diff options
Diffstat (limited to 'stdlib/source/library/lux/meta/compiler')
214 files changed, 36613 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/meta/compiler/arity.lux b/stdlib/source/library/lux/meta/compiler/arity.lux new file mode 100644 index 000000000..9d88e1d0f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/arity.lux @@ -0,0 +1,17 @@ +(.require + [library + [lux (.except) + [math + [number + ["n" nat]]]]]) + +(type .public Arity + Nat) + +(with_template [<comparison> <name>] + [(def .public <name> (-> Arity Bit) (<comparison> 1))] + + [n.< nullary?] + [n.= unary?] + [n.> multiary?] + ) diff --git a/stdlib/source/library/lux/meta/compiler/default/init.lux b/stdlib/source/library/lux/meta/compiler/default/init.lux new file mode 100644 index 000000000..6d6704655 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/default/init.lux @@ -0,0 +1,291 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" try (.only Try)] + ["[0]" exception]] + [data + [binary (.only Binary)] + ["[0]" product] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" dictionary] + ["[0]" set] + ["[0]" sequence (.use "[1]#[0]" functor)]]] + ["[0]" meta (.only) + ["@" target (.only Target)] + ["[0]" configuration (.only Configuration)] + ["[0]" version]] + [world + ["[0]" file]]]] + ["[0]" // + ["/[1]" // (.only Instancer) + ["[1][0]" phase] + [language + [lux + [program (.only Program)] + ["[1][0]" syntax (.only Aliases)] + ["[1][0]" synthesis] + ["[1][0]" declaration (.only Requirements)] + ["[1][0]" generation] + ["[1][0]" analysis (.only) + [macro (.only Expander)] + ["[1]/[0]" evaluation] + ["[0]A" module]] + [phase + ["[0]P" analysis] + ["[0]P" synthesis] + ["[0]P" declaration] + ["[0]" extension (.only Extender) + ["[0]E" analysis] + ["[0]E" synthesis] + [declaration + ["[0]D" lux]]]]]] + [meta + ["[0]" archive (.only Archive) + ["[0]" registry (.only Registry)] + ["[0]" module (.only) + ["[0]" descriptor] + ["[0]" document]]]]]]) + +(def .public (state target module configuration expander host_analysis host generate generation_bundle) + (All (_ anchor expression declaration) + (-> Target + descriptor.Module + Configuration + Expander + ///analysis.Bundle + (///generation.Host expression declaration) + (///generation.Phase anchor expression declaration) + (///generation.Bundle anchor expression declaration) + (///declaration.State+ anchor expression declaration))) + (let [synthesis_state [synthesisE.bundle ///synthesis.init] + generation_state [generation_bundle (///generation.state host module)] + eval (///analysis/evaluation.evaluator expander synthesis_state generation_state generate) + analysis_state [(analysisE.bundle eval host_analysis) + (///analysis.state (///analysis.info version.latest target configuration))]] + [extension.empty + [///declaration.#analysis [///declaration.#state analysis_state + ///declaration.#phase (analysisP.phase expander)] + ///declaration.#synthesis [///declaration.#state synthesis_state + ///declaration.#phase synthesisP.phase] + ///declaration.#generation [///declaration.#state generation_state + ///declaration.#phase generate]]])) + +(def .public (with_default_declarations expander host_analysis program anchorT,expressionT,declarationT extender) + (All (_ anchor expression declaration) + (-> Expander + ///analysis.Bundle + (Program expression declaration) + [Type Type Type] + Extender + (-> (///declaration.State+ anchor expression declaration) + (///declaration.State+ anchor expression declaration)))) + (function (_ [declaration_extensions sub_state]) + [(dictionary.composite declaration_extensions + (luxD.bundle expander host_analysis program anchorT,expressionT,declarationT extender)) + sub_state])) + +(type Reader + (-> Source (Either [Source Text] [Source Code]))) + +(def (reader current_module aliases [location offset source_code]) + (-> descriptor.Module Aliases Source (///analysis.Operation Reader)) + (function (_ [bundle state]) + {try.#Success [[bundle state] + (///syntax.parse current_module aliases ("lux text size" source_code))]})) + +(def (read source reader) + (-> Source Reader (///analysis.Operation [Source Code])) + (function (_ [bundle compiler]) + (case (reader source) + {.#Left [source' error]} + {try.#Failure error} + + {.#Right [source' output]} + (let [[location _] output] + {try.#Success [[bundle (|> compiler + (has .#source source') + (has .#location location))] + [source' output]]})))) + +(type (Operation a) + (All (_ anchor expression declaration) + (///declaration.Operation anchor expression declaration a))) + +(type (Payload declaration) + [(///generation.Buffer declaration) + Registry]) + +(def (begin dependencies hash input) + (-> (List descriptor.Module) Nat ///.Input + (All (_ anchor expression declaration) + (///declaration.Operation anchor expression declaration + [Source (Payload declaration)]))) + (do ///phase.monad + [.let [module (the ///.#module input)] + _ (///declaration.set_current_module module)] + (///declaration.lifted_analysis + (do [! ///phase.monad] + [_ (moduleA.create hash module) + _ (monad.each ! moduleA.import dependencies) + .let [source (///analysis.source (the ///.#module input) (the ///.#code input))] + _ (///analysis.set_source_code source)] + (in [source [///generation.empty_buffer + registry.empty]]))))) + +(def (end module) + (-> descriptor.Module + (All (_ anchor expression declaration) + (///declaration.Operation anchor expression declaration [.Module (Payload declaration)]))) + (do ///phase.monad + [_ (///declaration.lifted_analysis + (moduleA.set_compiled module)) + analysis_module (<| (is (Operation .Module)) + ///declaration.lifted_analysis + extension.lifted + meta.current_module) + final_buffer (///declaration.lifted_generation + ///generation.buffer) + final_registry (///declaration.lifted_generation + ///generation.get_registry)] + (in [analysis_module [final_buffer + final_registry]]))) + +... TODO: Inline ASAP +(def (get_current_payload _) + (All (_ declaration) + (-> (Payload declaration) + (All (_ anchor expression) + (///declaration.Operation anchor expression declaration + (Payload declaration))))) + (do ///phase.monad + [buffer (///declaration.lifted_generation + ///generation.buffer) + registry (///declaration.lifted_generation + ///generation.get_registry)] + (in [buffer registry]))) + +... TODO: Inline ASAP +(def (process_declaration wrapper archive expander pre_payoad code) + (All (_ declaration) + (-> ///phase.Wrapper Archive Expander (Payload declaration) Code + (All (_ anchor expression) + (///declaration.Operation anchor expression declaration + [Requirements (Payload declaration)])))) + (do ///phase.monad + [.let [[pre_buffer pre_registry] pre_payoad] + _ (///declaration.lifted_generation + (///generation.set_buffer pre_buffer)) + _ (///declaration.lifted_generation + (///generation.set_registry pre_registry)) + requirements (let [execute! (declarationP.phase wrapper expander)] + (execute! archive code)) + post_payload (..get_current_payload pre_payoad)] + (in [requirements post_payload]))) + +(def (iteration' wrapper archive expander reader source pre_payload) + (All (_ declaration) + (-> ///phase.Wrapper Archive Expander Reader Source (Payload declaration) + (All (_ anchor expression) + (///declaration.Operation anchor expression declaration + [Source Requirements (Payload declaration)])))) + (do ///phase.monad + [[source code] (///declaration.lifted_analysis + (..read source reader)) + [requirements post_payload] (process_declaration wrapper archive expander pre_payload code)] + (in [source requirements post_payload]))) + +(def (iteration wrapper archive expander module source pre_payload aliases) + (All (_ declaration) + (-> ///phase.Wrapper Archive Expander descriptor.Module Source (Payload declaration) Aliases + (All (_ anchor expression) + (///declaration.Operation anchor expression declaration + (Maybe [Source Requirements (Payload declaration)]))))) + (do ///phase.monad + [reader (///declaration.lifted_analysis + (..reader module aliases source))] + (function (_ state) + (case (///phase.result' state (..iteration' wrapper archive expander reader source pre_payload)) + {try.#Success [state source&requirements&buffer]} + {try.#Success [state {.#Some source&requirements&buffer}]} + + {try.#Failure error} + (if (exception.match? ///syntax.end_of_file error) + {try.#Success [state {.#None}]} + (exception.with ///.cannot_compile module {try.#Failure error})))))) + +(def (default_dependencies prelude input) + (-> descriptor.Module ///.Input (List descriptor.Module)) + (list.partial descriptor.runtime + (if (text#= prelude (the ///.#module input)) + (list) + (list prelude)))) + +(def module_aliases + (-> .Module Aliases) + (|>> (the .#module_aliases) (dictionary.of_list text.hash))) + +(def .public (compiler wrapper expander prelude write_declaration) + (All (_ anchor expression declaration) + (-> ///phase.Wrapper Expander descriptor.Module (-> declaration Binary) + (Instancer (///declaration.State+ anchor expression declaration) .Module))) + (let [execute! (declarationP.phase wrapper expander)] + (function (_ key parameters input) + (let [dependencies (default_dependencies prelude input)] + [///.#dependencies dependencies + ///.#process (function (_ state archive) + (do [! try.monad] + [.let [hash (text#hash (the ///.#code input))] + [state [source buffer]] (<| (///phase.result' state) + (..begin dependencies hash input)) + .let [module (the ///.#module input)]] + (loop (again [iteration (<| (///phase.result' state) + (..iteration wrapper archive expander module source buffer ///syntax.no_aliases))]) + (do ! + [[state ?source&requirements&temporary_payload] iteration] + (case ?source&requirements&temporary_payload + {.#None} + (do ! + [[state [analysis_module [final_buffer final_registry]]] (///phase.result' state (..end module)) + .let [descriptor [descriptor.#hash hash + descriptor.#name module + descriptor.#file (the ///.#file input) + descriptor.#references (set.of_list text.hash dependencies) + descriptor.#state {.#Compiled}]]] + (in [state + {.#Right [[module.#id (try.else module.runtime (archive.id module archive)) + module.#descriptor descriptor + module.#document (document.document key analysis_module)] + (sequence#each (function (_ [artifact_id custom declaration]) + [artifact_id custom (write_declaration declaration)]) + final_buffer) + final_registry]}])) + + {.#Some [source requirements temporary_payload]} + (let [[temporary_buffer temporary_registry] temporary_payload] + (in [state + {.#Left [///.#dependencies (|> requirements + (the ///declaration.#imports) + (list#each product.left)) + ///.#process (function (_ state archive) + (again (<| (///phase.result' state) + (do [! ///phase.monad] + [analysis_module (<| (is (Operation .Module)) + ///declaration.lifted_analysis + extension.lifted + meta.current_module) + _ (///declaration.lifted_generation + (///generation.set_buffer temporary_buffer)) + _ (///declaration.lifted_generation + (///generation.set_registry temporary_registry)) + _ (|> requirements + (the ///declaration.#referrals) + (monad.each ! (execute! archive))) + temporary_payload (..get_current_payload temporary_payload)] + (..iteration wrapper archive expander module source temporary_payload (..module_aliases analysis_module))))))]}])) + )))))])))) diff --git a/stdlib/source/library/lux/meta/compiler/default/platform.lux b/stdlib/source/library/lux/meta/compiler/default/platform.lux new file mode 100644 index 000000000..cdea7252d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/default/platform.lux @@ -0,0 +1,888 @@ +(.require + [library + [lux (.except) + ["[0]" debug] + ["[0]" static] + [abstract + ["[0]" monad (.only Monad do)]] + [control + ["[0]" function] + ["[0]" maybe] + ["[0]" try (.only Try) (.use "[1]#[0]" monad)] + ["[0]" exception (.only exception)] + [concurrency + ["[0]" async (.only Async Resolver) (.use "[1]#[0]" monad)] + ["[0]" stm (.only Var STM)]]] + [data + ["[0]" bit] + ["[0]" product] + ["[0]" binary (.only Binary) + ["_" \\format (.only Format)]] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format]] + [collection + ["[0]" dictionary (.only Dictionary)] + ["[0]" sequence (.only Sequence) (.use "[1]#[0]" mix)] + ["[0]" set (.only Set)] + ["[0]" list (.use "[1]#[0]" monoid functor mix)]]] + ["[0]" meta (.only) + ["@" target] + ["[0]" configuration (.only Configuration)] + [type (.only sharing) + ["[0]" check]]] + [world + ["[0]" file (.only Path)] + ["[0]" console]]]] + ["[0]" // + ["[1][0]" init] + ["/[1]" // (.only) + ["[1][0]" phase (.only Phase)] + [language + [lux + [program (.only Program)] + ["$" /] + ["[0]" syntax] + ["[1][0]" synthesis] + ["[1][0]" generation (.only Buffer)] + ["[1][0]" declaration] + ["[1][0]" analysis (.only) + [macro (.only Expander)] + ["[0]A" module]] + [phase + ["[0]" extension (.only Extender)]]]] + [meta + [import (.only Import)] + ["[0]" context] + ["[0]" cache (.only) + ["[1]/[0]" archive] + ["[1]/[0]" module] + ["[1]/[0]" artifact]] + [cli (.only Compilation Library) + ["[0]" compiler]] + ["[0]" archive (.only Output Archive) + [key (.only Key)] + ["[0]" registry (.only Registry)] + ["[0]" artifact] + ["[0]" module (.only) + ["[0]" descriptor (.only Descriptor)] + ["[0]" document (.only Document)]]] + ["[0]" io + ["_[1]" /] + ["[1]" context] + ["ioW" archive]]]]]) + +(with_expansions [<type_vars> (these anchor expression declaration) + <Operation> (these ///generation.Operation <type_vars>)] + (type .public (Platform <type_vars>) + (Record + [#file_system (file.System Async) + #host (///generation.Host expression declaration) + #phase (///generation.Phase <type_vars>) + #runtime (<Operation> [Registry Output]) + #phase_wrapper (-> Archive (<Operation> ///phase.Wrapper)) + #write (-> declaration Binary)])) + + ... TODO: Get rid of this + (type (Action a) + (Async (Try a))) + + ... TODO: Get rid of this + (def monad + (as (Monad Action) + (try.with async.monad))) + + (with_expansions [<Platform> (these (Platform <type_vars>)) + <State+> (these (///declaration.State+ <type_vars>)) + <Bundle> (these (///generation.Bundle <type_vars>))] + + (def (format //) + (All (_ a) + (-> (Format a) + (Format [(module.Module a) Registry]))) + (all _.and + (all _.and + _.nat + descriptor.format + (document.format //)) + registry.format + )) + + (def (cache_module context platform @module key format entry) + (All (_ <type_vars> document) + (-> context.Context <Platform> module.ID (Key document) (Format document) (archive.Entry document) + (Async (Try Any)))) + (let [system (the #file_system platform) + write_artifact! (is (-> [artifact.ID (Maybe Text) Binary] (Action Any)) + (function (_ [artifact_id custom content]) + (is (Async (Try Any)) + (cache/artifact.cache! system context @module artifact_id content))))] + (do [! ..monad] + [_ (is (Async (Try Any)) + (cache/module.enable! async.monad system context @module)) + _ (for @.python (|> entry + (the archive.#output) + sequence.list + (list.sub 128) + (monad.each ! (monad.each ! write_artifact!)) + (is (Action (List (List Any))))) + (|> entry + (the archive.#output) + sequence.list + (monad.each ..monad write_artifact!) + (is (Action (List Any))))) + document (at async.monad in + (document.marked? key (the [archive.#module module.#document] entry)))] + (is (Async (Try Any)) + (|> [(|> entry + (the archive.#module) + (has module.#document document)) + (the archive.#registry entry)] + (_.result (..format format)) + (cache/module.cache! system context @module)))))) + + ... TODO: Inline ASAP + (def initialize_buffer! + (All (_ <type_vars>) + (///generation.Operation <type_vars> Any)) + (///generation.set_buffer ///generation.empty_buffer)) + + ... TODO: Inline ASAP + (def (compile_runtime! platform) + (All (_ <type_vars>) + (-> <Platform> (///generation.Operation <type_vars> [Registry Output]))) + (do ///phase.monad + [_ ..initialize_buffer!] + (the #runtime platform))) + + (def runtime_descriptor + Descriptor + [descriptor.#hash 0 + descriptor.#name descriptor.runtime + descriptor.#file "" + descriptor.#references (set.empty text.hash) + descriptor.#state {.#Compiled}]) + + (def runtime_document + (Document .Module) + (document.document $.key (moduleA.empty 0))) + + (def runtime_module + (module.Module .Module) + [module.#id module.runtime + module.#descriptor runtime_descriptor + module.#document runtime_document]) + + (def (process_runtime archive platform) + (All (_ <type_vars>) + (-> Archive <Platform> + (///declaration.Operation <type_vars> + [Archive (archive.Entry .Module)]))) + (do ///phase.monad + [[registry payload] (///declaration.lifted_generation + (..compile_runtime! platform)) + .let [entry [..runtime_module payload registry]] + archive (///phase.lifted (if (archive.reserved? archive descriptor.runtime) + (archive.has descriptor.runtime entry archive) + (do try.monad + [[_ archive] (archive.reserve descriptor.runtime archive)] + (archive.has descriptor.runtime entry archive))))] + (in [archive entry]))) + + (def (initialize_state extender + [analysers + synthesizers + generators + declarations] + analysis_state + state) + (All (_ <type_vars>) + (-> Extender + [(Dictionary Text ///analysis.Handler) + (Dictionary Text ///synthesis.Handler) + (Dictionary Text (///generation.Handler <type_vars>)) + (Dictionary Text (///declaration.Handler <type_vars>))] + .Lux + <State+> + (Try <State+>))) + (|> (sharing [<type_vars>] + (is <State+> + state) + (is (///declaration.Operation <type_vars> Any) + (do [! ///phase.monad] + [_ (///declaration.lifted_analysis + (do ! + [_ (///analysis.set_state analysis_state)] + (extension.with extender analysers))) + _ (///declaration.lifted_synthesis + (extension.with extender synthesizers)) + _ (///declaration.lifted_generation + (extension.with extender (as_expected generators))) + _ (extension.with extender (as_expected declarations))] + (in [])))) + (///phase.result' state) + (at try.monad each product.left))) + + (def (phase_wrapper archive platform state) + (All (_ <type_vars>) + (-> Archive <Platform> <State+> (Try [<State+> ///phase.Wrapper]))) + (|> archive + ((the #phase_wrapper platform)) + ///declaration.lifted_generation + (///phase.result' state))) + + (def (complete_extensions host_declaration_bundle phase_wrapper [analysers synthesizers generators declarations]) + (All (_ <type_vars>) + (-> (-> ///phase.Wrapper (///declaration.Bundle <type_vars>)) + ///phase.Wrapper + [(Dictionary Text ///analysis.Handler) + (Dictionary Text ///synthesis.Handler) + (Dictionary Text (///generation.Handler <type_vars>)) + (Dictionary Text (///declaration.Handler <type_vars>))] + [(Dictionary Text ///analysis.Handler) + (Dictionary Text ///synthesis.Handler) + (Dictionary Text (///generation.Handler <type_vars>)) + (Dictionary Text (///declaration.Handler <type_vars>))])) + [analysers + synthesizers + generators + (dictionary.composite declarations (host_declaration_bundle phase_wrapper))]) + + (def .public (initialize context module expander host_analysis platform generation_bundle host_declaration_bundle program anchorT,expressionT,declarationT extender + import compilation_sources compilation_configuration) + (All (_ <type_vars>) + (-> context.Context + descriptor.Module + Expander + ///analysis.Bundle + <Platform> + <Bundle> + (-> ///phase.Wrapper (///declaration.Bundle <type_vars>)) + (Program expression declaration) + [Type Type Type] (-> ///phase.Wrapper Extender) + Import (List _io.Context) Configuration + (Async (Try [<State+> Archive ///phase.Wrapper])))) + (do [! (try.with async.monad)] + [.let [state (//init.state (the context.#host context) + module + compilation_configuration + expander + host_analysis + (the #host platform) + (the #phase platform) + generation_bundle)] + _ (is (Async (Try Any)) + (cache.enable! async.monad (the #file_system platform) context)) + [archive analysis_state bundles] (ioW.thaw (list) compilation_configuration (the #host platform) (the #file_system platform) context import compilation_sources) + .let [with_missing_extensions + (is (All (_ <type_vars>) + (-> <Platform> (Program expression declaration) <State+> + (Async (Try [///phase.Wrapper <State+>])))) + (function (_ platform program state) + (async#in + (do try.monad + [[state phase_wrapper] (..phase_wrapper archive platform state)] + (|> state + (initialize_state (extender phase_wrapper) + (as_expected (..complete_extensions host_declaration_bundle phase_wrapper (as_expected bundles))) + analysis_state) + (try#each (|>> (//init.with_default_declarations expander host_analysis program anchorT,expressionT,declarationT (extender phase_wrapper)) + [phase_wrapper])))))))]] + (if (archive.archived? archive descriptor.runtime) + (do ! + [[phase_wrapper state] (with_missing_extensions platform program state)] + (in [state archive phase_wrapper])) + (do ! + [[state [archive payload]] (|> (..process_runtime archive platform) + (///phase.result' state) + async#in) + _ (..cache_module context platform 0 $.key $.format payload) + + [phase_wrapper state] (with_missing_extensions platform program state)] + (in [state archive phase_wrapper]))))) + + (def compilation_log_separator + (%.format text.new_line text.tab)) + + (def (module_compilation_log module) + (All (_ <type_vars>) + (-> descriptor.Module <State+> Text)) + (|>> (the [extension.#state + ///declaration.#generation + ///declaration.#state + extension.#state + ///generation.#log]) + (sequence#mix (function (_ right left) + (%.format left ..compilation_log_separator right)) + module))) + + (def with_reset_log + (All (_ <type_vars>) + (-> <State+> <State+>)) + (has [extension.#state + ///declaration.#generation + ///declaration.#state + extension.#state + ///generation.#log] + sequence.empty)) + + (def empty + (Set descriptor.Module) + (set.empty text.hash)) + + (type Mapping + (Dictionary descriptor.Module (Set descriptor.Module))) + + (type Dependence + (Record + [#depends_on Mapping + #depended_by Mapping])) + + (def independence + Dependence + (let [empty (dictionary.empty text.hash)] + [#depends_on empty + #depended_by empty])) + + (def (depend module import dependence) + (-> descriptor.Module descriptor.Module Dependence Dependence) + (let [transitive_dependency (is (-> (-> Dependence Mapping) descriptor.Module (Set descriptor.Module)) + (function (_ lens module) + (|> dependence + lens + (dictionary.value module) + (maybe.else ..empty)))) + transitive_depends_on (transitive_dependency (the #depends_on) import) + transitive_depended_by (transitive_dependency (the #depended_by) module) + update_dependence (is (-> [descriptor.Module (Set descriptor.Module)] [descriptor.Module (Set descriptor.Module)] + (-> Mapping Mapping)) + (function (_ [source forward] [target backward]) + (function (_ mapping) + (let [with_dependence+transitives + (|> mapping + (dictionary.revised' source ..empty (set.has target)) + (dictionary.revised source (set.union forward)))] + (list#mix (function (_ previous) + (dictionary.revised' previous ..empty (set.has target))) + with_dependence+transitives + (set.list backward))))))] + (|> dependence + (revised #depends_on + (update_dependence + [module transitive_depends_on] + [import transitive_depended_by])) + (revised #depended_by + ((function.flipped update_dependence) + [module transitive_depends_on] + [import transitive_depended_by]))))) + + (def (circular_dependency? module import dependence) + (-> descriptor.Module descriptor.Module Dependence Bit) + (let [dependence? (is (-> descriptor.Module (-> Dependence Mapping) descriptor.Module Bit) + (function (_ from relationship to) + (let [targets (|> dependence + relationship + (dictionary.value from) + (maybe.else ..empty))] + (set.member? targets to))))] + (or (dependence? import (the #depends_on) module) + (dependence? module (the #depended_by) import)))) + + (exception .public (module_cannot_import_itself [module descriptor.Module]) + (exception.report + "Module" (%.text module))) + + (exception .public (cannot_import_circular_dependency [importer descriptor.Module + importee descriptor.Module]) + (exception.report + "Importer" (%.text importer) + "importee" (%.text importee))) + + (exception .public (cannot_import_twice [importer descriptor.Module + duplicates (Set descriptor.Module)]) + (exception.report + "Importer" (%.text importer) + "Duplicates" (%.list %.text (set.list duplicates)))) + + (def (verify_dependencies importer importee dependence) + (-> descriptor.Module descriptor.Module Dependence (Try Any)) + (cond (text#= importer importee) + (exception.except ..module_cannot_import_itself [importer]) + + (..circular_dependency? importer importee dependence) + (exception.except ..cannot_import_circular_dependency [importer importee]) + + ... else + {try.#Success []})) + + (exception .public (cannot_overwrite_extension [extension extension.Name]) + (exception.report + "Extension" (%.text extension))) + + (def (with_extensions from to) + (All (_ state input output) + (-> (extension.Bundle state input output) + (extension.Bundle state input output) + (Try (extension.Bundle state input output)))) + (monad.mix try.monad + (function (_ [extension expected] output) + (with_expansions [<inherited> (dictionary.has extension expected output)] + (case (dictionary.value extension output) + {.#None} + {try.#Success <inherited>} + + {.#Some actual} + (if (same? expected actual) + {try.#Success <inherited>} + (exception.except ..cannot_overwrite_extension [extension]))))) + to + ... TODO: Come up with something better. This is not an ideal solution because it can mask overwrites happening across multiple imported modules. + (list.only (|>> product.left (dictionary.key? to) not) + (dictionary.entries from)))) + + (with_template [<name> <path>] + [(def (<name> from state) + (All (_ <type_vars>) + (-> <State+> <State+> (Try <State+>))) + (do try.monad + [inherited (with_extensions (the <path> from) (the <path> state))] + (in (has <path> inherited state))))] + + [with_analysis_extensions [extension.#state ///declaration.#analysis ///declaration.#state extension.#bundle]] + [with_synthesis_extensions [extension.#state ///declaration.#synthesis ///declaration.#state extension.#bundle]] + [with_generation_extensions [extension.#state ///declaration.#generation ///declaration.#state extension.#bundle]] + [with_declaration_extensions [extension.#bundle]] + ) + + (def (with_all_extensions from state) + (All (_ <type_vars>) + (-> <State+> <State+> (Try <State+>))) + (do try.monad + [state (with_analysis_extensions from state) + state (with_synthesis_extensions from state) + state (with_generation_extensions from state)] + (with_declaration_extensions from state))) + + (type (Context state) + [Archive state]) + + (type (Result state) + (Try (Context state))) + + (type (Return state) + (Async (Result state))) + + (type (Signal state) + (Resolver (Result state))) + + (type (Pending state) + [(Return state) + (Signal state)]) + + (type (Importer state) + (-> (List ///.Custom) descriptor.Module descriptor.Module (Return state))) + + (type (Compiler state) + (-> (List ///.Custom) descriptor.Module (Importer state) module.ID (Context state) descriptor.Module (Return state))) + + (with_expansions [Lux_Context (..Context <State+>) + Lux_Return (..Return <State+>) + Lux_Signal (..Signal <State+>) + Lux_Pending (..Pending <State+>) + Lux_Importer (..Importer <State+>) + Lux_Compiler (..Compiler <State+>)] + (def (parallel initial) + (All (_ <type_vars>) + (-> Lux_Context + (-> Lux_Compiler Lux_Importer))) + (let [current (stm.var initial) + pending (sharing [<type_vars>] + (is Lux_Context + initial) + (is (Var (Dictionary descriptor.Module Lux_Pending)) + (as_expected (stm.var (dictionary.empty text.hash))))) + dependence (is (Var Dependence) + (stm.var ..independence))] + (function (_ compile) + (function (import! customs importer module) + (do [! async.monad] + [[return signal] (sharing [<type_vars>] + (is Lux_Context + initial) + (is (Async [Lux_Return (Maybe [Lux_Context + module.ID + Lux_Signal])]) + (as_expected + (stm.commit! + (do [! stm.monad] + [dependence (if (text#= descriptor.runtime importer) + (stm.read dependence) + (do ! + [[_ dependence] (stm.update (..depend importer module) dependence)] + (in dependence)))] + (case (..verify_dependencies importer module dependence) + {try.#Failure error} + (in [(async.resolved {try.#Failure error}) + {.#None}]) + + {try.#Success _} + (do ! + [[archive state] (stm.read current)] + (if (archive.archived? archive module) + (in [(async#in {try.#Success [archive state]}) + {.#None}]) + (do ! + [@pending (stm.read pending)] + (case (dictionary.value module @pending) + {.#Some [return signal]} + (in [return + {.#None}]) + + {.#None} + (case (if (archive.reserved? archive module) + (do try.monad + [@module (archive.id module archive)] + (in [@module archive])) + (archive.reserve module archive)) + {try.#Success [@module archive]} + (do ! + [_ (stm.write [archive state] current) + .let [[return signal] (sharing [<type_vars>] + (is Lux_Context + initial) + (is Lux_Pending + (async.async [])))] + _ (stm.update (dictionary.has module [return signal]) pending)] + (in [return + {.#Some [[archive state] + @module + signal]}])) + + {try.#Failure error} + (in [(async#in {try.#Failure error}) + {.#None}])))))))))))) + _ (case signal + {.#None} + (in []) + + {.#Some [context @module resolver]} + (do ! + [result (compile customs importer import! @module context module) + result (case result + {try.#Failure error} + (in result) + + {try.#Success [resulting_archive resulting_state]} + (stm.commit! (do stm.monad + [[_ [merged_archive _]] (stm.update (function (_ [archive state]) + [(archive.composite resulting_archive archive) + state]) + current)] + (in {try.#Success [merged_archive resulting_state]}))))] + (async.future (resolver result))))] + return))))) + + ... TODO: Find a better way, as this only works for the Lux compiler. + (def (updated_state archive extended_states state) + (All (_ <type_vars>) + (-> Archive (List <State+>) <State+> (Try <State+>))) + (do [! try.monad] + [modules (monad.each ! (function (_ module) + (do ! + [entry (archive.find module archive) + lux_module (|> entry + (the [archive.#module module.#document]) + (document.content $.key))] + (in [module lux_module]))) + (archive.archived archive)) + .let [additions (|> modules + (list#each product.left) + (set.of_list text.hash)) + with_modules (is (All (_ <type_vars>) + (-> <State+> <State+>)) + (revised [extension.#state + ///declaration.#analysis + ///declaration.#state + extension.#state] + (is (All (_ a) (-> a a)) + (function (_ analysis_state) + (|> analysis_state + (as .Lux) + (revised .#modules (function (_ current) + (list#composite (list.only (|>> product.left + (set.member? additions) + not) + current) + modules))) + as_expected)))))] + state (monad.mix ! with_all_extensions state extended_states)] + (in (with_modules state)))) + + (def (set_current_module module state) + (All (_ <type_vars>) + (-> descriptor.Module <State+> <State+>)) + (|> (///declaration.set_current_module module) + (///phase.result' state) + try.trusted + product.left)) + + ... TODO: Come up with a less hacky way to prevent duplicate imports. + ... This currently assumes that all imports will be specified once in a single .require form. + ... This might not be the case in the future. + (def (with_new_dependencies new_dependencies all_dependencies) + (-> (List descriptor.Module) (Set descriptor.Module) [(Set descriptor.Module) (Set descriptor.Module)]) + (let [[all_dependencies duplicates _] (is [(Set descriptor.Module) (Set descriptor.Module) Bit] + (list#mix (function (_ new [all duplicates seen_prelude?]) + (if (set.member? all new) + (if (text#= .prelude new) + (if seen_prelude? + [all (set.has new duplicates) seen_prelude?] + [all duplicates true]) + [all (set.has new duplicates) seen_prelude?]) + [(set.has new all) duplicates seen_prelude?])) + (is [(Set descriptor.Module) (Set descriptor.Module) Bit] + [all_dependencies ..empty (set.empty? all_dependencies)]) + new_dependencies))] + [all_dependencies duplicates])) + + (def (any|after_imports customs import! module duplicates new_dependencies archive) + (All (_ <type_vars> + state document object) + (-> (List ///.Custom) (..Importer state) descriptor.Module (Set descriptor.Module) (List descriptor.Module) Archive + (Async (Try [Archive (List state)])))) + (do [! (try.with async.monad)] + [] + (if (set.empty? duplicates) + (case new_dependencies + {.#End} + (in [archive (list)]) + + {.#Item _} + (do ! + [archive,state/* (|> new_dependencies + (list#each (import! customs module)) + (monad.all ..monad))] + (in [(|> archive,state/* + (list#each product.left) + (list#mix archive.composite archive)) + (list#each product.right archive,state/*)]))) + (async#in (exception.except ..cannot_import_twice [module duplicates]))))) + + (def (lux|after_imports customs import! module duplicates new_dependencies [archive state]) + (All (_ <type_vars>) + (-> (List ///.Custom) Lux_Importer descriptor.Module (Set descriptor.Module) (List descriptor.Module) Lux_Context Lux_Return)) + (do (try.with async.monad) + [[archive state/*] (any|after_imports customs import! module duplicates new_dependencies archive)] + (in [archive (case state/* + {.#End} + state + + {.#Item _} + (try.trusted (..updated_state archive state/* state)))]))) + + (def (next_compilation module [archive state] compilation) + (All (_ <type_vars>) + (-> descriptor.Module Lux_Context (///.Compilation <State+> .Module Any) + (Try [<State+> (Either (///.Compilation <State+> .Module Any) + (archive.Entry Any))]))) + ((the ///.#process compilation) + ... TODO: The "///declaration.set_current_module" below shouldn't be necessary. Remove it ASAP. + ... TODO: The context shouldn't need to be re-set either. + (|> (///declaration.set_current_module module) + (///phase.result' state) + try.trusted + product.left) + archive)) + + (def (compiler phase_wrapper expander platform) + (All (_ <type_vars>) + (-> ///phase.Wrapper Expander <Platform> + (///.Compiler <State+> .Module Any))) + (let [instancer (//init.compiler phase_wrapper expander syntax.prelude (the #write platform))] + (instancer $.key (list)))) + + (def (custom_compiler import context platform compilation_sources compiler + custom_key custom_format custom_compilation) + (All (_ <type_vars> + state document object) + (-> Import context.Context <Platform> (List _io.Context) (///.Compiler <State+> .Module Any) + (Key document) (Format document) (///.Compilation state document object) + (-> (List ///.Custom) descriptor.Module Lux_Importer module.ID (..Context state) descriptor.Module (..Return state)))) + (function (_ customs importer import! @module [archive state] module) + (loop (again [[archive state] [archive state] + compilation custom_compilation + all_dependencies (is (Set descriptor.Module) + (set.of_list text.hash (list)))]) + (do [! (try.with async.monad)] + [.let [new_dependencies (the ///.#dependencies compilation) + [all_dependencies duplicates] (with_new_dependencies new_dependencies all_dependencies)] + [archive _] (any|after_imports customs import! module duplicates new_dependencies archive)] + (case ((the ///.#process compilation) state archive) + {try.#Success [state more|done]} + (case more|done + {.#Left more} + (let [continue! (sharing [state document object] + (is (///.Compilation state document object) + custom_compilation) + (is (-> (..Context state) (///.Compilation state document object) (Set descriptor.Module) + (..Return state)) + (as_expected again)))] + (continue! [archive state] more all_dependencies)) + + {.#Right entry} + (do ! + [.let [entry (has [archive.#module module.#descriptor descriptor.#references] all_dependencies entry)] + _ (..cache_module context platform @module custom_key custom_format entry)] + (async#in (do try.monad + [archive (archive.has module entry archive)] + (in [archive state]))))) + + {try.#Failure error} + (do ! + [_ (cache/archive.cache! (the #file_system platform) context archive)] + (async#in {try.#Failure error}))))))) + + (def (lux_compiler import context platform compilation_sources compiler compilation) + (All (_ <type_vars>) + (-> Import context.Context <Platform> (List _io.Context) (///.Compiler <State+> .Module Any) + (///.Compilation <State+> .Module Any) + Lux_Compiler)) + (function (_ customs importer import! @module [archive state] module) + (loop (again [[archive state] [archive (..set_current_module module state)] + compilation compilation + all_dependencies (is (Set descriptor.Module) + (set.of_list text.hash (list)))]) + (do [! (try.with async.monad)] + [.let [new_dependencies (the ///.#dependencies compilation) + [all_dependencies duplicates] (with_new_dependencies new_dependencies all_dependencies)] + [archive state] (lux|after_imports customs import! module duplicates new_dependencies [archive state])] + (case (next_compilation module [archive state] compilation) + {try.#Success [state more|done]} + (case more|done + {.#Left more} + (let [continue! (sharing [<type_vars>] + (is <Platform> + platform) + (is (-> Lux_Context (///.Compilation <State+> .Module Any) (Set descriptor.Module) + (Action [Archive <State+>])) + (as_expected again)))] + (continue! [archive state] more all_dependencies)) + + {.#Right entry} + (do ! + [_ (let [report (..module_compilation_log module state)] + (with_expansions [<else> (in (debug.log! report))] + (for @.js (is (Async (Try Any)) + (case console.default + {.#None} + <else> + + {.#Some console} + (console.write_line report console))) + <else>))) + .let [entry (has [archive.#module module.#descriptor descriptor.#references] all_dependencies entry)] + _ (..cache_module context platform @module $.key $.format (as (archive.Entry .Module) entry))] + (async#in (do try.monad + [archive (archive.has module entry archive)] + (in [archive + (..with_reset_log state)]))))) + + {try.#Failure error} + (do ! + [_ (cache/archive.cache! (the #file_system platform) context archive)] + (async#in {try.#Failure error}))))))) + + (for @.old (these (def Fake_State + Type + {.#Primitive (%.nat (static.random_nat)) (list)}) + + (def Fake_Document + Type + {.#Primitive (%.nat (static.random_nat)) (list)}) + + (def Fake_Object + Type + {.#Primitive (%.nat (static.random_nat)) (list)})) + (these)) + + (def (serial_compiler import context platform compilation_sources compiler) + (All (_ <type_vars>) + (-> Import context.Context <Platform> (List _io.Context) (///.Compiler <State+> .Module Any) + Lux_Compiler)) + (function (_ all_customs importer import! @module [archive lux_state] module) + (do [! (try.with async.monad)] + [input (io.read (the #file_system platform) + importer + import + compilation_sources + (the context.#host_module_extension context) + module)] + (loop (again [customs (for @.old (as (List (///.Custom Fake_State Fake_Document Fake_Object)) + all_customs) + all_customs)]) + (case customs + {.#End} + ((..lux_compiler import context platform compilation_sources compiler (compiler input)) + all_customs importer import! @module [archive lux_state] module) + + {.#Item [custom_state custom_key custom_format custom_parser custom_compiler] tail} + (case (custom_compiler input) + {try.#Failure _} + (again tail) + + {try.#Success custom_compilation} + (do ! + [[archive' custom_state'] ((..custom_compiler import context platform compilation_sources compiler + custom_key custom_format custom_compilation) + all_customs importer import! @module [archive custom_state] module)] + (in [archive' lux_state])))))))) + + (def .public Custom + Type + (type_literal (-> (List Text) (Try ///.Custom)))) + + (exception .public (invalid_custom_compiler [definition Symbol + type Type]) + (exception.report + "Definition" (%.symbol definition) + "Expected Type" (%.type ..Custom) + "Actual Type" (%.type type))) + + (def (custom import! it) + (All (_ <type_vars>) + (-> Lux_Importer compiler.Compiler (Async (Try [Lux_Context (List Text) Any])))) + (let [/#definition (the compiler.#definition it) + [/#module /#name] /#definition] + (do ..monad + [context (import! (list) descriptor.runtime /#module) + .let [[archive state] context + meta_state (the [extension.#state + ///declaration.#analysis + ///declaration.#state + extension.#state] + state)] + [_ /#type /#value] (|> /#definition + meta.export + (meta.result meta_state) + async#in)] + (async#in (if (check.subsumes? ..Custom /#type) + {try.#Success [context (the compiler.#parameters it) /#value]} + (exception.except ..invalid_custom_compiler [/#definition /#type])))))) + + (def .public (compile lux_compiler phase_wrapper import file_context expander platform compilation context) + (All (_ <type_vars>) + (-> (-> Any ..Custom) ///phase.Wrapper Import context.Context Expander <Platform> Compilation Lux_Context Lux_Return)) + (let [[host_dependencies libraries compilers sources target module configuration] compilation + import! (|> (..compiler phase_wrapper expander platform) + (serial_compiler import file_context platform sources) + (..parallel context))] + (do [! ..monad] + [customs (|> compilers + (list#each (function (_ it) + (do ! + [[context parameters custom] (..custom import! it)] + (async#in (|> custom + lux_compiler + (function.on parameters)))))) + (monad.all !))] + (import! customs descriptor.runtime module)))) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux.lux b/stdlib/source/library/lux/meta/compiler/language/lux.lux new file mode 100644 index 000000000..14adeb6d6 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux.lux @@ -0,0 +1,105 @@ +(.require + [library + [lux (.except) + [control + ["<>" parser]] + [data + ["[0]" binary + ["_" \\format (.only Format)] + ["<[1]>" \\parser (.only Parser)]]] + [meta + ["[0]" version]]]] + ["[0]" / + [analysis + ["[0]" module]] + [/// + [meta + [archive + ["[0]" signature] + ["[0]" key (.only Key)]]]]]) + +... TODO: Remove #module_hash, #imports & #module_state ASAP. +... TODO: Not just from this parser, but from the lux.Module type. +(def .public format + (Format .Module) + (let [definition (is (Format Definition) + (all _.and _.bit _.type _.any)) + labels (is (Format [Text (List Text)]) + (_.and _.text (_.list _.text))) + global_type (is (Format [Bit Type (Either [Text (List Text)] + [Text (List Text)])]) + (all _.and _.bit _.type (_.or labels labels))) + global_label (is (Format .Label) + (all _.and _.bit _.type (_.list _.text) _.nat)) + alias (is (Format Alias) + (_.and _.text _.text)) + global (is (Format Global) + (all _.or + definition + global_type + global_label + global_label + alias))] + (all _.and + ... #module_hash + _.nat + ... #module_aliases + (_.list alias) + ... #definitions + (_.list (_.and _.text global)) + ... #imports + (_.list _.text) + ... #module_state + _.any))) + +(def .public parser + (Parser .Module) + (let [definition (is (Parser Definition) + (all <>.and + <binary>.bit + <binary>.type + <binary>.any)) + labels (is (Parser [Text (List Text)]) + (all <>.and + <binary>.text + (<binary>.list <binary>.text))) + global_type (is (Parser [Bit Type (Either [Text (List Text)] + [Text (List Text)])]) + (all <>.and + <binary>.bit + <binary>.type + (<binary>.or labels labels))) + global_label (is (Parser .Label) + (all <>.and + <binary>.bit + <binary>.type + (<binary>.list <binary>.text) + <binary>.nat)) + alias (is (Parser Alias) + (all <>.and + <binary>.text + <binary>.text)) + global (is (Parser Global) + (all <binary>.or + definition + global_type + global_label + global_label + alias))] + (all <>.and + ... #module_hash + <binary>.nat + ... #module_aliases + (<binary>.list alias) + ... #definitions + (<binary>.list (<>.and <binary>.text global)) + ... #imports + (<binary>.list <binary>.text) + ... #module_state + (at <>.monad in {.#Cached})))) + +(def .public key + (Key .Module) + (key.key [signature.#name (symbol ..compiler) + signature.#version version.latest] + (module.empty 0))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux new file mode 100644 index 000000000..b975614df --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis.lux @@ -0,0 +1,387 @@ +(.require + [library + [lux (.except Tuple Variant Pattern nat int rev case local except) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)] + [monad (.only do)]] + [control + ["[0]" function] + ["[0]" maybe] + ["[0]" try (.only Try)] + ["[0]" exception (.only Exception)]] + [data + ["[0]" product] + ["[0]" bit (.use "[1]#[0]" equivalence)] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only Format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["n" nat] + ["i" int] + ["r" rev] + ["f" frac]]] + [meta + ["[0]" location] + ["[0]" configuration (.only Configuration)] + ["[0]" code + ["<[1]>" \\parser]] + [macro + [syntax (.only syntax)]]]]] + ["[0]" / + ["[1][0]" simple (.only Simple)] + ["[1][0]" complex (.only Tuple Variant Complex)] + ["[1][0]" pattern (.only Pattern)] + [// + [phase + ["[0]" extension (.only Extension)]] + [/// + [arity (.only Arity)] + ["[0]" version (.only Version)] + ["[0]" phase] + ["[0]" reference (.only Reference) + ["[0]" variable (.only Register Variable)]]]]]) + +(type .public (Branch' e) + (Record + [#when Pattern + #then e])) + +(type .public (Match' e) + [(Branch' e) (List (Branch' e))]) + +(type .public (Environment a) + (List a)) + +(type .public Analysis + (Rec Analysis + (.Variant + {#Simple Simple} + {#Structure (Complex Analysis)} + {#Reference Reference} + {#Case Analysis (Match' Analysis)} + {#Function (Environment Analysis) Analysis} + {#Apply Analysis Analysis} + {#Extension (Extension Analysis)}))) + +(type .public Branch + (Branch' Analysis)) + +(type .public Match + (Match' Analysis)) + +(def (branch_equivalence equivalence) + (-> (Equivalence Analysis) (Equivalence Branch)) + (implementation + (def (= [reference_pattern reference_body] [sample_pattern sample_body]) + (and (at /pattern.equivalence = reference_pattern sample_pattern) + (at equivalence = reference_body sample_body))))) + +(def .public equivalence + (Equivalence Analysis) + (implementation + (def (= reference sample) + (.case [reference sample] + [{#Simple reference} {#Simple sample}] + (at /simple.equivalence = reference sample) + + [{#Structure reference} {#Structure sample}] + (at (/complex.equivalence =) = reference sample) + + [{#Reference reference} {#Reference sample}] + (at reference.equivalence = reference sample) + + [{#Case [reference_analysis reference_match]} + {#Case [sample_analysis sample_match]}] + (and (= reference_analysis sample_analysis) + (at (list.equivalence (branch_equivalence =)) = {.#Item reference_match} {.#Item sample_match})) + + [{#Function [reference_environment reference_analysis]} + {#Function [sample_environment sample_analysis]}] + (and (= reference_analysis sample_analysis) + (at (list.equivalence =) = reference_environment sample_environment)) + + [{#Apply [reference_input reference_abstraction]} + {#Apply [sample_input sample_abstraction]}] + (and (= reference_input sample_input) + (= reference_abstraction sample_abstraction)) + + [{#Extension reference} {#Extension sample}] + (at (extension.equivalence =) = reference sample) + + _ + false)))) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> content) + [{<tag> content}]))] + + [case ..#Case] + ) + +(def .public unit + (template (unit) + [{..#Simple {/simple.#Unit}}])) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> value) + [{..#Simple {<tag> value}}]))] + + [bit /simple.#Bit] + [nat /simple.#Nat] + [int /simple.#Int] + [rev /simple.#Rev] + [frac /simple.#Frac] + [text /simple.#Text] + ) + +(type .public (Abstraction c) + [(Environment c) Arity c]) + +(type .public (Reification c) + [c (List c)]) + +(def .public no_op + (template (no_op value) + [(|> 1 + {variable.#Local} + {reference.#Variable} + {..#Reference} + {..#Function (list)} + {..#Apply value})])) + +(def .public (reified [abstraction inputs]) + (-> (Reification Analysis) Analysis) + (list#mix (function (_ input abstraction') + {#Apply input abstraction'}) + abstraction + inputs)) + +(def .public (reification analysis) + (-> Analysis (Reification Analysis)) + (loop (again [abstraction analysis + inputs (is (List Analysis) + (list))]) + (.case abstraction + {#Apply input next} + (again next {.#Item input inputs}) + + _ + [abstraction inputs]))) + +(with_template [<name> <tag>] + [(def .public <name> + (syntax (_ [content <code>.any]) + (in (list (` (.<| {..#Reference} + <tag> + (, content)))))))] + + [variable {reference.#Variable}] + [constant {reference.#Constant}] + + [local ((,! reference.local))] + [foreign ((,! reference.foreign))] + ) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> content) + [(.<| {..#Structure} + {<tag>} + content)]))] + + [variant /complex.#Variant] + [tuple /complex.#Tuple] + ) + +(def .public (format analysis) + (Format Analysis) + (.case analysis + {#Simple it} + (/simple.format it) + + {#Structure it} + (/complex.format format it) + + {#Reference reference} + (reference.format reference) + + {#Case analysis match} + (%.format "({" + (|> {.#Item match} + (list#each (function (_ [when then]) + (%.format (/pattern.format when) " " (format then)))) + (text.interposed " ")) + "} " + (format analysis) + ")") + + {#Function environment body} + (|> (format body) + (%.format " ") + (%.format (|> environment + (list#each format) + (text.interposed " ") + (text.enclosed ["[" "]"]))) + (text.enclosed ["(" ")"])) + + {#Apply _} + (|> analysis + ..reification + {.#Item} + (list#each format) + (text.interposed " ") + (text.enclosed ["(" ")"])) + + {#Extension name parameters} + (|> parameters + (list#each format) + (text.interposed " ") + (%.format (%.text name) " ") + (text.enclosed ["(" ")"])))) + +(with_template [<special> <general>] + [(type .public <special> + (<general> .Lux Code Analysis))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def .public (with_source_code source action) + (All (_ a) (-> Source (Operation a) (Operation a))) + (function (_ [bundle state]) + (let [old_source (the .#source state)] + (.case (action [bundle (has .#source source state)]) + {try.#Success [[bundle' state'] output]} + {try.#Success [[bundle' (has .#source old_source state')] + output]} + + failure + failure)))) + +(def .public (with_current_module name) + (All (_ a) (-> Text (Operation a) (Operation a))) + (extension.localized (the .#current_module) + (has .#current_module) + (function.constant {.#Some name}))) + +(def .public (with_location location action) + (All (_ a) (-> Location (Operation a) (Operation a))) + (if (text#= "" (product.left location)) + action + (function (_ [bundle state]) + (let [old_location (the .#location state)] + (.case (action [bundle (has .#location location state)]) + {try.#Success [[bundle' state'] output]} + {try.#Success [[bundle' (has .#location old_location state')] + output]} + + failure + failure))))) + +(def (located location error) + (-> Location Text Text) + (%.format (%.location location) text.new_line + error)) + +(def .public (failure error) + (-> Text Operation) + (function (_ [bundle state]) + {try.#Failure (located (the .#location state) error)})) + +(def .public (of_try it) + (All (_ a) (-> (Try a) (Operation a))) + (function (_ [bundle state]) + (.case it + {try.#Failure error} + {try.#Failure (located (the .#location state) error)} + + {try.#Success it} + {try.#Success [[bundle state] it]}))) + +(def .public (except exception parameters) + (All (_ e) (-> (Exception e) e Operation)) + (..failure (exception.error exception parameters))) + +(def .public (assertion exception parameters condition) + (All (_ e) (-> (Exception e) e Bit (Operation Any))) + (if condition + (at phase.monad in []) + (..except exception parameters))) + +(def .public (with_exception exception message action) + (All (_ e o) (-> (Exception e) e (Operation o) (Operation o))) + (function (_ bundle,state) + (.case (exception.with exception message + (action bundle,state)) + {try.#Failure error} + (let [[bundle state] bundle,state] + {try.#Failure (located (the .#location state) error)}) + + success + success))) + +(def .public (set_state state) + (-> .Lux (Operation Any)) + (function (_ [bundle _]) + {try.#Success [[bundle state] + []]})) + +(with_template [<name> <type> <field> <value>] + [(def .public (<name> value) + (-> <type> (Operation Any)) + (extension.update (has <field> <value>)))] + + [set_source_code Source .#source value] + [set_current_module Text .#current_module {.#Some value}] + [set_location Location .#location value] + ) + +(def .public (location file) + (-> Text Location) + [file 1 0]) + +(def .public (source file code) + (-> Text Text Source) + [(location file) 0 code]) + +(def dummy_source + Source + [location.dummy 0 ""]) + +(def type_context + Type_Context + [.#ex_counter 0 + .#var_counter 0 + .#var_bindings (list)]) + +(def .public (info version host configuration) + (-> Version Text Configuration Info) + [.#target host + .#version (version.format version) + .#mode {.#Build} + .#configuration configuration]) + +(def .public (state info) + (-> Info Lux) + [.#info info + .#source ..dummy_source + .#location location.dummy + .#current_module {.#None} + .#modules (list) + .#scopes (list) + .#type_context ..type_context + .#expected {.#None} + .#seed 0 + .#scope_type_vars (list) + .#extensions [] + .#eval (as (-> Type Code (Meta Any)) []) + .#host []]) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/complex.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/complex.lux new file mode 100644 index 000000000..0d00367b9 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/complex.lux @@ -0,0 +1,98 @@ +(.require + [library + [lux (.except Tuple Variant) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [data + ["[0]" bit (.use "[1]#[0]" equivalence)] + ["[0]" text (.only) + ["%" \\format (.only Format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [math + [number + ["n" nat]]]]]) + +(type .public (Variant a) + (Record + [#lefts Nat + #right? Bit + #value a])) + +(type .public (Tuple a) + (List a)) + +(type .public (Complex a) + (.Variant + {#Variant (Variant a)} + {#Tuple (Tuple a)})) + +(type .public Tag + Nat) + +(def .public (tag right? lefts) + (-> Bit Nat Tag) + (if right? + (++ lefts) + lefts)) + +(def .public (lefts right? tag) + (-> Bit Tag Nat) + (if right? + (-- tag) + tag)) + +(def .public (choice multiplicity pick) + (-> Nat Tag [Nat Bit]) + (let [right? (n.= (-- multiplicity) pick)] + [(..lefts right? pick) + right?])) + +(def .public (equivalence (open "/#[0]")) + (All (_ a) (-> (Equivalence a) (Equivalence (Complex a)))) + (implementation + (def (= reference sample) + (case [reference sample] + [{#Variant [reference_lefts reference_right? reference_value]} + {#Variant [sample_lefts sample_right? sample_value]}] + (and (n.= reference_lefts sample_lefts) + (bit#= reference_right? sample_right?) + (/#= reference_value sample_value)) + + [{#Tuple reference} {#Tuple sample}] + (at (list.equivalence /#=) = reference sample) + + _ + false)))) + +(def .public (hash super) + (All (_ a) (-> (Hash a) (Hash (Complex a)))) + (implementation + (def equivalence + (..equivalence (at super equivalence))) + + (def (hash value) + (case value + {#Variant [lefts right? value]} + (all n.* 2 + (at n.hash hash lefts) + (at bit.hash hash right?) + (at super hash value)) + + {#Tuple members} + (all n.* 3 + (at (list.hash super) hash members)) + )))) + +(def .public (format %it it) + (All (_ a) (-> (Format a) (Format (Complex a)))) + (case it + {#Variant [lefts right? it]} + (%.format "{" (%.nat lefts) " " (%.bit right?) " " (%it it) "}") + + {#Tuple it} + (|> it + (list#each %it) + (text.interposed " ") + (text.enclosed ["[" "]"])))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/coverage.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/coverage.lux new file mode 100644 index 000000000..dd5fde4f2 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/coverage.lux @@ -0,0 +1,423 @@ +(.require + [library + [lux (.except Variant Pattern) + [abstract + [equivalence (.except)] + ["[0]" monad (.only do)]] + [control + ["[0]" maybe (.use "[1]#[0]" monoid monad)] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)]] + [data + ["[0]" bit (.use "[1]#[0]" equivalence)] + ["[0]" text (.only) + ["%" \\format]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" set (.only Set) (.use "[1]#[0]" equivalence)]]] + [math + [number + ["n" nat (.use "[1]#[0]" interval)] + ["i" int] + ["r" rev] + ["f" frac]]] + [meta + [macro + ["^" pattern] + ["[0]" template]]]]] + ["[0]" // + ["[1][0]" simple] + ["[1][0]" complex] + ["[1][0]" pattern (.only Pattern)]]) + +... The coverage of a pattern-matching expression summarizes how well +... all the possible values of an input are being covered by the +... different patterns involved. +... Ideally, the pattern-matching has "exhaustive" coverage, which just +... means that every possible value can be matched by at least 1 +... pattern. +... Every other coverage is considered partial, and it would be valued +... as insuficient (since it could lead to runtime errors due to values +... not being handled by any pattern). +(template.let [(Variant' @) + [[(Maybe Nat) (Dictionary Nat @)]]] + (these (type .public Coverage + (Rec @ + (.Variant + {#Exhaustive} + {#Bit Bit} + {#Nat (Set Nat)} + {#Int (Set Int)} + {#Rev (Set Rev)} + {#Frac (Set Frac)} + {#Text (Set Text)} + {#Variant (Variant' @)} + {#Seq @ @} + {#Alt @ @}))) + + (type .public Variant + (Variant' Coverage)))) + +(def .public (minimum [max cases]) + (-> Variant Nat) + (maybe.else (|> cases + dictionary.keys + (list#mix n.max 0) + ++) + max)) + +(def .public (maximum [max cases]) + (-> Variant Nat) + (maybe.else n#top max)) + +(def (alternatives coverage) + (-> Coverage (List Coverage)) + (case coverage + {#Alt left right} + (list.partial left (alternatives right)) + + _ + (list coverage))) + +(def .public equivalence + (Equivalence Coverage) + (implementation + (def (= reference sample) + (case [reference sample] + [{#Exhaustive} {#Exhaustive}] + #1 + + [{#Bit sideR} {#Bit sideS}] + (bit#= sideR sideS) + + (^.with_template [<tag>] + [[{<tag> partialR} {<tag> partialS}] + (set#= partialR partialS)]) + ([#Nat] + [#Int] + [#Rev] + [#Frac] + [#Text]) + + [{#Variant allR casesR} {#Variant allS casesS}] + (and (at (maybe.equivalence n.equivalence) = allR allS) + (at (dictionary.equivalence =) = casesR casesS)) + + [{#Seq leftR rightR} {#Seq leftS rightS}] + (and (= leftR leftS) + (= rightR rightS)) + + [{#Alt _} {#Alt _}] + (let [flatR (alternatives reference) + flatS (alternatives sample)] + (and (n.= (list.size flatR) (list.size flatS)) + (list.every? (function (_ [coverageR coverageS]) + (= coverageR coverageS)) + (list.zipped_2 flatR flatS)))) + + _ + #0)))) + +(use "/#[0]" ..equivalence) + +(def .public (format value) + (%.Format Coverage) + (case value + {#Bit it} + (%.bit it) + + (^.with_template [<tag> <format>] + [{<tag> it} + (|> it + set.list + (list#each <format>) + (text.interposed " ") + (text.enclosed ["[" "]"]))]) + ([#Nat %.nat] + [#Int %.int] + [#Rev %.rev] + [#Frac %.frac] + [#Text %.text]) + + {#Variant ?max_cases cases} + (|> cases + dictionary.entries + (list#each (function (_ [tag it]) + (%.format (%.nat tag) " " (format it)))) + (text.interposed " ") + (%.format (maybe.else "?" (maybe#each %.nat ?max_cases)) " ") + (text.enclosed ["{" "}"])) + + {#Seq left right} + (%.format "(& " (format left) " " (format right) ")") + + {#Alt left right} + (%.format "(| " (format left) " " (format right) ")") + + {#Exhaustive} + "*")) + +(exception .public (invalid_tuple [size Nat]) + (exception.report + "Expected size" ">= 2" + "Actual size" (%.nat size))) + +(def .public (coverage pattern) + (-> Pattern (Try Coverage)) + (case pattern + (^.or {//pattern.#Simple {//simple.#Unit}} + {//pattern.#Bind _}) + {try.#Success {#Exhaustive}} + + ... Simple patterns (other than unit/[]) always have partial coverage because there + ... are too many possibilities as far as values go. + (^.with_template [<from> <to> <hash>] + [{//pattern.#Simple {<from> it}} + {try.#Success {<to> (set.of_list <hash> (list it))}}]) + ([//simple.#Nat #Nat n.hash] + [//simple.#Int #Int i.hash] + [//simple.#Rev #Rev r.hash] + [//simple.#Frac #Frac f.hash] + [//simple.#Text #Text text.hash]) + + ... Bits are the exception, since there is only "#1" and + ... "#0", which means it is possible for bit + ... pattern-matching to become exhaustive if complementary parts meet. + {//pattern.#Simple {//simple.#Bit value}} + {try.#Success {#Bit value}} + + ... Tuple patterns can be exhaustive if there is exhaustiveness for all of + ... their sub-patterns. + {//pattern.#Complex {//complex.#Tuple membersP+}} + (case (list.reversed membersP+) + (^.or (list) + (list _)) + (exception.except ..invalid_tuple [(list.size membersP+)]) + + {.#Item lastP prevsP+} + (do [! try.monad] + [lastC (coverage lastP)] + (monad.mix ! + (function (_ leftP rightC) + (do ! + [leftC (coverage leftP)] + (case rightC + {#Exhaustive} + (in leftC) + + _ + (in {#Seq leftC rightC})))) + lastC prevsP+))) + + ... Variant patterns can be shown to be exhaustive if all the possible + ... cases are handled exhaustively. + {//pattern.#Complex {//complex.#Variant [lefts right? value]}} + (do try.monad + [value_coverage (coverage value) + .let [idx (if right? + (++ lefts) + lefts)]] + (in {#Variant (if right? + {.#Some (++ idx)} + {.#None}) + (|> (dictionary.empty n.hash) + (dictionary.has idx value_coverage))})))) + +(def (xor left right) + (-> Bit Bit Bit) + (or (and left (not right)) + (and (not left) right))) + +... The coverage checker not only verifies that pattern-matching is +... exhaustive, but also that there are no redundant patterns. +... Redundant patterns will never be executed, since there will +... always be a pattern prior to them that would match the input. +... Because of that, the presence of redundant patterns is assumed to +... be a bug, likely due to programmer carelessness. +(exception .public (redundancy [so_far Coverage + addition Coverage]) + (exception.report + "Coverage so-far" (format so_far) + "Additional coverage" (format addition))) + +(exception .public (variant_mismatch [expected Nat + mismatched Nat]) + (exception.report + "Expected cases" (%.nat expected) + "Mismatched cases" (%.nat mismatched))) + +(def .public (exhaustive? coverage) + (-> Coverage Bit) + (case coverage + {#Exhaustive} + #1 + + _ + #0)) + +... After determining the coverage of each individual pattern, it is +... necessary to merge them all to figure out if the entire +... pattern-matching expression is exhaustive and whether it contains +... redundant patterns. +(def .public (composite addition so_far) + (-> Coverage Coverage (Try Coverage)) + (with_expansions [<redundancy> (exception.except ..redundancy [so_far addition]) + <alternatively> {try.#Success {#Alt addition so_far}} + <otherwise> (if (/#= so_far addition) + ... The addition cannot possibly improve the coverage. + <redundancy> + ... There are now 2 alternative paths. + <alternatively>)] + (case [addition so_far] + ... 2 bit coverages are exhaustive if they complement one another. + [{#Bit sideA} {#Bit sideSF}] + (if (xor sideA sideSF) + {try.#Success {#Exhaustive}} + <redundancy>) + + (^.with_template [<tag>] + [[{<tag> partialA} {<tag> partialSF}] + (if (set.empty? (set.intersection partialA partialSF)) + {try.#Success {<tag> (set.union partialA partialSF)}} + <redundancy>)]) + ([#Nat] + [#Int] + [#Rev] + [#Frac] + [#Text]) + + [{#Variant addition'} {#Variant so_far'}] + (let [[allA casesA] addition' + [allSF casesSF] so_far' + addition_cases (..maximum addition') + so_far_cases (..maximum so_far')] + (cond (template.let [(known_cases? it) + [(n.< n#top it)]] + (and (known_cases? so_far_cases) + (if (known_cases? addition_cases) + (not (n.= so_far_cases addition_cases)) + (n.> so_far_cases (..minimum addition'))))) + (exception.except ..variant_mismatch [so_far_cases addition_cases]) + + (at (dictionary.equivalence ..equivalence) = casesSF casesA) + <redundancy> + + ... else + (do [! try.monad] + [casesM (monad.mix ! + (function (_ [tagA coverageA] casesSF') + (case (dictionary.value tagA casesSF') + {.#Some coverageSF} + (do ! + [coverageM (composite coverageA coverageSF)] + (in (dictionary.has tagA coverageM casesSF'))) + + {.#None} + (in (dictionary.has tagA coverageA casesSF')))) + casesSF + (dictionary.entries casesA))] + (in (if (and (n.= (n.min addition_cases so_far_cases) + (dictionary.size casesM)) + (list.every? ..exhaustive? (dictionary.values casesM))) + {#Exhaustive} + {#Variant (maybe#composite allA allSF) casesM}))))) + + [{#Seq leftA rightA} {#Seq leftSF rightSF}] + (case [(/#= leftSF leftA) (/#= rightSF rightA)] + ... Same prefix + [#1 #0] + (do try.monad + [rightM (composite rightA rightSF)] + (in (if (..exhaustive? rightM) + ... If all that follows is exhaustive, then it can be safely dropped + ... (since only the "left" part would influence whether the + ... composite coverage is exhaustive or not). + leftSF + {#Seq leftSF rightM}))) + + ... Same suffix + [#0 #1] + (do try.monad + [leftM (composite leftA leftSF)] + (in {#Seq leftM rightA})) + + ... The 2 sequences cannot possibly be merged. + [#0 #0] + <alternatively> + + ... There is nothing the addition adds to the coverage. + [#1 #1] + <redundancy>) + + ... The addition cannot possibly improve the coverage. + [_ {#Exhaustive}] + <redundancy> + + ... The addition completes the coverage. + [{#Exhaustive} _] + {try.#Success {#Exhaustive}} + + ... When merging a new coverage against one based on Alt, it may be + ... that one of the many coverages in the Alt is complementary to + ... the new one, so effort must be made to fuse carefully, to match + ... the right coverages together. + ... If one of the Alt sub-coverages matches the new one, the cycle + ... must be repeated, in case the resulting coverage can now match + ... other ones in the original Alt. + ... This process must be repeated until no further productive + ... merges can be done. + [_ {#Alt leftS rightS}] + (do [! try.monad] + [.let [fuse_once (is (-> Coverage (List Coverage) + (Try [(Maybe Coverage) + (List Coverage)])) + (function (_ coverageA possibilitiesSF) + (loop (again [altsSF possibilitiesSF]) + (case altsSF + {.#End} + (in [{.#None} (list coverageA)]) + + {.#Item altSF altsSF'} + (do ! + [altMSF (composite coverageA altSF)] + (case altMSF + {#Alt _} + (do ! + [[success altsSF+] (again altsSF')] + (in [success {.#Item altSF altsSF+}])) + + _ + (in [{.#Some altMSF} altsSF'])))))))]] + (loop (again [addition addition + possibilitiesSF (alternatives so_far)]) + (do ! + [[addition' possibilitiesSF'] (fuse_once addition possibilitiesSF)] + (case addition' + {.#Some addition'} + (again addition' possibilitiesSF') + + {.#None} + (case (list.reversed possibilitiesSF') + {.#Item last prevs} + (in (list#mix (function (_ left right) {#Alt left right}) + last + prevs)) + + {.#End} + (undefined)))))) + + ... The left part will always match, so the addition is redundant. + [{#Seq left right} single] + (if (/#= left single) + <redundancy> + <otherwise>) + + ... The right part is not necessary, since it can always match the left. + [single {#Seq left right}] + (if (/#= left single) + {try.#Success single} + <otherwise>) + + _ + <otherwise>))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/evaluation.lux new file mode 100644 index 000000000..402cf563a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/evaluation.lux @@ -0,0 +1,77 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" maybe] + ["[0]" try] + ["[0]" io] + [concurrency + ["[0]" atom (.only Atom)]]] + [data + [collection + ["[0]" dictionary (.only Dictionary)]]] + [math + [number + ["n" nat]]] + ["[0]" meta (.only) + [type (.only sharing)]]]] + ["[0]" // (.only Operation) + [macro (.only Expander)] + ["[1][0]" type] + ["[1][0]" scope] + [// + [phase + ["[0]P" extension] + ["[0]P" synthesis] + ["[0]P" analysis] + [// + ["[0]" synthesis] + ["[0]" generation] + [/// + ["[0]" phase] + [meta + ["[0]" archive (.only Archive) + ["[0]" module]]]]]]]]) + +(type .public Eval + (-> Archive Type Code (Operation Any))) + +(def evals + (Atom (Dictionary module.ID Nat)) + (atom.atom (dictionary.empty n.hash))) + +(def .public (evaluator expander synthesis_state generation_state generate) + (All (_ anchor expression artifact) + (-> Expander + synthesis.State+ + (generation.State+ anchor expression artifact) + (generation.Phase anchor expression artifact) + Eval)) + (let [analyze (analysisP.phase expander)] + (function (eval archive type exprC) + (do phase.monad + [exprA (<| (//type.expecting type) + //scope.reset + (analyze archive exprC)) + module (extensionP.lifted + meta.current_module_name)] + (<| phase.lifted + (do try.monad + [exprS (|> exprA (synthesisP.phase archive) (phase.result synthesis_state))]) + (phase.result generation_state) + (do phase.monad + [@module (sharing [anchor expression artifact] + (is (generation.Phase anchor expression artifact) + generate) + (is (generation.Operation anchor expression artifact module.ID) + (generation.module_id module archive))) + .let [[evals _] (io.run! (atom.update! (dictionary.revised' @module 0 ++) ..evals)) + @eval (maybe.else 0 (dictionary.value @module evals))] + exprO (<| (generation.with_registry_shift (|> @module + ("lux i64 left-shift" 16) + ("lux i64 or" @eval) + ("lux i64 left-shift" 32))) + (generate archive exprS))] + (generation.evaluate! [@module @eval] [{.#None} exprO]))))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/inference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/inference.lux new file mode 100644 index 000000000..4bfa2da6a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/inference.lux @@ -0,0 +1,282 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" pipe] + ["[0]" maybe] + ["[0]" try] + ["[0]" exception (.only exception)]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor monoid)]]] + [math + [number + ["n" nat]]] + ["[0]" meta (.only) + [macro + ["^" pattern] + ["[0]" template]] + ["[0]" type (.only) + ["[0]" check]]]]] + ["/" // (.only Analysis Operation Phase) + ["[1][0]" type] + [// + [phase + ["[0]" extension]] + [/// + ["[0]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)]]]]]) + +(exception .public (cannot_infer [type Type + arguments (List Code)]) + (exception.report + "Type" (%.type type) + "Arguments" (exception.listing %.code arguments))) + +(exception .public (cannot_infer_argument [type Type + argument Code]) + (exception.report + "Type" (%.type type) + "Argument" (%.code argument))) + +(with_template [<name>] + [(exception .public (<name> [type Type]) + (exception.report + "Type" (%.type type)))] + + [not_a_variant] + [not_a_record] + [invalid_type_application] + ) + +(def .public (quantified @var @parameter :it:) + (-> check.Var Nat Type Type) + (case :it: + {.#Primitive name co_variant} + {.#Primitive name (list#each (quantified @var @parameter) co_variant)} + + (^.with_template [<tag>] + [{<tag> left right} + {<tag> (quantified @var @parameter left) + (quantified @var @parameter right)}]) + ([.#Sum] + [.#Product] + [.#Function] + [.#Apply]) + + {.#Var @} + (if (n.= @var @) + {.#Parameter @parameter} + :it:) + + (^.with_template [<tag>] + [{<tag> env body} + {<tag> (list#each (quantified @var @parameter) env) + (quantified @var (n.+ 2 @parameter) body)}]) + ([.#UnivQ] + [.#ExQ]) + + (^.or {.#Parameter _} + {.#Ex _} + {.#Named _}) + :it:)) + +... Type-inference works by applying some (potentially quantified) type +... to a sequence of values. +... Function types are used for this, although inference is not always +... done for function application (alternative uses may be records and +... tagged variants). +... But, so long as the type being used for the inference can be treated +... as a function type, this method of inference should work. +(def (general' vars archive analyse inferT args) + (-> (List check.Var) Archive Phase Type (List Code) (Operation [Type_Context (List check.Var) Type (List Analysis)])) + (case args + {.#End} + (do phase.monad + [just_before (/type.check check.context) + _ (/type.inference inferT)] + (in [just_before vars inferT (list)])) + + {.#Item argC args'} + (case inferT + {.#Named name unnamedT} + (general' vars archive analyse unnamedT args) + + {.#UnivQ _} + (do phase.monad + [[@var :var:] (/type.check check.var)] + (general' (list.partial @var vars) archive analyse (maybe.trusted (type.applied (list :var:) inferT)) args)) + + {.#ExQ _} + (do phase.monad + [:ex: /type.existential] + (general' vars archive analyse (maybe.trusted (type.applied (list :ex:) inferT)) args)) + + {.#Apply inputT transT} + (case (type.applied (list inputT) transT) + {.#Some outputT} + (general' vars archive analyse outputT args) + + {.#None} + (/.except ..invalid_type_application [inferT])) + + ... Arguments are inferred back-to-front because, by convention, + ... Lux functions take the most important arguments *last*, which + ... means that the most information for doing proper inference is + ... located in the last arguments to a function call. + ... By inferring back-to-front, a lot of type-annotations can be + ... avoided in Lux code, since the inference algorithm can piece + ... things together more easily. + {.#Function inputT outputT} + (do phase.monad + [[just_before vars outputT' args'A] (general' vars archive analyse outputT args') + argA (<| (/.with_exception ..cannot_infer_argument [inputT argC]) + (/type.expecting inputT) + (analyse archive argC))] + (in [just_before vars outputT' (list.partial argA args'A)])) + + {.#Var infer_id} + (do phase.monad + [?inferT' (/type.check (check.peek infer_id))] + (case ?inferT' + {.#Some inferT'} + (general' vars archive analyse inferT' args) + + _ + (/.except ..cannot_infer [inferT args]))) + + _ + (/.except ..cannot_infer [inferT args])) + )) + +(def .public (general archive analyse inferT args) + (-> Archive Phase Type (List Code) (Operation [Type (List Analysis)])) + (do [! phase.monad] + [[just_before vars :inference: terms] (general' (list) archive analyse inferT args)] + (in [:inference: terms]) + ... (case vars + ... (list) + ... (in [:inference: terms]) + + ... _ + ... (do ! + ... [:inference: (/type.check + ... (do [! check.monad] + ... [quantifications (monad.mix ! (function (_ @var level) + ... (do ! + ... [:var: (check.try (check.identity vars @var))] + ... (case :var: + ... {try.#Success _} + ... (in level) + + ... {try.#Failure _} + ... (do ! + ... [.let [:var: (|> level (n.* 2) ++ {.#Parameter})] + ... _ (check.bind :var: @var)] + ... (in (++ level)))))) + ... 0 + ... vars) + ... :inference:' (at ! each (type.univ_q quantifications) (check.clean vars :inference:)) + ... _ (check.with just_before)] + ... (in :inference:'))) + ... _ (/type.inference :inference:)] + ... (in [:inference: terms]))) + )) + +(def (with_recursion @self recursion) + (-> Nat Type Type Type) + (function (again it) + (case it + (^.or {.#Parameter index} + {.#Apply {.#Primitive "" {.#End}} + {.#Parameter index}}) + (if (n.= @self index) + recursion + it) + + (^.with_template [<tag>] + [{<tag> left right} + {<tag> (again left) (again right)}]) + ([.#Sum] [.#Product] [.#Function] [.#Apply]) + + (^.with_template [<tag>] + [{<tag> environment quantified} + {<tag> (list#each again environment) + (with_recursion (n.+ 2 @self) recursion quantified)}]) + ([.#UnivQ] [.#ExQ]) + + {.#Primitive name parameters} + {.#Primitive name (list#each again parameters)} + + _ + it))) + +(def parameters + (-> Nat (List Type)) + (|>> list.indices + (list#each (|>> (n.* 2) ++ {.#Parameter})) + list.reversed)) + +(with_template [<name> <types> <inputs> <exception> <when> <then>] + [(`` (def .public (<name> (,, (template.spliced <inputs>)) complex) + (-> (,, (template.spliced <types>)) Type (Operation Type)) + (loop (again [depth 0 + it complex]) + (case it + {.#Named name it} + (again depth it) + + (^.with_template [<tag>] + [{<tag> env it} + (phase#each (|>> {<tag> env}) + (again (++ depth) it))]) + ([.#UnivQ] + [.#ExQ]) + + {.#Apply parameter abstraction} + (case (type.applied (list parameter) abstraction) + {.#Some it} + (again depth it) + + {.#None} + (/.except ..invalid_type_application [it])) + + {<when> _} + <then> + + _ + (/.except <exception> [complex])))))] + + [record [Nat] [arity] ..not_a_record + .#Product + (let [[lefts right] (|> it + type.flat_tuple + (list.split_at (-- arity)))] + (phase#in (type.function + (list#each (..with_recursion (|> depth -- (n.* 2)) complex) + (list#composite lefts (list (type.tuple right)))) + (type.application (parameters depth) complex))))] + [variant [Nat Bit] [lefts right?] ..not_a_variant + .#Sum + (|> it + type.flat_variant + (list.after lefts) + (pipe.case + {.#Item [head tail]} + (let [case (if right? + (type.variant tail) + head)] + (-> (if (n.= 0 depth) + case + (..with_recursion (|> depth -- (n.* 2)) complex case)) + (type.application (parameters depth) complex))) + + {.#End} + (-> .Nothing complex)) + phase#in)] + ) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/macro.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/macro.lux new file mode 100644 index 000000000..9a5de364f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/macro.lux @@ -0,0 +1,56 @@ +(.require + [library + [lux (.except) + ["[0]" meta] + [abstract + [monad (.only do)]] + [control + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)]] + [data + ["[0]" text + ["%" \\format (.only format)]]]]] + [///// + ["[0]" phase]]) + +(exception .public (expansion_failed [macro Symbol + inputs (List Code) + error Text]) + (exception.report + "Macro" (%.symbol macro) + "Inputs" (exception.listing %.code inputs) + "Error" error)) + +(exception .public (must_have_single_expansion [macro Symbol + inputs (List Code) + outputs (List Code)]) + (exception.report + "Macro" (%.symbol macro) + "Inputs" (exception.listing %.code inputs) + "Outputs" (exception.listing %.code outputs))) + +(type .public Expander + (-> Macro (List Code) Lux (Try (Try [Lux (List Code)])))) + +(def .public (expansion expander name macro inputs) + (-> Expander Symbol Macro (List Code) (Meta (List Code))) + (function (_ state) + (do try.monad + [output (expander macro inputs state)] + (case output + {try.#Failure error} + ((meta.failure (exception.error ..expansion_failed [name inputs error])) state) + + _ + output)))) + +(def .public (single_expansion expander name macro inputs) + (-> Expander Symbol Macro (List Code) (Meta Code)) + (do meta.monad + [expansion (..expansion expander name macro inputs)] + (case expansion + (list single) + (in single) + + _ + (meta.failure (exception.error ..must_have_single_expansion [name inputs expansion]))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/module.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/module.lux new file mode 100644 index 000000000..33e818a9e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/module.lux @@ -0,0 +1,216 @@ +(.require + [library + [lux (.except Label with) + ["[0]" meta] + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" pipe] + ["[0]" try] + ["[0]" exception (.only exception)]] + [data + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" mix functor) + ["[0]" property]]]]]] + ["/" // (.only Operation) + ["//[1]" // + [phase + ["[1][0]" extension]] + [/// + ["[1]" phase]]]]) + +(type .public Label + Text) + +(exception .public (unknown_module [module Text]) + (exception.report + "Module" module)) + +(with_template [<name>] + [(exception .public (<name> [labels (List Label) + owner Type]) + (exception.report + "Labels" (text.interposed " " labels) + "Type" (%.type owner)))] + + [cannot_declare_labels_for_anonymous_type] + [cannot_declare_labels_for_foreign_type] + ) + +(exception .public (cannot_define_more_than_once [name Symbol + already_existing Global]) + (exception.report + "Definition" (%.symbol name) + "Original" (case already_existing + {.#Alias alias} + (format "alias " (%.symbol alias)) + + {.#Definition definition} + (format "definition " (%.symbol name)) + + {.#Type _} + (format "type " (%.symbol name)) + + {.#Tag _} + (format "tag " (%.symbol name)) + + {.#Slot _} + (format "slot " (%.symbol name))))) + +(exception .public (can_only_change_state_of_active_module [module Text + state Module_State]) + (exception.report + "Module" module + "Desired state" (case state + {.#Active} "Active" + {.#Compiled} "Compiled" + {.#Cached} "Cached"))) + +(def .public (empty hash) + (-> Nat Module) + [.#module_hash hash + .#module_aliases (list) + .#definitions (list) + .#imports (list) + .#module_state {.#Active}]) + +(def .public (import module) + (-> Text (Operation Any)) + (///extension.lifted + (do ///.monad + [self_name meta.current_module_name] + (function (_ state) + {try.#Success [(revised .#modules + (property.revised self_name (revised .#imports (function (_ current) + (if (list.any? (text#= module) + current) + current + {.#Item module current})))) + state) + []]})))) + +(def .public (alias alias module) + (-> Text Text (Operation Any)) + (///extension.lifted + (do ///.monad + [self_name meta.current_module_name] + (function (_ state) + {try.#Success [(revised .#modules + (property.revised self_name (revised .#module_aliases (is (-> (List [Text Text]) (List [Text Text])) + (|>> {.#Item [alias module]})))) + state) + []]})))) + +(def .public (exists? module) + (-> Text (Operation Bit)) + (///extension.lifted + (function (_ state) + (|> state + (the .#modules) + (property.value module) + (pipe.case {.#Some _} #1 {.#None} #0) + [state] + {try.#Success})))) + +(def .public (define name definition) + (-> Text Global (Operation Any)) + (///extension.lifted + (do ///.monad + [self_name meta.current_module_name + self meta.current_module] + (function (_ state) + (case (property.value name (the .#definitions self)) + {.#None} + {try.#Success [(revised .#modules + (property.has self_name + (revised .#definitions + (is (-> (List [Text Global]) (List [Text Global])) + (|>> {.#Item [name definition]})) + self)) + state) + []]} + + {.#Some already_existing} + ((///extension.up (/.except ..cannot_define_more_than_once [[self_name name] already_existing])) + state)))))) + +(def .public (create hash name) + (-> Nat Text (Operation Any)) + (///extension.lifted + (function (_ state) + {try.#Success [(revised .#modules + (property.has name (..empty hash)) + state) + []]}))) + +(def .public (with hash name action) + (All (_ a) (-> Nat Text (Operation a) (Operation [Module a]))) + (do ///.monad + [_ (..create hash name) + output (/.with_current_module name + action) + module (///extension.lifted (meta.module name))] + (in [module output]))) + +(with_template [<setter> <asker> <tag>] + [(def .public (<setter> module_name) + (-> Text (Operation Any)) + (///extension.lifted + (function (_ state) + (case (|> state (the .#modules) (property.value module_name)) + {.#Some module} + (let [active? (case (the .#module_state module) + {.#Active} #1 + _ #0)] + (if active? + {try.#Success [(revised .#modules + (property.has module_name (has .#module_state {<tag>} module)) + state) + []]} + ((///extension.up (/.except ..can_only_change_state_of_active_module [module_name {<tag>}])) + state))) + + {.#None} + ((///extension.up (/.except ..unknown_module module_name)) + state))))) + + (def .public (<asker> module_name) + (-> Text (Operation Bit)) + (///extension.lifted + (function (_ state) + (case (|> state (the .#modules) (property.value module_name)) + {.#Some module} + {try.#Success [state + (case (the .#module_state module) + {<tag>} #1 + _ #0)]} + + {.#None} + ((///extension.up (/.except ..unknown_module module_name)) + state)))))] + + [set_active active? .#Active] + [set_compiled compiled? .#Compiled] + [set_cached cached? .#Cached] + ) + +(def .public (declare_labels record? labels exported? type) + (-> Bit (List Label) Bit Type (Operation Any)) + (do [! ///.monad] + [self_name (///extension.lifted meta.current_module_name) + [type_module type_name] (case type + {.#Named type_name _} + (in type_name) + + _ + (/.except ..cannot_declare_labels_for_anonymous_type [labels type])) + _ (///.assertion ..cannot_declare_labels_for_foreign_type [labels type] + (text#= self_name type_module))] + (monad.each ! (function (_ [index short]) + (..define short + (if record? + {.#Slot [exported? type labels index]} + {.#Tag [exported? type labels index]}))) + (list.enumeration labels)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/pattern.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/pattern.lux new file mode 100644 index 000000000..daf608222 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/pattern.lux @@ -0,0 +1,85 @@ +(.require + [library + [lux (.except Pattern nat int rev) + [abstract + [equivalence (.only Equivalence)]] + [data + [text + ["%" \\format]]] + [math + [number + ["n" nat]]]]] + ["[0]" // + ["[1][0]" simple (.only Simple)] + ["[1][0]" complex (.only Complex)] + [//// + [reference + ["[1][0]" variable (.only Register)]]]]) + +(type .public Pattern + (Rec Pattern + (.Variant + {#Simple Simple} + {#Complex (Complex Pattern)} + {#Bind Register}))) + +(def .public equivalence + (Equivalence Pattern) + (implementation + (def (= reference sample) + (case [reference sample] + [{#Simple reference} {#Simple sample}] + (at //simple.equivalence = reference sample) + + [{#Complex reference} {#Complex sample}] + (at (//complex.equivalence =) = reference sample) + + [{#Bind reference} {#Bind sample}] + (n.= reference sample) + + _ + false)))) + +(def .public (format it) + (%.Format Pattern) + (case it + {#Simple it} + (//simple.format it) + + {#Complex it} + (//complex.format format it) + + {#Bind it} + (//variable.format {//variable.#Local it}))) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> content) + [(.<| {..#Complex} + <tag> + content)]))] + + [variant {//complex.#Variant}] + [tuple {//complex.#Tuple}] + ) + +(def .public unit + (template (unit) + [{..#Simple {//simple.#Unit}}])) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> content) + [{..#Simple {<tag> content}}]))] + + [bit //simple.#Bit] + [nat //simple.#Nat] + [int //simple.#Int] + [rev //simple.#Rev] + [frac //simple.#Frac] + [text //simple.#Text] + ) + +(def .public bind + (template (bind register) + [{..#Bind register}])) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/scope.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/scope.lux new file mode 100644 index 000000000..538874881 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/scope.lux @@ -0,0 +1,193 @@ +(.require + [library + [lux (.except local with) + [abstract + [monad (.only do)]] + [control + ["[0]" maybe (.use "[1]#[0]" monad)] + ["[0]" try] + ["[0]" exception (.only exception)]] + [data + ["[0]" text (.use "[1]#[0]" equivalence)] + ["[0]" product] + [collection + ["[0]" list (.use "[1]#[0]" functor mix monoid) + ["[0]" property]]]]]] + ["/" // (.only Environment Operation Phase) + [// + [phase + ["[0]" extension]] + [/// + ["[0]" phase] + [reference + ["[0]" variable (.only Register Variable)]]]]]) + +(type Local + (Bindings Text [Type Register])) + +(type Foreign + (Bindings Text [Type Variable])) + +(def (local? name scope) + (-> Text Scope Bit) + (|> scope + (the [.#locals .#mappings]) + (property.contains? name))) + +(def (local name scope) + (-> Text Scope (Maybe [Type Variable])) + (|> scope + (the [.#locals .#mappings]) + (property.value name) + (maybe#each (function (_ [type value]) + [type {variable.#Local value}])))) + +(def (captured? name scope) + (-> Text Scope Bit) + (|> scope + (the [.#captured .#mappings]) + (property.contains? name))) + +(def (captured name scope) + (-> Text Scope (Maybe [Type Variable])) + (loop (again [idx 0 + mappings (the [.#captured .#mappings] scope)]) + (case mappings + {.#Item [_name [_source_type _source_ref]] mappings'} + (if (text#= name _name) + {.#Some [_source_type {variable.#Foreign idx}]} + (again (++ idx) mappings')) + + {.#End} + {.#None}))) + +(def (reference? name scope) + (-> Text Scope Bit) + (or (local? name scope) + (captured? name scope))) + +(def (reference name scope) + (-> Text Scope (Maybe [Type Variable])) + (case (..local name scope) + {.#Some type} + {.#Some type} + + _ + (..captured name scope))) + +(def .public (variable name) + (-> Text (Operation (Maybe [Type Variable]))) + (extension.lifted + (function (_ state) + (let [[inner outer] (|> state + (the .#scopes) + (list.split_when (|>> (reference? name))))] + (case outer + {.#End} + {.#Right [state {.#None}]} + + {.#Item top_outer _} + (let [[ref_type init_ref] (maybe.else (undefined) + (..reference name top_outer)) + [ref inner'] (list#mix (is (-> Scope [Variable (List Scope)] [Variable (List Scope)]) + (function (_ scope ref+inner) + [{variable.#Foreign (the [.#captured .#counter] scope)} + {.#Item (revised .#captured + (is (-> Foreign Foreign) + (|>> (revised .#counter ++) + (revised .#mappings (property.has name [ref_type (product.left ref+inner)])))) + scope) + (product.right ref+inner)}])) + [init_ref {.#End}] + (list.reversed inner)) + scopes (list#composite inner' outer)] + {.#Right [(has .#scopes scopes state) + {.#Some [ref_type ref]}]}) + ))))) + +(exception .public no_scope) +(exception .public drained) + +(def .public (with_local [name type] action) + (All (_ a) (-> [Text Type] (Operation a) (Operation a))) + (function (_ [bundle state]) + (case (the .#scopes state) + {.#Item head tail} + (let [old_mappings (the [.#locals .#mappings] head) + new_var_id (the [.#locals .#counter] head) + new_head (revised .#locals + (is (-> Local Local) + (|>> (revised .#counter ++) + (revised .#mappings (property.has name [type new_var_id])))) + head)] + (case (phase.result' [bundle (has .#scopes {.#Item new_head tail} state)] + action) + {try.#Success [[bundle' state'] output]} + (case (the .#scopes state') + {.#Item head' tail'} + (let [scopes' {.#Item (has .#locals (the .#locals head) head') + tail'}] + {try.#Success [[bundle' (has .#scopes scopes' state')] + output]}) + + _ + (exception.except ..drained [])) + + {try.#Failure error} + {try.#Failure error})) + + _ + (exception.except ..no_scope [])))) + +(def empty + Scope + (let [bindings (is Bindings + [.#counter 0 + .#mappings (list)])] + [.#name (list) + .#inner 0 + .#locals bindings + .#captured bindings])) + +(def .public (reset action) + (All (_ a) (-> (Operation a) (Operation a))) + (function (_ [bundle state]) + (case (action [bundle (has .#scopes (list ..empty) state)]) + {try.#Success [[bundle' state'] output]} + {try.#Success [[bundle' (has .#scopes (the .#scopes state) state')] + output]} + + failure + failure))) + +(def .public (with action) + (All (_ a) (-> (Operation a) (Operation [Scope a]))) + (function (_ [bundle state]) + (case (action [bundle (revised .#scopes (|>> {.#Item ..empty}) state)]) + {try.#Success [[bundle' state'] output]} + (case (the .#scopes state') + {.#Item head tail} + {try.#Success [[bundle' (has .#scopes tail state')] + [head output]]} + + {.#End} + (exception.except ..drained [])) + + {try.#Failure error} + {try.#Failure error}))) + +(def .public next + (Operation Register) + (extension.lifted + (function (_ state) + (case (the .#scopes state) + {.#Item top _} + {try.#Success [state (the [.#locals .#counter] top)]} + + {.#End} + (exception.except ..no_scope []))))) + +(def .public environment + (-> Scope (Environment Variable)) + (|>> (the [.#captured .#mappings]) + (list#each (function (_ [_ [_ ref]]) ref)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/simple.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/simple.lux new file mode 100644 index 000000000..4b092ad00 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/simple.lux @@ -0,0 +1,65 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)]] + [data + ["[0]" bit (.use "[1]#[0]" equivalence)] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only Format)]]] + [math + [number + ["n" nat] + ["i" int] + ["r" rev] + ["f" frac]]] + [meta + [macro + ["^" pattern]]]]]) + +(type .public Simple + (Variant + {#Unit} + {#Bit Bit} + {#Nat Nat} + {#Int Int} + {#Rev Rev} + {#Frac Frac} + {#Text Text})) + +(def .public equivalence + (Equivalence Simple) + (implementation + (def (= reference sample) + (case [reference sample] + [{#Unit} {#Unit}] + true + + (^.with_template [<tag> <=>] + [[{<tag> reference} {<tag> sample}] + (<=> reference sample)]) + ([#Bit bit#=] + [#Nat n.=] + [#Int i.=] + [#Rev r.=] + [#Frac f.=] + [#Text text#=]) + + _ + false)))) + +(def .public (format it) + (Format Simple) + (case it + {#Unit} + "[]" + + (^.with_template [<tag> <format>] + [{<tag> value} + (<format> value)]) + ([#Bit %.bit] + [#Nat %.nat] + [#Int %.int] + [#Rev %.rev] + [#Frac %.frac] + [#Text %.text]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/analysis/type.lux b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/type.lux new file mode 100644 index 000000000..b534b616a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/analysis/type.lux @@ -0,0 +1,133 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" function] + ["[0]" try]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list]]] + [math + [number + ["n" nat]]] + ["[0]" meta (.only) + [macro + ["^" pattern]] + [type + ["[0]" check (.only Check)]]]]] + ["/" // (.only Operation) + [// + [phase + ["[0]" extension]] + [/// + ["[0]" phase]]]]) + +(def .public (check action) + (All (_ a) (-> (Check a) (Operation a))) + (function (_ (^.let stateE [bundle state])) + (case (action (the .#type_context state)) + {try.#Success [context' output]} + {try.#Success [[bundle (has .#type_context context' state)] + output]} + + {try.#Failure error} + ((/.failure error) stateE)))) + +(def prefix + (format (%.symbol (symbol ..type)) "#")) + +(def .public (existential? type) + (-> Type Bit) + (case type + {.#Primitive actual {.#End}} + (text.starts_with? ..prefix actual) + + _ + false)) + +(def (existential' module id) + (-> Text Nat Type) + {.#Primitive (format ..prefix module "#" (%.nat id)) (list)}) + +(def .public existential + (Operation Type) + (do phase.monad + [module (extension.lifted meta.current_module_name) + id (extension.lifted meta.seed)] + (in (..existential' module id)))) + +(def .public (expecting expected) + (All (_ a) (-> Type (Operation a) (Operation a))) + (extension.localized (the .#expected) (has .#expected) + (function.constant {.#Some expected}))) + +(def .public fresh + (All (_ a) (-> (Operation a) (Operation a))) + (extension.localized (the .#type_context) (has .#type_context) + (function.constant check.fresh_context))) + +(def .public (inference actualT) + (-> Type (Operation Any)) + (do phase.monad + [module (extension.lifted meta.current_module_name) + expectedT (extension.lifted meta.expected_type)] + (..check (check.check expectedT actualT) + ... (do [! check.monad] + ... [pre check.context + ... it (check.check expectedT actualT) + ... post check.context + ... .let [pre#var_counter (the .#var_counter pre)]] + ... (if (n.< (the .#var_counter post) + ... pre#var_counter) + ... (do ! + ... [.let [new! (is (-> [Nat (Maybe Type)] (Maybe Nat)) + ... (function (_ [id _]) + ... (if (n.< id pre#var_counter) + ... {.#Some id} + ... {.#None}))) + ... new_vars (|> post + ... (the .#var_bindings) + ... (list.all new!))] + ... _ (monad.each ! (function (_ @new) + ... (do ! + ... [:new: (check.try (check.identity new_vars @new))] + ... (case :new: + ... {try.#Success :new:} + ... (in :new:) + + ... {try.#Failure error} + ... (do ! + ... [[id _] check.existential + ... .let [:new: (..existential' module id)] + ... _ (check.bind :new: @new)] + ... (in :new:))))) + ... new_vars) + ... expectedT' (check.clean new_vars expectedT) + ... _ (check.with pre)] + ... (check.check expectedT' actualT)) + ... (in it))) + ))) + +(def .public (with_var it) + (All (_ a) + (-> (-> [check.Var Type] (Operation a)) + (Operation a))) + (do phase.monad + [@it,:it: (..check check.var) + it (it @it,:it:) + .let [[@it :it:] @it,:it:] + _ (..check (check.forget! @it))] + (in it))) + +(def .public (inferring action) + (All (_ a) (-> (Operation a) (Operation [Type a]))) + (<| ..with_var + (function (_ [@it :it:])) + (do phase.monad + [it (..expecting :it: action) + :it: (..check (check.identity (list) @it))] + (in [:it: it])))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/declaration.lux b/stdlib/source/library/lux/meta/compiler/language/lux/declaration.lux new file mode 100644 index 000000000..1f2b4505a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/declaration.lux @@ -0,0 +1,102 @@ +(.require + [library + [lux (.except Module) + [abstract + [monad (.only do)]] + [control + ["[0]" try]] + [data + [collection + ["[0]" list (.use "[1]#[0]" monoid)]]]]] + [// + ["[0]" analysis] + ["[0]" synthesis] + ["[0]" generation] + [phase + ["[0]" extension]] + [/// + ["[0]" phase] + [meta + [archive + [module + [descriptor (.only Module)]]]]]]) + +(type .public (Component state phase) + (Record + [#state state + #phase phase])) + +(type .public (State anchor expression declaration) + (Record + [#analysis (Component analysis.State+ + analysis.Phase) + #synthesis (Component synthesis.State+ + synthesis.Phase) + #generation (Component (generation.State+ anchor expression declaration) + (generation.Phase anchor expression declaration))])) + +(type .public Import + (Record + [#module Module + #alias Text])) + +(type .public Requirements + (Record + [#imports (List Import) + #referrals (List Code)])) + +(def .public no_requirements + Requirements + [#imports (list) + #referrals (list)]) + +(def .public (merge_requirements left right) + (-> Requirements Requirements Requirements) + [#imports (list#composite (the #imports left) (the #imports right)) + #referrals (list#composite (the #referrals left) (the #referrals right))]) + +(with_template [<special> <general>] + [(type .public (<special> anchor expression declaration) + (<general> (..State anchor expression declaration) Code Requirements))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(with_template [<name> <component> <phase>] + [(def .public <name> + (All (_ anchor expression declaration) + (Operation anchor expression declaration <phase>)) + (function (_ [bundle state]) + {try.#Success [[bundle state] (the [<component> ..#phase] state)]}))] + + [analysis ..#analysis analysis.Phase] + [synthesis ..#synthesis synthesis.Phase] + [generation ..#generation (generation.Phase anchor expression declaration)] + ) + +(with_template [<name> <component> <operation>] + [(def .public <name> + (All (_ anchor expression declaration output) + (-> (<operation> output) + (Operation anchor expression declaration output))) + (|>> (phase.sub [(the [<component> ..#state]) + (has [<component> ..#state])]) + extension.lifted))] + + [lifted_analysis ..#analysis analysis.Operation] + [lifted_synthesis ..#synthesis synthesis.Operation] + [lifted_generation ..#generation (generation.Operation anchor expression declaration)] + ) + +(def .public (set_current_module module) + (All (_ anchor expression declaration) + (-> Module (Operation anchor expression declaration Any))) + (do phase.monad + [_ (..lifted_analysis + (analysis.set_current_module module))] + (..lifted_generation + (generation.enter_module module)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/generation.lux b/stdlib/source/library/lux/meta/compiler/language/lux/generation.lux new file mode 100644 index 000000000..c217a6d6c --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/generation.lux @@ -0,0 +1,398 @@ +(.require + [library + [lux (.except symbol) + [abstract + [monad (.only do)]] + [control + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)] + ["[0]" function]] + [data + [binary (.only Binary)] + ["[0]" product] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]] + [collection + ["[0]" sequence (.only Sequence)] + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set (.only Set)]]] + [math + [number + ["n" nat]]] + [meta + ["[0]" symbol] + [macro + ["^" pattern] + ["[0]" template]]]]] + [// + [synthesis (.only Synthesis)] + [phase + ["[0]" extension]] + [/// + ["[0]" phase] + [meta + ["[0]" archive (.only Archive) + ["[0]" registry (.only Registry)] + ["[0]" unit] + ["[0]" artifact (.only) + ["[0]" category]] + ["[0]" module (.only) + ["[0]" descriptor]]]]]]) + +(type .public (Buffer declaration) + (Sequence [artifact.ID (Maybe Text) declaration])) + +(exception .public (cannot_interpret [error Text]) + (exception.report + "Error" error)) + +(with_template [<name>] + [(exception .public (<name> [it artifact.ID]) + (exception.report + "Artifact ID" (%.nat it)))] + + [cannot_overwrite_output] + [no_buffer_for_saving_code] + ) + +(type .public (Host expression declaration) + (Interface + (is (-> unit.ID [(Maybe unit.ID) expression] (Try Any)) + evaluate) + (is (-> declaration (Try Any)) + execute) + (is (-> unit.ID (Maybe Text) [(Maybe unit.ID) expression] (Try [Text Any declaration])) + define) + + (is (-> unit.ID Binary declaration) + ingest) + (is (-> unit.ID (Maybe Text) declaration (Try Any)) + re_learn) + (is (-> unit.ID (Maybe Text) declaration (Try Any)) + re_load))) + +(type .public (State anchor expression declaration) + (Record + [#module descriptor.Module + #anchor (Maybe anchor) + #host (Host expression declaration) + #buffer (Maybe (Buffer declaration)) + #registry Registry + #registry_shift Nat + #counter Nat + #context (Maybe artifact.ID) + #log (Sequence Text) + #interim_artifacts (List artifact.ID)])) + +(with_template [<special> <general>] + [(type .public (<special> anchor expression declaration) + (<general> (State anchor expression declaration) Synthesis expression))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + [Extender extension.Extender] + ) + +(def .public (state host module) + (All (_ anchor expression declaration) + (-> (Host expression declaration) + descriptor.Module + (..State anchor expression declaration))) + [#module module + #anchor {.#None} + #host host + #buffer {.#None} + #registry registry.empty + #registry_shift 0 + #counter 0 + #context {.#None} + #log sequence.empty + #interim_artifacts (list)]) + +(def .public empty_buffer + Buffer + sequence.empty) + +(with_template [<tag> + <with_declaration> <with_type> <with_value> + <set> <get> <get_type> <exception>] + [(exception .public <exception>) + + (def .public <with_declaration> + (All (_ anchor expression declaration output) <with_type>) + (function (_ body) + (function (_ [bundle state]) + (case (body [bundle (has <tag> {.#Some <with_value>} state)]) + {try.#Success [[bundle' state'] output]} + {try.#Success [[bundle' (has <tag> (the <tag> state) state')] + output]} + + {try.#Failure error} + {try.#Failure error})))) + + (def .public <get> + (All (_ anchor expression declaration) + (Operation anchor expression declaration <get_type>)) + (function (_ (^.let stateE [bundle state])) + (case (the <tag> state) + {.#Some output} + {try.#Success [stateE output]} + + {.#None} + (exception.except <exception> [])))) + + (def .public (<set> value) + (All (_ anchor expression declaration) + (-> <get_type> (Operation anchor expression declaration Any))) + (function (_ [bundle state]) + {try.#Success [[bundle (has <tag> {.#Some value} state)] + []]}))] + + [#anchor + (with_anchor anchor) + (-> anchor (Operation anchor expression declaration output) + (Operation anchor expression declaration output)) + anchor + set_anchor anchor anchor no_anchor] + + [#buffer + with_buffer + (-> (Operation anchor expression declaration output) + (Operation anchor expression declaration output)) + ..empty_buffer + set_buffer buffer (Buffer declaration) no_active_buffer] + ) + +(def .public get_registry + (All (_ anchor expression declaration) + (Operation anchor expression declaration Registry)) + (function (_ (^.let stateE [bundle state])) + {try.#Success [stateE (the #registry state)]})) + +(def .public (set_registry value) + (All (_ anchor expression declaration) + (-> Registry (Operation anchor expression declaration Any))) + (function (_ [bundle state]) + {try.#Success [[bundle (has #registry value state)] + []]})) + +(def .public next + (All (_ anchor expression declaration) + (Operation anchor expression declaration Nat)) + (do phase.monad + [count (extension.read (the #counter)) + _ (extension.update (revised #counter ++))] + (in count))) + +(def .public (symbol prefix) + (All (_ anchor expression declaration) + (-> Text (Operation anchor expression declaration Text))) + (at phase.monad each (|>> %.nat (format prefix)) ..next)) + +(def .public (enter_module module) + (All (_ anchor expression declaration) + (-> descriptor.Module (Operation anchor expression declaration Any))) + (extension.update (has #module module))) + +(def .public module + (All (_ anchor expression declaration) + (Operation anchor expression declaration descriptor.Module)) + (extension.read (the #module))) + +(def .public (evaluate! label code) + (All (_ anchor expression declaration) + (-> unit.ID [(Maybe unit.ID) expression] (Operation anchor expression declaration Any))) + (function (_ (^.let state+ [bundle state])) + (case (at (the #host state) evaluate label code) + {try.#Success output} + {try.#Success [state+ output]} + + {try.#Failure error} + (exception.except ..cannot_interpret [error])))) + +(def .public (execute! code) + (All (_ anchor expression declaration) + (-> declaration (Operation anchor expression declaration Any))) + (function (_ (^.let state+ [bundle state])) + (case (at (the #host state) execute code) + {try.#Success output} + {try.#Success [state+ output]} + + {try.#Failure error} + (exception.except ..cannot_interpret error)))) + +(def .public (define! context custom code) + (All (_ anchor expression declaration) + (-> unit.ID (Maybe Text) [(Maybe unit.ID) expression] (Operation anchor expression declaration [Text Any declaration]))) + (function (_ (^.let stateE [bundle state])) + (case (at (the #host state) define context custom code) + {try.#Success output} + {try.#Success [stateE output]} + + {try.#Failure error} + (exception.except ..cannot_interpret error)))) + +(def .public (save! artifact_id custom code) + (All (_ anchor expression declaration) + (-> artifact.ID (Maybe Text) declaration (Operation anchor expression declaration Any))) + (do [! phase.monad] + [?buffer (extension.read (the #buffer))] + (case ?buffer + {.#Some buffer} + ... TODO: Optimize by no longer checking for overwrites... + (if (sequence.any? (|>> product.left (n.= artifact_id)) buffer) + (phase.except ..cannot_overwrite_output [artifact_id]) + (extension.update (has #buffer {.#Some (sequence.suffix [artifact_id custom code] buffer)}))) + + {.#None} + (phase.except ..no_buffer_for_saving_code [artifact_id])))) + +(with_template [<type> <mandatory?> <inputs> <input_types> <name> <artifact>] + [(`` (def .public (<name> it (,, (template.spliced <inputs>)) dependencies) + (All (_ anchor expression declaration) + (-> <type> (,, (template.spliced <input_types>)) (Set unit.ID) (Operation anchor expression declaration artifact.ID))) + (function (_ (^.let stateE [bundle state])) + (let [[id registry'] (<artifact> it <mandatory?> dependencies (the #registry state))] + {try.#Success [[bundle (has #registry registry' state)] + id]}))))] + + [category.Definition mandatory? [mandatory?] [Bit] learn registry.definition] + [Text #1 [] [] learn_custom registry.custom] + [Text #0 [] [] learn_analyser registry.analyser] + [Text #0 [] [] learn_synthesizer registry.synthesizer] + [Text #0 [] [] learn_generator registry.generator] + [Text #0 [] [] learn_declaration registry.declaration] + ) + +(exception .public (unknown_definition [name Symbol + known_definitions (List category.Definition)]) + (exception.report + "Definition" (symbol.short name) + "Module" (symbol.module name) + "Known Definitions" (exception.listing product.left known_definitions))) + +(def .public (remember archive name) + (All (_ anchor expression declaration) + (-> Archive Symbol (Operation anchor expression declaration unit.ID))) + (function (_ (^.let stateE [bundle state])) + (let [[_module _name] name] + (do try.monad + [@module (archive.id _module archive) + registry (if (text#= (the #module state) _module) + {try.#Success (the #registry state)} + (do try.monad + [[_module output registry] (archive.find _module archive)] + {try.#Success registry}))] + (case (registry.id _name registry) + {.#None} + (exception.except ..unknown_definition [name (registry.definitions registry)]) + + {.#Some id} + {try.#Success [stateE [@module id]]}))))) + +(def .public (definition archive name) + (All (_ anchor expression declaration) + (-> Archive Symbol (Operation anchor expression declaration [unit.ID (Maybe category.Definition)]))) + (function (_ (^.let stateE [bundle state])) + (let [[_module _name] name] + (do try.monad + [@module (archive.id _module archive) + registry (if (text#= (the #module state) _module) + {try.#Success (the #registry state)} + (do try.monad + [[_module output registry] (archive.find _module archive)] + {try.#Success registry}))] + (case (registry.find_definition _name registry) + {.#None} + (exception.except ..unknown_definition [name (registry.definitions registry)]) + + {.#Some [@artifact def]} + {try.#Success [stateE [[@module @artifact] def]]}))))) + +(exception .public no_context) + +(def .public (module_id module archive) + (All (_ anchor expression declaration) + (-> descriptor.Module Archive (Operation anchor expression declaration module.ID))) + (function (_ (^.let stateE [bundle state])) + (do try.monad + [@module (archive.id module archive)] + (in [stateE @module])))) + +(def .public (context archive) + (All (_ anchor expression declaration) + (-> Archive (Operation anchor expression declaration unit.ID))) + (function (_ (^.let stateE [bundle state])) + (case (the #context state) + {.#None} + (exception.except ..no_context []) + + {.#Some id} + (do try.monad + [@module (archive.id (the #module state) archive)] + (in [stateE [@module id]]))))) + +(def .public (with_context @artifact body) + (All (_ anchor expression declaration a) + (-> artifact.ID + (Operation anchor expression declaration a) + (Operation anchor expression declaration a))) + (function (_ [bundle state]) + (do try.monad + [[[bundle' state'] output] (body [bundle (has #context {.#Some @artifact} state)])] + (in [[bundle' (has #context (the #context state) state')] + output])))) + +(def .public (with_registry_shift shift body) + (All (_ anchor expression declaration a) + (-> Nat + (Operation anchor expression declaration a) + (Operation anchor expression declaration a))) + (function (_ [bundle state]) + (do try.monad + [[[bundle' state'] output] (body [bundle (has #registry_shift shift state)])] + (in [[bundle' (has #registry_shift (the #registry_shift state) state')] + output])))) + +(def .public (with_new_context archive dependencies body) + (All (_ anchor expression declaration a) + (-> Archive (Set unit.ID) (Operation anchor expression declaration a) + (Operation anchor expression declaration [unit.ID a]))) + (function (_ (^.let stateE [bundle state])) + (let [[@artifact registry'] (registry.resource false dependencies (the #registry state)) + @artifact (n.+ @artifact (the #registry_shift state))] + (do try.monad + [[[bundle' state'] output] (body [bundle (|> state + (has #registry registry') + (has #context {.#Some @artifact}) + (revised #interim_artifacts (|>> {.#Item @artifact})))]) + @module (archive.id (the #module state) archive)] + (in [[bundle' (has #context (the #context state) state')] + [[@module @artifact] + output]]))))) + +(def .public (log! message) + (All (_ anchor expression declaration a) + (-> Text (Operation anchor expression declaration Any))) + (function (_ [bundle state]) + {try.#Success [[bundle + (revised #log (sequence.suffix message) state)] + []]})) + +(def .public (with_interim_artifacts archive body) + (All (_ anchor expression declaration a) + (-> Archive (Operation anchor expression declaration a) + (Operation anchor expression declaration [(List unit.ID) a]))) + (do phase.monad + [module (extension.read (the #module))] + (function (_ state+) + (do try.monad + [@module (archive.id module archive) + [[bundle' state'] output] (body state+)] + (in [[bundle' + (has #interim_artifacts (list) state')] + [(list#each (|>> [@module]) (the #interim_artifacts state')) + output]]))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis.lux new file mode 100644 index 000000000..30e4a1360 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis.lux @@ -0,0 +1,136 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" exception (.only exception)]] + [data + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list]]] + [math + [number + ["n" nat]]] + ["[0]" meta (.only) + ["[0]" location] + ["[0]" code] + [macro + ["^" pattern]]]]] + ["[0]" / + ["[1][0]" simple] + ["[1][0]" complex] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" function] + ["/[1]" // + ["[1][0]" extension] + ["/[1]" // + ["/" analysis (.only Analysis Operation Phase) + ["[1][0]" macro (.only Expander)] + ["[1][0]" type]] + [/// + ["//" phase] + ["[0]" reference] + [meta + [archive (.only Archive)]]]]]]) + +(exception .public (invalid [syntax Code]) + (exception.report + "Syntax" (%.code syntax))) + +(def variant_analysis + (template (_ analysis archive tag values) + ... (-> Phase Archive Symbol (List Code) (Operation Analysis)) + [(case values + (list value) + (/complex.variant analysis tag archive value) + + _ + (/complex.variant analysis tag archive (code.tuple values)))])) + +(def sum_analysis + (template (_ analysis archive lefts right? values) + ... (-> Phase Archive Nat Bit (List Code) (Operation Analysis)) + [(case values + (list value) + (/complex.sum analysis lefts right? archive value) + + _ + (/complex.sum analysis lefts right? archive (code.tuple values)))])) + +(def case_analysis + (template (_ analysis archive input branches code) + ... (-> Phase Archive Code (List Code) Code (Operation Analysis)) + [(case (list.pairs branches) + {.#Some branches} + (/case.case analysis branches archive input) + + {.#None} + (//.except ..invalid [code]))])) + +(def apply_analysis + (template (_ expander analysis archive functionC argsC+) + ... (-> Expander Phase Archive Code (List Code) (Operation Analysis)) + [(do [! //.monad] + [[functionT functionA] (/type.inferring + (analysis archive functionC))] + (case functionA + (/.constant def_name) + (do ! + [?macro (//extension.lifted (meta.macro def_name))] + (case ?macro + {.#Some macro} + (do ! + [expansion (//extension.lifted (/macro.single_expansion expander def_name macro argsC+))] + (analysis archive expansion)) + + _ + (/function.apply analysis argsC+ functionT functionA archive functionC))) + + _ + (/function.apply analysis argsC+ functionT functionA archive functionC)))])) + +(def .public (phase expander) + (-> Expander Phase) + (function (analysis archive code) + (<| (let [[location code'] code]) + ... The location must be set in the state for the sake + ... of having useful error messages. + (/.with_location location) + (case code + (^.with_template [<tag> <analyser>] + [[_ {<tag> value}] + (<analyser> value)]) + ([.#Symbol /reference.reference] + [.#Text /simple.text] + [.#Nat /simple.nat] + [.#Bit /simple.bit] + [.#Frac /simple.frac] + [.#Int /simple.int] + [.#Rev /simple.rev]) + + (^.` [(,* elems)]) + (/complex.record analysis archive elems) + + (^.` {(, [_ {.#Symbol tag}]) (,* values)}) + (..variant_analysis analysis archive tag values) + + (^.` ({(,* branches)} (, input))) + (..case_analysis analysis archive input branches code) + + (^.` ([(, [_ {.#Symbol ["" function_name]}]) (, [_ {.#Symbol ["" arg_name]}])] (, body))) + (/function.function analysis function_name arg_name archive body) + + (^.` ((, [_ {.#Text extension_name}]) (,* extension_args))) + (//extension.apply archive analysis [extension_name extension_args]) + + (^.` ((, functionC) (,* argsC+))) + (..apply_analysis expander analysis archive functionC argsC+) + + (^.` {(, [_ {.#Nat lefts}]) (, [_ {.#Bit right?}]) (,* values)}) + (..sum_analysis analysis archive lefts right? values) + + _ + (//.except ..invalid [code]))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/case.lux new file mode 100644 index 000000000..6356d32c5 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/case.lux @@ -0,0 +1,364 @@ +(.require + [library + [lux (.except Pattern case) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" maybe] + ["[0]" try] + ["[0]" exception (.only exception)]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" mix monoid monad)]]] + [math + [number + ["n" nat]]] + ["[0]" meta (.only) + ["[0]" code] + [macro + ["^" pattern]] + ["[0]" type (.only) + ["[0]" check (.only Check)]]]]] + ["[0]" / + ["/[1]" // + ["[1][0]" complex] + ["/[1]" // + ["[1][0]" extension] + [// + ["/" analysis (.only Analysis Operation Phase) + ["[1][0]" simple] + ["[1][0]" complex] + ["[1][0]" pattern (.only Pattern)] + ["[1][0]" type] + ["[1][0]" scope] + ["[1][0]" coverage (.only Coverage)]] + [/// + ["[1]" phase]]]]]]) + +(exception .public (mismatch [type Type + pattern Code]) + (exception.report + "Type" (%.type type) + "Pattern" (%.code pattern))) + +(exception .public (sum_has_no_case [case Nat + type Type]) + (exception.report + "Case" (%.nat case) + "Type" (%.type type))) + +(exception .public (invalid [it Code]) + (exception.report + "Pattern" (%.code it))) + +(exception .public (non_tuple [type Type]) + (exception.report + "Type" (%.type type))) + +(exception .public (non_exhaustive [input Code + branches (List [Code Code]) + coverage Coverage]) + (exception.report + "Input" (%.code input) + "Branches" (%.code (code.tuple (|> branches + (list#each (function (_ [slot value]) + (list slot value))) + list#conjoint))) + "Coverage" (/coverage.format coverage))) + +(exception .public empty_branches) + +(def (quantified envs baseT) + (-> (List (List Type)) Type Type) + (.case envs + {.#End} + baseT + + {.#Item head tail} + (quantified tail {.#UnivQ head baseT}))) + +... Type-checking on the input value is done during the analysis of a +... "case" expression, to ensure that the patterns being used make +... sense for the type of the input value. +... Sometimes, that input value is complex, by depending on +... type-variables or quantifications. +... This function makes it easier for "case" analysis to properly +... type-check the input with respect to the patterns. +(def .public (tuple :it:) + (-> Type (Check [(List check.Var) Type])) + (loop (again [envs (is (List (List Type)) + (list)) + :it: :it:]) + (.case :it: + {.#Var id} + (do check.monad + [?:it:' (check.peek id)] + (.case ?:it:' + {.#Some :it:'} + (again envs :it:') + + _ + (check.except ..non_tuple :it:))) + + {.#Named name unnamedT} + (again envs unnamedT) + + {.#UnivQ env unquantifiedT} + (again {.#Item env envs} unquantifiedT) + + {.#ExQ _} + (do check.monad + [[@head :head:] check.var + [tail :tuple:] (again envs (maybe.trusted (type.applied (list :head:) :it:)))] + (in [(list.partial @head tail) :tuple:])) + + {.#Apply _} + (do [! check.monad] + [.let [[:abstraction: :parameters:] (type.flat_application :it:)] + :abstraction: (.case :abstraction: + {.#Var @abstraction} + (do ! + [?:abstraction: (check.peek @abstraction)] + (.case ?:abstraction: + {.#Some :abstraction:} + (in :abstraction:) + + _ + (check.except ..non_tuple :it:))) + + _ + (in :abstraction:))] + (.case (type.applied :parameters: :abstraction:) + {.#Some :it:} + (again envs :it:) + + {.#None} + (check.except ..non_tuple :it:))) + + {.#Product _} + (|> :it: + type.flat_tuple + (list#each (..quantified envs)) + type.tuple + [(list)] + (at check.monad in)) + + _ + (at check.monad in [(list) (..quantified envs :it:)])))) + +(def (simple_pattern_analysis type :input: location output next) + (All (_ a) (-> Type Type Location Pattern (Operation a) (Operation [Pattern a]))) + (/.with_location location + (do ///.monad + [_ (/type.check (check.check :input: type)) + outputA next] + (in [output outputA])))) + +(def (tuple_pattern_analysis pattern_analysis :input: sub_patterns next) + (All (_ a) + (-> (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a])) + Type (List Code) (Operation a) (Operation [Pattern a]))) + (do [! ///.monad] + [[@ex_var+ :input:'] (/type.check (..tuple :input:))] + (.case :input:' + {.#Product _} + (let [matches (loop (again [types (type.flat_tuple :input:') + patterns sub_patterns + output (is (List [Type Code]) + {.#End})]) + (.case [types patterns] + [{.#End} {.#End}] + output + + [{.#Item headT {.#End}} {.#Item headP {.#End}}] + {.#Item [headT headP] output} + + [remainingT {.#Item headP {.#End}}] + {.#Item [(type.tuple remainingT) headP] output} + + [{.#Item headT {.#End}} remainingP] + {.#Item [headT (code.tuple remainingP)] output} + + [{.#Item headT tailT} {.#Item headP tailP}] + (again tailT tailP {.#Item [headT headP] output}) + + _ + (undefined)))] + (do ! + [[memberP+ thenA] (list#mix (is (All (_ a) + (-> [Type Code] (Operation [(List Pattern) a]) + (Operation [(List Pattern) a]))) + (function (_ [memberT memberC] then) + (do ! + [[memberP [memberP+ thenA]] ((as (All (_ a) (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + pattern_analysis) + {.#None} memberT memberC then)] + (in [(list.partial memberP memberP+) thenA])))) + (do ! + [nextA next] + (in [(list) nextA])) + matches) + _ (/type.check (monad.each check.monad check.forget! @ex_var+))] + (in [(/pattern.tuple memberP+) + thenA]))) + + _ + (/.except ..mismatch [:input:' (code.tuple sub_patterns)])))) + +... This function handles several concerns at once, but it must be that +... way because those concerns are interleaved when doing +... pattern-matching and they cannot be separated. +... The pattern is analysed in order to get a general feel for what is +... expected of the input value. This, in turn, informs the +... type-checking of the input. +... A kind of "continuation" value is passed around which signifies +... what needs to be done _after_ analysing a pattern. +... In general, this is done to analyse the "body" expression +... associated to a particular pattern _in the context of_ said +... pattern. +... The reason why *context* is important is because patterns may bind +... values to local variables, which may in turn be referenced in the +... body expressions. +... That is why the body must be analysed in the context of the +... pattern, and not separately. +(def (pattern_analysis num_tags :input: pattern next) + (All (_ a) (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + (.case pattern + [location {.#Symbol ["" name]}] + (/.with_location location + (do ///.monad + [outputA (/scope.with_local [name :input:] + next) + idx /scope.next] + (in [{/pattern.#Bind idx} outputA]))) + + (^.with_template [<type> <input> <output>] + [[location <input>] + (simple_pattern_analysis <type> :input: location {/pattern.#Simple <output>} next)]) + ([Bit {.#Bit pattern_value} {/simple.#Bit pattern_value}] + [Nat {.#Nat pattern_value} {/simple.#Nat pattern_value}] + [Int {.#Int pattern_value} {/simple.#Int pattern_value}] + [Rev {.#Rev pattern_value} {/simple.#Rev pattern_value}] + [Frac {.#Frac pattern_value} {/simple.#Frac pattern_value}] + [Text {.#Text pattern_value} {/simple.#Text pattern_value}] + [Any {.#Tuple {.#End}} {/simple.#Unit}]) + + [location {.#Tuple (list singleton)}] + (pattern_analysis {.#None} :input: singleton next) + + [location {.#Tuple sub_patterns}] + (/.with_location location + (do [! ///.monad] + [record (//complex.normal true sub_patterns) + record_size,members,recordT (is (Operation (Maybe [Nat (List Code) Type])) + (.case record + {.#Some record} + (//complex.order true record) + + {.#None} + (in {.#None})))] + (.case record_size,members,recordT + {.#Some [record_size members recordT]} + (do ! + [_ (.case :input: + {.#Var @input} + (/type.check (do check.monad + [? (check.bound? @input)] + (if ? + (in []) + (check.check :input: recordT)))) + + _ + (in []))] + (.case members + (list singleton) + (pattern_analysis {.#None} :input: singleton next) + + _ + (..tuple_pattern_analysis pattern_analysis :input: members next))) + + {.#None} + (..tuple_pattern_analysis pattern_analysis :input: sub_patterns next)))) + + [location {.#Variant (list.partial [_ {.#Nat lefts}] [_ {.#Bit right?}] values)}] + (/.with_location location + (do ///.monad + [[@ex_var+ :input:'] (/type.check (..tuple :input:))] + (.case :input:' + {.#Sum _} + (let [flat_sum (type.flat_variant :input:') + size_sum (list.size flat_sum) + num_cases (maybe.else size_sum num_tags) + idx (/complex.tag right? lefts)] + (.case (list.item idx flat_sum) + (^.multi {.#Some caseT} + (n.< num_cases idx)) + (do ///.monad + [[testP nextA] (if (and (n.> num_cases size_sum) + (n.= (-- num_cases) idx)) + (pattern_analysis {.#None} + (type.variant (list.after (-- num_cases) flat_sum)) + (` [(,* values)]) + next) + (pattern_analysis {.#None} caseT (` [(,* values)]) next)) + _ (/type.check (monad.each check.monad check.forget! @ex_var+))] + (in [(/pattern.variant [lefts right? testP]) + nextA])) + + _ + (/.except ..sum_has_no_case [idx :input:]))) + + {.#UnivQ _} + (do ///.monad + [[ex_id exT] (/type.check check.existential) + it (pattern_analysis num_tags + (maybe.trusted (type.applied (list exT) :input:')) + pattern + next) + _ (/type.check (monad.each check.monad check.forget! @ex_var+))] + (in it)) + + _ + (/.except ..mismatch [:input:' pattern])))) + + [location {.#Variant (list.partial [_ {.#Symbol tag}] values)}] + (/.with_location location + (do ///.monad + [tag (///extension.lifted (meta.normal tag)) + [idx group variantT] (///extension.lifted (meta.tag tag)) + _ (/type.check (check.check :input: variantT)) + .let [[lefts right?] (/complex.choice (list.size group) idx)]] + (pattern_analysis {.#Some (list.size group)} :input: (` {(, (code.nat lefts)) (, (code.bit right?)) (,* values)}) next))) + + _ + (/.except ..invalid [pattern]) + )) + +(def .public (case analyse branches archive inputC) + (-> Phase (List [Code Code]) Phase) + (.case branches + {.#Item [patternH bodyH] branchesT} + (do [! ///.monad] + [[:input: inputA] (<| /type.inferring + (analyse archive inputC)) + outputH (pattern_analysis {.#None} :input: patternH (analyse archive bodyH)) + outputT (monad.each ! + (function (_ [patternT bodyT]) + (pattern_analysis {.#None} :input: patternT (analyse archive bodyT))) + branchesT) + outputHC (|> outputH product.left /coverage.coverage /.of_try) + outputTC (monad.each ! (|>> product.left /coverage.coverage /.of_try) outputT) + _ (.case (monad.mix try.monad /coverage.composite outputHC outputTC) + {try.#Success coverage} + (///.assertion ..non_exhaustive [inputC branches coverage] + (/coverage.exhaustive? coverage)) + + {try.#Failure error} + (/.failure error))] + (in {/.#Case inputA [outputH outputT]})) + + {.#End} + (/.except ..empty_branches []))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/complex.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/complex.lux new file mode 100644 index 000000000..d7b26aa8f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/complex.lux @@ -0,0 +1,433 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" maybe] + ["[0]" try] + ["[0]" exception (.only exception)] + ["[0]" state]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" monad)] + ["[0]" dictionary (.only Dictionary)]]] + [math + [number + ["n" nat]]] + ["[0]" meta (.only) + ["[0]" symbol] + ["[0]" code] + ["[0]" type (.only) + ["[0]" check]]]]] + ["[0]" // + ["[1][0]" simple] + ["/[1]" // + ["[1][0]" extension] + [// + ["/" analysis (.only Analysis Operation Phase) + ["[1][0]" complex (.only Tag)] + ["[1][0]" type] + ["[1][0]" inference]] + [/// + ["[1]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)]]]]]]) + +(exception .public (not_a_quantified_type [type Type]) + (exception.report + "Type" (%.type type))) + +(with_template [<name>] + [(exception .public (<name> [type Type + members (List Code)]) + (exception.report + "Type" (%.type type) + "Expression" (%.code (` [(,* members)]))))] + + [invalid_tuple_type] + [cannot_analyse_tuple] + ) + +(with_template [<name>] + [(exception .public (<name> [type Type + lefts Nat + right? Bit + code Code]) + (exception.report + "Type" (%.type type) + "Lefts" (%.nat lefts) + "Right?" (%.bit right?) + "Expression" (%.code code)))] + + [invalid_variant_type] + [cannot_analyse_variant] + [cannot_infer_sum] + ) + +(exception .public (cannot_repeat_slot [key Symbol + record (List [Symbol Code])]) + (exception.report + "Slot" (%.code (code.symbol key)) + "Record" (%.code (code.tuple (|> record + (list#each (function (_ [keyI valC]) + (list (code.symbol keyI) valC))) + list#conjoint))))) + +(exception .public (slot_does_not_belong_to_record [key Symbol + type Type]) + (exception.report + "Slot" (%.code (code.symbol key)) + "Type" (%.type type))) + +(exception .public (record_size_mismatch [expected Nat + actual Nat + type Type + record (List [Symbol Code])]) + (exception.report + "Expected" (%.nat expected) + "Actual" (%.nat actual) + "Type" (%.type type) + "Expression" (%.code (|> record + (list#each (function (_ [keyI valueC]) + (list (code.symbol keyI) valueC))) + list#conjoint + code.tuple)))) + +(def .public (sum analyse lefts right? archive) + (-> Phase Nat Bit Phase) + (let [tag (/complex.tag right? lefts)] + (function (again valueC) + (do [! ///.monad] + [expectedT (///extension.lifted meta.expected_type) + expectedT' (/type.check (check.clean (list) expectedT))] + (/.with_exception ..cannot_analyse_variant [expectedT' lefts right? valueC] + (case expectedT + {.#Sum _} + (|> (analyse archive valueC) + (at ! each (|>> [lefts right?] /.variant)) + (/type.expecting (|> expectedT + type.flat_variant + (list.item tag) + (maybe.else .Nothing)))) + + {.#Named name unnamedT} + (<| (/type.expecting unnamedT) + (again valueC)) + + {.#Var id} + (do ! + [?expectedT' (/type.check (check.peek id))] + (case ?expectedT' + {.#Some expectedT'} + (<| (/type.expecting expectedT') + (again valueC)) + + ... Cannot do inference when the tag is numeric. + ... This is because there is no way of knowing how many + ... cases the inferred sum type would have. + _ + (/.except ..cannot_infer_sum [expectedT lefts right? valueC]))) + + {.#UnivQ _} + (do ! + [[@instance :instance:] (/type.check check.existential)] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (again valueC))) + {.#ExQ _} + (<| /type.with_var + (function (_ [@instance :instance:])) + (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (again valueC)) + + {.#Apply inputT funT} + (case funT + {.#Var funT_id} + (do ! + [?funT' (/type.check (check.peek funT_id))] + (case ?funT' + {.#Some funT'} + (<| (/type.expecting {.#Apply inputT funT'}) + (again valueC)) + + _ + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))) + + _ + (case (type.applied (list inputT) funT) + {.#Some outputT} + (<| (/type.expecting outputT) + (again valueC)) + + {.#None} + (/.except ..not_a_quantified_type [funT]))) + + _ + (/.except ..invalid_variant_type [expectedT lefts right? valueC]))))))) + +(def .public (variant analyse tag archive valueC) + (-> Phase Symbol Phase) + (do [! ///.monad] + [tag (///extension.lifted (meta.normal tag)) + [idx group variantT] (///extension.lifted (meta.tag tag)) + .let [case_size (list.size group) + [lefts right?] (/complex.choice case_size idx)] + expectedT (///extension.lifted meta.expected_type)] + (case expectedT + {.#Var _} + (do ! + [inferenceT (/inference.variant lefts right? variantT) + [inferredT valueA+] (/inference.general archive analyse inferenceT (list valueC))] + (in (/.variant [lefts right? (|> valueA+ list.head maybe.trusted)]))) + + _ + (..sum analyse lefts right? archive valueC)))) + +(def (typed_product analyse expectedT archive members) + (-> Phase Type Archive (List Code) (Operation Analysis)) + (<| (let [! ///.monad]) + (at ! each (|>> /.tuple)) + (is (Operation (List Analysis))) + (loop (again [membersT+ (type.flat_tuple expectedT) + membersC+ members]) + (case [membersT+ membersC+] + [{.#Item memberT {.#End}} {.#Item memberC {.#End}}] + (<| (at ! each (|>> list)) + (/type.expecting memberT) + (analyse archive memberC)) + + [{.#Item memberT {.#End}} _] + (<| (/type.expecting memberT) + (at ! each (|>> list) (analyse archive (code.tuple membersC+)))) + + [_ {.#Item memberC {.#End}}] + (<| (/type.expecting (type.tuple membersT+)) + (at ! each (|>> list) (analyse archive memberC))) + + [{.#Item memberT membersT+'} {.#Item memberC membersC+'}] + (do ! + [memberA (<| (/type.expecting memberT) + (analyse archive memberC)) + memberA+ (again membersT+' membersC+')] + (in {.#Item memberA memberA+})) + + _ + (/.except ..cannot_analyse_tuple [expectedT members]))))) + +(def .public (product analyse archive membersC) + (-> Phase Archive (List Code) (Operation Analysis)) + (do [! ///.monad] + [expectedT (///extension.lifted meta.expected_type)] + (/.with_exception ..cannot_analyse_tuple [expectedT membersC] + (case expectedT + {.#Product _} + (..typed_product analyse expectedT archive membersC) + + {.#Named name unnamedT} + (<| (/type.expecting unnamedT) + (product analyse archive membersC)) + + {.#Var id} + (do ! + [?expectedT' (/type.check (check.peek id))] + (case ?expectedT' + {.#Some expectedT'} + (<| (/type.expecting expectedT') + (product analyse archive membersC)) + + _ + ... Must infer... + (do ! + [membersTA (monad.each ! (|>> (analyse archive) /type.inferring) membersC) + _ (/type.check (check.check expectedT + (type.tuple (list#each product.left membersTA))))] + (in (/.tuple (list#each product.right membersTA)))))) + + {.#UnivQ _} + (do ! + [[@instance :instance:] (/type.check check.existential)] + (<| (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (product analyse archive membersC))) + + {.#ExQ _} + (<| /type.with_var + (function (_ [@instance :instance:])) + (/type.expecting (maybe.trusted (type.applied (list :instance:) expectedT))) + (product analyse archive membersC)) + + {.#Apply inputT funT} + (case funT + {.#Var funT_id} + (do ! + [?funT' (/type.check (check.peek funT_id))] + (case ?funT' + {.#Some funT'} + (<| (/type.expecting {.#Apply inputT funT'}) + (product analyse archive membersC)) + + _ + (/.except ..invalid_tuple_type [expectedT membersC]))) + + _ + (case (type.applied (list inputT) funT) + {.#Some outputT} + (<| (/type.expecting outputT) + (product analyse archive membersC)) + + {.#None} + (/.except ..not_a_quantified_type funT))) + + _ + (/.except ..invalid_tuple_type [expectedT membersC]) + )))) + +... There cannot be any ambiguity or improper syntax when analysing +... records, so they must be normalized for further analysis. +... Normalization just means that all the tags get resolved to their +... canonical form (with their corresponding module identified). +(def .public (normal pattern_matching? record) + (-> Bit (List Code) (Operation (Maybe (List [Symbol Code])))) + (loop (again [input record + output (is (List [Symbol Code]) + {.#End})]) + (case input + (list.partial [_ {.#Symbol ["" slotH]}] valueH tail) + (if pattern_matching? + (///#in {.#None}) + (do ///.monad + [slotH (///extension.lifted (meta.normal ["" slotH]))] + (again tail {.#Item [slotH valueH] output}))) + + (list.partial [_ {.#Symbol slotH}] valueH tail) + (do ///.monad + [slotH (///extension.lifted (meta.normal slotH))] + (again tail {.#Item [slotH valueH] output})) + + {.#End} + (///#in {.#Some output}) + + _ + (///#in {.#None})))) + +(def (local_binding? name) + (-> Text (Meta Bit)) + (at meta.monad each + (list.any? (list.any? (|>> product.left (text#= name)))) + meta.locals)) + +... Lux already possesses the means to analyse tuples, so +... re-implementing the same functionality for records makes no sense. +... Records, thus, get transformed into tuples by ordering the elements. +(def (order' head_k record) + (-> Symbol (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) + (do [! ///.monad] + [slotH' (///extension.lifted + (do meta.monad + [head_k (meta.normal head_k)] + (meta.try (meta.slot head_k))))] + (case slotH' + {try.#Success [_ slot_set recordT]} + (do ! + [.let [size_record (list.size record) + size_ts (list.size slot_set)] + _ (if (n.= size_ts size_record) + (in []) + (/.except ..record_size_mismatch [size_ts size_record recordT record])) + .let [tuple_range (list.indices size_ts) + tag->idx (dictionary.of_list symbol.hash (list.zipped_2 slot_set tuple_range))] + idx->val (monad.mix ! + (function (_ [key val] idx->val) + (do ! + [key (///extension.lifted (meta.normal key))] + (case (dictionary.value key tag->idx) + {.#Some idx} + (if (dictionary.key? idx->val idx) + (/.except ..cannot_repeat_slot [key record]) + (in (dictionary.has idx val idx->val))) + + {.#None} + (/.except ..slot_does_not_belong_to_record [key recordT])))) + (is (Dictionary Nat Code) + (dictionary.empty n.hash)) + record) + .let [ordered_tuple (list#each (function (_ idx) + (maybe.trusted (dictionary.value idx idx->val))) + tuple_range)]] + (in {.#Some [size_ts ordered_tuple recordT]})) + + {try.#Failure error} + (in {.#None})))) + +(def .public (order pattern_matching? record) + (-> Bit (List [Symbol Code]) (Operation (Maybe [Nat (List Code) Type]))) + (case record + ... empty_record = empty_tuple = unit/any = [] + {.#End} + (///#in {.#Some [0 (list) .Any]}) + + {.#Item [head_k head_v] _} + (case head_k + ["" head_k'] + (if pattern_matching? + (///#in {.#None}) + (do ///.monad + [local_binding? (///extension.lifted + (..local_binding? head_k'))] + (if local_binding? + (in {.#None}) + (order' head_k record)))) + + _ + (order' head_k record)))) + +(def .public (record analyse archive members) + (-> Phase Archive (List Code) (Operation Analysis)) + (case members + (list) + //simple.unit + + (list singletonC) + (analyse archive singletonC) + + (list [_ {.#Symbol pseudo_slot}] singletonC) + (do [! ///.monad] + [head_k (///extension.lifted (meta.normal pseudo_slot)) + slot (///extension.lifted (meta.try (meta.slot head_k)))] + (case slot + {try.#Success [_ slot_set recordT]} + (case (list.size slot_set) + 1 (analyse archive singletonC) + _ (..product analyse archive members)) + + _ + (..product analyse archive members))) + + _ + (do [! ///.monad] + [?members (..normal false members)] + (case ?members + {.#None} + (..product analyse archive members) + + {.#Some slots} + (do ! + [record_size,membersC,recordT (..order false slots)] + (case record_size,membersC,recordT + {.#None} + (..product analyse archive members) + + {.#Some [record_size membersC recordT]} + (do ! + [expectedT (///extension.lifted meta.expected_type)] + (case expectedT + {.#Var _} + (do ! + [inferenceT (/inference.record record_size recordT) + [inferredT membersA] (/inference.general archive analyse inferenceT membersC)] + (in (/.tuple membersA))) + + _ + (..product analyse archive membersC))))))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/function.lux new file mode 100644 index 000000000..68d8ed9e4 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/function.lux @@ -0,0 +1,141 @@ +(.require + [library + [lux (.except function) + [abstract + [monad (.only do)]] + [control + ["[0]" maybe] + ["[0]" try] + ["[0]" exception (.only exception)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" monoid monad)]]] + [math + [number + ["n" nat]]] + ["[0]" meta (.only) + ["[0]" type (.only) + ["[0]" check]]]]] + ["[0]" /// + ["[1][0]" extension] + [// + ["/" analysis (.only Analysis Operation Phase) + ["[1][0]" type] + ["[1][0]" inference] + ["[1][0]" scope]] + [/// + ["[1]" phase (.use "[1]#[0]" functor)] + [reference (.only) + [variable (.only)]]]]]) + +(exception .public (cannot_analyse [expected Type + function Text + argument Text + body Code]) + (exception.report + "Type" (%.type expected) + "Function" function + "Argument" argument + "Body" (%.code body))) + +(exception .public (cannot_apply [:function: Type + functionC Code + arguments (List Code)]) + (exception.report + "Function type" (%.type :function:) + "Function" (%.code functionC) + "Arguments" (|> arguments + list.enumeration + (list#each (.function (_ [idx argC]) + (format (%.nat idx) " " (%.code argC)))) + (text.interposed text.new_line)))) + +(def .public (function analyse function_name arg_name archive body) + (-> Phase Text Text Phase) + (do [! ///.monad] + [expectedT (///extension.lifted meta.expected_type)] + (loop (again [expectedT expectedT]) + (/.with_exception ..cannot_analyse [expectedT function_name arg_name body] + (case expectedT + {.#Function :input: :output:} + (<| (at ! each (.function (_ [scope bodyA]) + {/.#Function (list#each (|>> /.variable) + (/scope.environment scope)) + bodyA})) + /scope.with + ... Functions have access not only to their argument, but + ... also to themselves, through a local variable. + (/scope.with_local [function_name expectedT]) + (/scope.with_local [arg_name :input:]) + (/type.expecting :output:) + (analyse archive body)) + + {.#Named name :anonymous:} + (again :anonymous:) + + {.#Apply argT funT} + (case (type.applied (list argT) funT) + {.#Some value} + (again value) + + {.#None} + (/.failure (exception.error ..cannot_analyse [expectedT function_name arg_name body]))) + + {.#UnivQ _} + (do ! + [[@instance :instance:] (/type.check check.existential)] + (again (maybe.trusted (type.applied (list :instance:) expectedT)))) + + {.#ExQ _} + (<| /type.with_var + (.function (_ [@instance :instance:])) + (again (maybe.trusted (type.applied (list :instance:) expectedT)))) + + {.#Var id} + (do ! + [?expectedT' (/type.check (check.peek id))] + (case ?expectedT' + {.#Some expectedT'} + (again expectedT') + + ... Inference + _ + (<| /type.with_var + (.function (_ [@input :input:])) + /type.with_var + (.function (_ [@output :output:])) + (do ! + [functionA (again {.#Function :input: :output:})]) + /type.check + (do check.monad + [:output: (check.identity (list) @output) + ?:input: (check.try (check.identity (list @output) @input)) + ? (check.linked? @input @output) + _ (<| (check.check expectedT) + (case ?:input: + {try.#Success :input:} + {.#Function :input: (if ? + :input: + :output:)} + + {try.#Failure _} + (|> (if ? + :input: + :output:) + {.#Function :input:} + (/inference.quantified @input 1) + {.#UnivQ (list)})))] + (in functionA))))) + + _ + (/.failure "") + ))))) + +(def .public (apply analyse argsC+ :function: functionA archive functionC) + (-> Phase (List Code) Type Analysis Phase) + (|> (/inference.general archive analyse :function: argsC+) + (///#each (|>> product.right [functionA] /.reified)) + (/.with_exception ..cannot_apply [:function: functionC argsC+]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux new file mode 100644 index 000000000..61daacb2f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/reference.lux @@ -0,0 +1,115 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" exception (.only exception)]] + [data + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]]] + ["[0]" meta (.only) + [macro + ["^" pattern]]]]] + ["[0]" // + ["/[1]" // + ["[1][0]" extension] + [// + ["/" analysis (.only Analysis Operation) + ["[1][0]" type] + ["[1][0]" scope]] + [/// + ["[1][0]" reference] + ["[1]" phase]]]]]) + +(exception .public (foreign_module_has_not_been_imported [current Text + foreign Text + definition Symbol]) + (exception.report + "Current" current + "Foreign" foreign + "Definition" (%.symbol definition))) + +(exception .public (definition_has_not_been_exported [definition Symbol]) + (exception.report + "Definition" (%.symbol definition))) + +(exception .public (labels_are_not_definitions [definition Symbol]) + (exception.report + "Label" (%.symbol definition))) + +(def (definition def_name) + (-> Symbol (Operation Analysis)) + (with_expansions [<return> (in (|> def_name ///reference.constant {/.#Reference}))] + (do [! ///.monad] + [constant (///extension.lifted (meta.definition def_name))] + (case constant + {.#Alias real_def_name} + (definition real_def_name) + + {.#Definition [exported? actualT _]} + (do ! + [_ (/type.inference actualT) + (^.let def_name [::module ::name]) (///extension.lifted (meta.normal def_name)) + current (///extension.lifted meta.current_module_name)] + (if (text#= current ::module) + <return> + (if exported? + (do ! + [imported! (///extension.lifted (meta.imported_by? ::module current))] + (if imported! + <return> + (/.except ..foreign_module_has_not_been_imported [current ::module def_name]))) + (/.except ..definition_has_not_been_exported def_name)))) + + {.#Type [exported? value labels]} + (do ! + [_ (/type.inference .Type) + (^.let def_name [::module ::name]) (///extension.lifted (meta.normal def_name)) + current (///extension.lifted meta.current_module_name)] + (if (text#= current ::module) + <return> + (if exported? + (do ! + [imported! (///extension.lifted (meta.imported_by? ::module current))] + (if imported! + <return> + (/.except ..foreign_module_has_not_been_imported [current ::module def_name]))) + (/.except ..definition_has_not_been_exported def_name)))) + + {.#Tag _} + (/.except ..labels_are_not_definitions [def_name]) + + {.#Slot _} + (/.except ..labels_are_not_definitions [def_name]))))) + +(def (variable var_name) + (-> Text (Operation (Maybe Analysis))) + (do [! ///.monad] + [?var (/scope.variable var_name)] + (case ?var + {.#Some [actualT ref]} + (do ! + [_ (/type.inference actualT)] + (in {.#Some (|> ref ///reference.variable {/.#Reference})})) + + {.#None} + (in {.#None})))) + +(def .public (reference it) + (-> Symbol (Operation Analysis)) + (case it + ["" simple_name] + (do [! ///.monad] + [?var (variable simple_name)] + (case ?var + {.#Some varA} + (in varA) + + {.#None} + (do ! + [this_module (///extension.lifted meta.current_module_name)] + (definition [this_module simple_name])))) + + _ + (definition it))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/simple.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/simple.lux new file mode 100644 index 000000000..c20161ec3 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/analysis/simple.lux @@ -0,0 +1,33 @@ +(.require + [library + [lux (.except nat int rev) + [abstract + [monad (.only do)]]]] + ["[0]" /// + [// + ["/" analysis (.only Analysis Operation) + ["[1][0]" simple] + ["[1][0]" type]] + [/// + ["[1]" phase]]]]) + +(with_template [<name> <type> <tag>] + [(def .public (<name> value) + (-> <type> (Operation Analysis)) + (do ///.monad + [_ (/type.inference <type>)] + (in {/.#Simple {<tag> value}})))] + + [bit .Bit /simple.#Bit] + [nat .Nat /simple.#Nat] + [int .Int /simple.#Int] + [rev .Rev /simple.#Rev] + [frac .Frac /simple.#Frac] + [text .Text /simple.#Text] + ) + +(def .public unit + (Operation Analysis) + (do ///.monad + [_ (/type.inference .Any)] + (in {/.#Simple {/simple.#Unit}}))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux new file mode 100644 index 000000000..86602280e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/declaration.lux @@ -0,0 +1,125 @@ +(.require + [library + [lux (.except) + ["[0]" meta] + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" try] + ["[0]" exception (.only exception)]] + [data + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" mix monoid)]]]]] + ["[0]" // + ["[1][0]" extension] + ["[1][0]" analysis] + ["/[1]" // + ["/" declaration (.only Operation Phase)] + ["[1][0]" analysis (.only) + ["[0]" evaluation] + ["[1]/[0]" macro (.only Expander)] + ["[1]/[0]" type]] + [/// + ["//" phase] + [reference (.only) + [variable (.only)]] + [meta + [archive (.only Archive)]]]]]) + +(exception .public (not_a_declaration [code Code]) + (exception.report + "Declaration" (%.code code))) + +(exception .public (invalid_macro_call [code Code]) + (exception.report + "Code" (%.code code))) + +(exception .public (macro_was_not_found [name Symbol]) + (exception.report + "Name" (%.symbol name))) + +(type Eval + (-> Type Code (Meta Any))) + +(def (meta_eval archive bundle compiler_eval) + (-> Archive ///analysis.Bundle evaluation.Eval + Eval) + (function (_ type code lux) + (case (compiler_eval archive type code [bundle lux]) + {try.#Success [[_bundle lux'] value]} + {try.#Success [lux' value]} + + {try.#Failure error} + {try.#Failure error}))) + +(def (requiring phase archive expansion) + (All (_ anchor expression declaration) + (-> (Phase anchor expression declaration) Archive (List Code) + (Operation anchor expression declaration /.Requirements))) + (function (_ state) + (loop (again [state state + input expansion + output /.no_requirements]) + (case input + {.#End} + {try.#Success [state output]} + + {.#Item head tail} + (case (phase archive head state) + {try.#Success [state' head']} + (again state' tail (/.merge_requirements head' output)) + + {try.#Failure error} + {try.#Failure error}))))) + +(with_expansions [<lux_def_module> (these [|form_location| {.#Form (list.partial [|text_location| {.#Text "lux def module"}] annotations)}])] + (def .public (phase wrapper expander) + (-> //.Wrapper Expander Phase) + (let [analysis (//analysis.phase expander)] + (function (again archive code) + (do [! //.monad] + [state //.state + .let [compiler_eval (meta_eval archive + (the [//extension.#state /.#analysis /.#state //extension.#bundle] state) + (evaluation.evaluator expander + (the [//extension.#state /.#synthesis /.#state] state) + (the [//extension.#state /.#generation /.#state] state) + (the [//extension.#state /.#generation /.#phase] state))) + extension_eval (as Eval (wrapper (as_expected compiler_eval)))] + _ (//.with (has [//extension.#state /.#analysis /.#state //extension.#state .#eval] extension_eval state))] + (case code + [_ {.#Form (list.partial [_ {.#Text name}] inputs)}] + (//extension.apply archive again [name inputs]) + + [_ {.#Form (list.partial macro inputs)}] + (do ! + [expansion (/.lifted_analysis + (do ! + [macroA (<| (///analysis/type.expecting Macro) + (analysis archive macro))] + (case macroA + (///analysis.constant macro_name) + (do ! + [?macro (//extension.lifted (meta.macro macro_name)) + macro (case ?macro + {.#Some macro} + (in macro) + + {.#None} + (//.except ..macro_was_not_found macro_name))] + (//extension.lifted (///analysis/macro.expansion expander macro_name macro inputs))) + + _ + (//.except ..invalid_macro_call code))))] + (case expansion + (list.partial <lux_def_module> referrals) + (|> (again archive <lux_def_module>) + (at ! each (revised /.#referrals (list#composite referrals)))) + + _ + (..requiring again archive expansion))) + + _ + (//.except ..not_a_declaration code))))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension.lux new file mode 100644 index 000000000..36a7deaa1 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension.lux @@ -0,0 +1,196 @@ +(.require + [library + [lux (.except with) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)] + ["[0]" monad (.only do)]] + [control + ["[0]" function] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" order) + ["%" \\format (.only Format format)]] + [collection + ["[0]" list] + ["[0]" dictionary (.only Dictionary)]]] + [meta + [macro + ["^" pattern]]]]] + [///// + ["//" phase] + [meta + [archive (.only Archive)]]]) + +(type .public Name + Text) + +(type .public (Extension a) + [Name (List a)]) + +(def .public equivalence + (All (_ a) (-> (Equivalence a) (Equivalence (Extension a)))) + (|>> list.equivalence + (product.equivalence text.equivalence))) + +(def .public hash + (All (_ a) (-> (Hash a) (Hash (Extension a)))) + (|>> list.hash + (product.hash text.hash))) + +(with_expansions [<Bundle> (these (Dictionary Name (Handler s i o)))] + (type .public (Handler s i o) + (-> Name + (//.Phase [<Bundle> s] i o) + (//.Phase [<Bundle> s] (List i) o))) + + (type .public (Bundle s i o) + <Bundle>)) + +(def .public empty + Bundle + (dictionary.empty text.hash)) + +(type .public (State s i o) + (Record + [#bundle (Bundle s i o) + #state s])) + +(type .public (Operation s i o v) + (//.Operation (State s i o) v)) + +(type .public (Phase s i o) + (//.Phase (State s i o) i o)) + +(exception .public (cannot_overwrite [name Name]) + (exception.report + "Extension" (%.text name))) + +(exception .public (incorrect_arity [name Name + arity Nat + args Nat]) + (exception.report + "Extension" (%.text name) + "Expected" (%.nat arity) + "Actual" (%.nat args))) + +(exception .public [a] (invalid_syntax [name Name + %format (Format a) + inputs (List a)]) + (exception.report + "Extension" (%.text name) + "Inputs" (exception.listing %format inputs))) + +(exception .public [s i o] (unknown [name Name + bundle (Bundle s i o)]) + (exception.report + "Extension" (%.text name) + "Available" (|> bundle + dictionary.keys + (list.sorted text#<) + (exception.listing %.text)))) + +(type .public (Extender s i o) + (-> Any (Handler s i o))) + +(def .public (install extender name handler) + (All (_ s i o) + (-> (Extender s i o) Name (Handler s i o) (Operation s i o Any))) + (function (_ [bundle state]) + (case (dictionary.has' name (extender handler) bundle) + {try.#Success bundle'} + {try.#Success [[bundle' state] + []]} + + {try.#Failure _} + (exception.except ..cannot_overwrite name)))) + +(def .public (with extender extensions) + (All (_ s i o) + (-> Extender (Bundle s i o) (Operation s i o Any))) + (|> extensions + dictionary.entries + (monad.mix //.monad + (function (_ [extension handle] output) + (..install extender extension handle)) + []))) + +(def .public (apply archive phase [name parameters]) + (All (_ s i o) + (-> Archive (Phase s i o) (Extension i) (Operation s i o o))) + (function (_ (^.let stateE [bundle state])) + (case (dictionary.value name bundle) + {.#Some handler} + (((handler name phase) archive parameters) + stateE) + + {.#None} + (exception.except ..unknown [name bundle])))) + +(def .public (localized get set transform) + (All (_ s s' i o v) + (-> (-> s s') (-> s' s s) (-> s' s') + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (let [old (get state)] + (case (operation [bundle (set (transform old) state)]) + {try.#Success [[bundle' state'] output]} + {try.#Success [[bundle' (set old state')] output]} + + {try.#Failure error} + {try.#Failure error}))))) + +(def .public (temporary transform) + (All (_ s i o v) + (-> (-> s s) + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (case (operation [bundle (transform state)]) + {try.#Success [[bundle' state'] output]} + {try.#Success [[bundle' state] output]} + + {try.#Failure error} + {try.#Failure error})))) + +(def .public (with_state state) + (All (_ s i o v) + (-> s (-> (Operation s i o v) (Operation s i o v)))) + (..temporary (function.constant state))) + +(def .public (read get) + (All (_ s i o v) + (-> (-> s v) (Operation s i o v))) + (function (_ [bundle state]) + {try.#Success [[bundle state] (get state)]})) + +(def .public (update transform) + (All (_ s i o) + (-> (-> s s) (Operation s i o Any))) + (function (_ [bundle state]) + {try.#Success [[bundle (transform state)] []]})) + +(def .public (lifted action) + (All (_ s i o v) + (-> (//.Operation s v) (Operation s i o v))) + (function (_ [bundle state]) + (case (action state) + {try.#Success [state' output]} + {try.#Success [[bundle state'] output]} + + {try.#Failure error} + {try.#Failure error}))) + +(def .public (up it) + (All (_ s i o v) + (-> (Operation s i o v) (//.Operation s v))) + (function (_ state) + (case (it [..empty state]) + {try.#Success [[_ state'] output]} + {try.#Success [state' output]} + + {try.#Failure error} + {try.#Failure error}))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis.lux new file mode 100644 index 000000000..2a887e12d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis.lux @@ -0,0 +1,16 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + [//// + [analysis (.only Bundle) + [evaluation (.only Eval)]]] + ["[0]" / + ["[1][0]" lux]]) + +(def .public (bundle eval host_specific) + (-> Eval Bundle Bundle) + (dictionary.composite host_specific + (/lux.bundle eval))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/common_lisp.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/common_lisp.lux new file mode 100644 index 000000000..377ce23c4 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/common_lisp.lux @@ -0,0 +1,13 @@ +(.require + [library + [lux (.except)]] + [/// + ["[0]" bundle] + [/// + [analysis (.only Bundle)]]]) + +(def .public bundle + Bundle + (<| (bundle.prefix "common_lisp") + (|> bundle.empty + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/js.lux new file mode 100644 index 000000000..e1fe38771 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/js.lux @@ -0,0 +1,233 @@ +(.require + [library + [lux (.except) + ["[0]" ffi] + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser]] + [data + [collection + ["[0]" array] + ["[0]" dictionary] + ["[0]" list]]] + [meta + ["@" target (.only) + ["_" js]] + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + ["[0]" type (.only) + ["[0]" check]]]]] + [// + ["/" lux (.only custom)] + [// + ["[0]" bundle] + [/// + ["[0]" analysis (.only Analysis Operation Phase Handler Bundle) + ["[1]/[0]" type]] + [/// + ["[0]" phase]]]]]) + +(def array::new + Handler + (custom + [<code>.any + (function (_ extension phase archive lengthC) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [lengthA (analysis/type.expecting Nat + (phase archive lengthC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list lengthA)}))))])) + +(def array::length + Handler + (custom + [<code>.any + (function (_ extension phase archive arrayC) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference Nat)] + (in {analysis.#Extension extension (list arrayA)}))))])) + +(def array::read + Handler + (custom + [(<>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference :read:)] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def array::write + Handler + (custom + [(all <>.and <code>.any <code>.any <code>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + valueA (analysis/type.expecting :write: + (phase archive valueC)) + arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list indexA valueA arrayA)}))))])) + +(def array::delete + Handler + (custom + [(all <>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def object::new + Handler + (custom + [(all <>.and <code>.any (<code>.tuple (<>.some <code>.any))) + (function (_ extension phase archive [constructorC inputsC]) + (do [! phase.monad] + [constructorA (analysis/type.expecting Any + (phase archive constructorC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list.partial constructorA inputsA)})))])) + +(def object::get + Handler + (custom + [(all <>.and <code>.text <code>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (analysis/type.expecting Any + (phase archive objectC)) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list (analysis.text fieldC) + objectA)})))])) + +(def object::do + Handler + (custom + [(all <>.and <code>.text <code>.any (<code>.tuple (<>.some <code>.any))) + (function (_ extension phase archive [methodC objectC inputsC]) + (do [! phase.monad] + [objectA (analysis/type.expecting Any + (phase archive objectC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list.partial (analysis.text methodC) + objectA + inputsA)})))])) + +(def bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "new" object::new) + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "null" (/.nullary Any)) + (bundle.install "null?" (/.unary Any Bit)) + (bundle.install "undefined" (/.nullary Any)) + (bundle.install "undefined?" (/.unary Any Bit)) + ))) + +(def js::constant + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.inference Any)] + (in {analysis.#Extension extension (list (analysis.text name))})))])) + +(def js::apply + Handler + (custom + [(all <>.and <code>.any (<code>.tuple (<>.some <code>.any))) + (function (_ extension phase archive [abstractionC inputsC]) + (do [! phase.monad] + [abstractionA (analysis/type.expecting Any + (phase archive abstractionC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference Any)] + (in {analysis.#Extension extension (list.partial abstractionA inputsA)})))])) + +(def js::type_of + Handler + (custom + [<code>.any + (function (_ extension phase archive objectC) + (do phase.monad + [objectA (analysis/type.expecting Any + (phase archive objectC)) + _ (analysis/type.inference .Text)] + (in {analysis.#Extension extension (list objectA)})))])) + +(def js::function + Handler + (custom + [(all <>.and <code>.nat <code>.any) + (function (_ extension phase archive [arity abstractionC]) + (do phase.monad + [.let [inputT (type.tuple (list.repeated arity Any))] + abstractionA (analysis/type.expecting (-> inputT Any) + (phase archive abstractionC)) + _ (analysis/type.inference (for @.js ffi.Function + Any))] + (in {analysis.#Extension extension (list (analysis.nat arity) + abstractionA)})))])) + +(def .public bundle + Bundle + (<| (bundle.prefix "js") + (|> bundle.empty + (dictionary.composite bundle::array) + (dictionary.composite bundle::object) + + (bundle.install "constant" js::constant) + (bundle.install "apply" js::apply) + (bundle.install "type-of" js::type_of) + (bundle.install "function" js::function) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/jvm.lux new file mode 100644 index 000000000..338029e94 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -0,0 +1,2754 @@ +(.require + [library + [lux (.except Type Module Primitive char int type) + ["[0]" ffi (.only import)] + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" pipe] + ["[0]" maybe (.use "[1]#[0]" functor)] + ["[0]" try (.only Try) (.use "[1]#[0]" monad)] + ["[0]" exception (.only exception)] + [function + ["[0]" predicate]]] + [data + [binary (.only Binary) + ["[0]" \\format]] + ["[0]" product] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)] + ["<[1]>" \\parser]] + [collection + ["[0]" list (.use "[1]#[0]" mix monad monoid)] + ["[0]" array] + ["[0]" dictionary (.only Dictionary)] + ["[0]" sequence]]] + [math + [number + ["n" nat] + ["[0]" i32]]] + ["[0]" meta (.only) + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + [macro + ["^" pattern] + ["[0]" template]] + [target + ["[0]" jvm + ["[0]!" reflection] + ["_" bytecode (.only Bytecode) (.use "[1]#[0]" monad)] + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + ["[0]" attribute] + ["[0]" field] + ["[0]" version] + ["[0]" method] + ["[0]" class] + ["[0]" constant (.only) + ["[0]" pool (.only Resource)]] + [encoding + ["[0]" name (.only External)]] + ["[1]" type (.only Type Argument Typed) (.use "[1]#[0]" equivalence) + ["[0]" category (.only Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)] + ["[0]" box] + ["[0]" reflection] + ["[0]" descriptor] + ["[0]" signature] + ["[0]" parser] + ["[0]" alias (.only Aliasing)] + ["[0]T" lux (.only Mapping)]]]] + ["[0]" type (.only) + ["[0]" check (.only Check) (.use "[1]#[0]" monad)]]]]] + ["[0]" // + ["[1][0]" lux (.only custom)] + ["/[1]" // (.only) + ["[1][0]" bundle] + ["/[1]" // + [generation + [jvm + ["[0]" runtime] + ["[0]" function + ["[1]" abstract]]]] + ["/[1]" // + ["[0]" generation] + ["[0]" declaration] + ["[1][0]" analysis (.only Analysis Operation Phase Handler Bundle) + ["[0]" complex] + ["[0]" pattern] + ["[0]" inference] + ["[0]A" type] + ["[0]" scope]] + [/// + ["[0]" phase (.use "[1]#[0]" monad)] + ["[0]" reference (.only) + ["[0]" variable]] + [meta + [archive (.only Archive) + [module + [descriptor (.only Module)]]]]]]]]]) + +(import java/lang/ClassLoader + "[1]::[0]") + +(import java/lang/Object + "[1]::[0]" + (equals [java/lang/Object] boolean)) + +(import java/lang/reflect/Type + "[1]::[0]") + +(import (java/lang/reflect/TypeVariable d) + "[1]::[0]" + (getName [] java/lang/String) + (getBounds [] [java/lang/reflect/Type])) + +(import java/lang/reflect/Modifier + "[1]::[0]" + ("static" isStatic [int] boolean) + ("static" isFinal [int] boolean) + ("static" isInterface [int] boolean) + ("static" isAbstract [int] boolean) + ("static" isPublic [int] boolean) + ("static" isProtected [int] boolean)) + +(import java/lang/annotation/Annotation + "[1]::[0]") + +(import java/lang/reflect/Method + "[1]::[0]" + (getName [] java/lang/String) + (getModifiers [] int) + (getDeclaringClass [] (java/lang/Class java/lang/Object)) + (getTypeParameters [] [(java/lang/reflect/TypeVariable java/lang/reflect/Method)]) + (getGenericParameterTypes [] [java/lang/reflect/Type]) + (getDeclaredAnnotations [] [java/lang/annotation/Annotation]) + + (getReturnType [] (java/lang/Class java/lang/Object)) + (getGenericReturnType [] "?" java/lang/reflect/Type) + + (getExceptionTypes [] [(java/lang/Class java/lang/Object)]) + (getGenericExceptionTypes [] [java/lang/reflect/Type])) + +(import (java/lang/reflect/Constructor c) + "[1]::[0]" + (getModifiers [] int) + (getDeclaringClass [] (java/lang/Class c)) + (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))]) + (getGenericParameterTypes [] [java/lang/reflect/Type]) + (getExceptionTypes [] [(java/lang/Class java/lang/Object)]) + (getGenericExceptionTypes [] [java/lang/reflect/Type]) + (getDeclaredAnnotations [] [java/lang/annotation/Annotation])) + +(import (java/lang/Class c) + "[1]::[0]" + ("static" forName [java/lang/String] "try" (java/lang/Class java/lang/Object)) + (getName [] java/lang/String) + (getModifiers [] int) + (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean) + (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/Class c))]) + (getGenericInterfaces [] [java/lang/reflect/Type]) + (getGenericSuperclass [] "?" java/lang/reflect/Type) + (getDeclaredField [java/lang/String] "try" java/lang/reflect/Field) + (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)]) + (getDeclaredMethods [] [java/lang/reflect/Method]) + (getDeclaredAnnotations [] [java/lang/annotation/Annotation]) + (getSuperclass [] "?" (java/lang/Class java/lang/Object)) + (getInterfaces [] [(java/lang/Class java/lang/Object)])) + +(with_template [<name>] + [(exception .public (<name> [class External + field Text]) + (exception.report + "Class" (%.text class) + "Field" (%.text field)))] + + [cannot_set_a_final_field] + [deprecated_field] + ) + +(exception .public (deprecated_method [class External + method Text + type .Type]) + (exception.report + "Class" (%.text class) + "Method" (%.text method) + "Type" (%.type type))) + +(exception .public (deprecated_class [class External]) + (exception.report + "Class" (%.text class))) + +(def (ensure_fresh_class! class_loader name) + (-> java/lang/ClassLoader External (Operation Any)) + (do phase.monad + [class (phase.lifted (reflection!.load class_loader name))] + (phase.assertion ..deprecated_class [name] + (|> class + java/lang/Class::getDeclaredAnnotations + reflection!.deprecated? + not)))) + +(def reflection + (All (_ category) (-> (Type (<| Return' Value' category)) Text)) + (|>> jvm.reflection reflection.reflection)) + +(def signature (|>> jvm.signature signature.signature)) + +(def object_class + External + "java.lang.Object") + +... TODO: Get rid of this with_template block and use the definition in +... lux/ffi.jvm.lux ASAP +(with_template [<name> <class>] + [(def .public <name> + .Type + {.#Primitive <class> {.#End}})] + + ... Boxes + [Boolean box.boolean] + [Byte box.byte] + [Short box.short] + [Integer box.int] + [Long box.long] + [Float box.float] + [Double box.double] + [Character box.char] + [String "java.lang.String"] + + ... Primitives + [boolean (reflection.reflection reflection.boolean)] + [byte (reflection.reflection reflection.byte)] + [short (reflection.reflection reflection.short)] + [int (reflection.reflection reflection.int)] + [long (reflection.reflection reflection.long)] + [float (reflection.reflection reflection.float)] + [double (reflection.reflection reflection.double)] + [char (reflection.reflection reflection.char)] + ) + +(.type Member + (Record + [#class External + #member Text])) + +(def member + (Parser Member) + (all <>.and <code>.text <code>.text)) + +(.type Method_Signature + (Record + [#method .Type + #deprecated? Bit + #throws (List .Type)])) + +(with_template [<name>] + [(exception .public (<name> [type .Type]) + (exception.report + "Type" (%.type type)))] + + [non_object] + [non_array] + [non_parameter] + [non_jvm_type] + ) + +(with_template [<name>] + [(exception .public (<name> [class External]) + (exception.report + "Class/type" (%.text class)))] + + [non_interface] + [non_throwable] + [primitives_are_not_objects] + ) + +(with_template [<name>] + [(exception .public (<name> [class_variables (List (Type Var)) + class External + method Text + method_variables (List (Type Var)) + inputsJT (List (Type Value)) + hints (List Method_Signature)]) + (exception.report + "Class Variables" (exception.listing ..signature class_variables) + "Class" class + "Method" method + "Method Variables" (exception.listing ..signature method_variables) + "Arguments" (exception.listing ..signature inputsJT) + "Hints" (exception.listing %.type (list#each product.left hints))))] + + [no_candidates] + [too_many_candidates] + ) + +(exception .public (cannot_cast [from .Type + to .Type + value Code]) + (exception.report + "From" (%.type from) + "To" (%.type to) + "Value" (%.code value))) + +(with_template [<name>] + [(exception .public (<name> [message Text]) + message)] + + [primitives_cannot_have_type_parameters] + + [cannot_possibly_be_an_instance] + + [unknown_type_var] + ) + +(def bundle::conversion + Bundle + (<| (///bundle.prefix "conversion") + (|> ///bundle.empty + (///bundle.install "double-to-float" (//lux.unary ..double ..float)) + (///bundle.install "double-to-int" (//lux.unary ..double ..int)) + (///bundle.install "double-to-long" (//lux.unary ..double ..long)) + (///bundle.install "float-to-double" (//lux.unary ..float ..double)) + (///bundle.install "float-to-int" (//lux.unary ..float ..int)) + (///bundle.install "float-to-long" (//lux.unary ..float ..long)) + (///bundle.install "int-to-byte" (//lux.unary ..int ..byte)) + (///bundle.install "int-to-char" (//lux.unary ..int ..char)) + (///bundle.install "int-to-double" (//lux.unary ..int ..double)) + (///bundle.install "int-to-float" (//lux.unary ..int ..float)) + (///bundle.install "int-to-long" (//lux.unary ..int ..long)) + (///bundle.install "int-to-short" (//lux.unary ..int ..short)) + (///bundle.install "long-to-double" (//lux.unary ..long ..double)) + (///bundle.install "long-to-float" (//lux.unary ..long ..float)) + (///bundle.install "long-to-int" (//lux.unary ..long ..int)) + (///bundle.install "long-to-short" (//lux.unary ..long ..short)) + (///bundle.install "long-to-byte" (//lux.unary ..long ..byte)) + (///bundle.install "char-to-byte" (//lux.unary ..char ..byte)) + (///bundle.install "char-to-short" (//lux.unary ..char ..short)) + (///bundle.install "char-to-int" (//lux.unary ..char ..int)) + (///bundle.install "char-to-long" (//lux.unary ..char ..long)) + (///bundle.install "byte-to-long" (//lux.unary ..byte ..long)) + (///bundle.install "short-to-long" (//lux.unary ..short ..long)) + ))) + +(with_template [<name> <prefix> <type>] + [(def <name> + Bundle + (<| (///bundle.prefix (reflection.reflection <prefix>)) + (|> ///bundle.empty + (///bundle.install "+" (//lux.binary <type> <type> <type>)) + (///bundle.install "-" (//lux.binary <type> <type> <type>)) + (///bundle.install "*" (//lux.binary <type> <type> <type>)) + (///bundle.install "/" (//lux.binary <type> <type> <type>)) + (///bundle.install "%" (//lux.binary <type> <type> <type>)) + (///bundle.install "=" (//lux.binary <type> <type> Bit)) + (///bundle.install "<" (//lux.binary <type> <type> Bit)) + (///bundle.install "and" (//lux.binary <type> <type> <type>)) + (///bundle.install "or" (//lux.binary <type> <type> <type>)) + (///bundle.install "xor" (//lux.binary <type> <type> <type>)) + (///bundle.install "shl" (//lux.binary ..int <type> <type>)) + (///bundle.install "shr" (//lux.binary ..int <type> <type>)) + (///bundle.install "ushr" (//lux.binary ..int <type> <type>)) + )))] + + [bundle::int reflection.int ..int] + [bundle::long reflection.long ..long] + ) + +(with_template [<name> <prefix> <type>] + [(def <name> + Bundle + (<| (///bundle.prefix (reflection.reflection <prefix>)) + (|> ///bundle.empty + (///bundle.install "+" (//lux.binary <type> <type> <type>)) + (///bundle.install "-" (//lux.binary <type> <type> <type>)) + (///bundle.install "*" (//lux.binary <type> <type> <type>)) + (///bundle.install "/" (//lux.binary <type> <type> <type>)) + (///bundle.install "%" (//lux.binary <type> <type> <type>)) + (///bundle.install "=" (//lux.binary <type> <type> Bit)) + (///bundle.install "<" (//lux.binary <type> <type> Bit)) + )))] + + [bundle::float reflection.float ..float] + [bundle::double reflection.double ..double] + ) + +(def bundle::char + Bundle + (<| (///bundle.prefix (reflection.reflection reflection.char)) + (|> ///bundle.empty + (///bundle.install "=" (//lux.binary ..char ..char Bit)) + (///bundle.install "<" (//lux.binary ..char ..char Bit)) + ))) + +(def .public boxes + (Dictionary External [External (Type Primitive)]) + (|> (list [(reflection.reflection reflection.boolean) [box.boolean jvm.boolean]] + [(reflection.reflection reflection.byte) [box.byte jvm.byte]] + [(reflection.reflection reflection.short) [box.short jvm.short]] + [(reflection.reflection reflection.int) [box.int jvm.int]] + [(reflection.reflection reflection.long) [box.long jvm.long]] + [(reflection.reflection reflection.float) [box.float jvm.float]] + [(reflection.reflection reflection.double) [box.double jvm.double]] + [(reflection.reflection reflection.char) [box.char jvm.char]]) + (dictionary.of_list text.hash))) + +(def lux_array_type + (template (_ :read: :write:) + [{.#Primitive (static array.type_name) (list {.#Apply :write: {.#Apply :read: _Mutable}})}])) + +(def (jvm_type luxT) + (-> .Type (Operation (Type Value))) + (case luxT + {.#Named name anonymousT} + (jvm_type anonymousT) + + {.#Apply inputT abstractionT} + (case (type.applied (list inputT) abstractionT) + {.#Some outputT} + (jvm_type outputT) + + {.#None} + (/////analysis.except ..non_jvm_type luxT)) + + (lux_array_type elemT _) + (phase#each jvm.array (jvm_type elemT)) + + {.#Primitive class parametersT} + (case (dictionary.value class ..boxes) + {.#Some [_ primitive_type]} + (case parametersT + {.#End} + (phase#in primitive_type) + + _ + (/////analysis.except ..primitives_cannot_have_type_parameters class)) + + {.#None} + (do [! phase.monad] + [parametersJT (is (Operation (List (Type Parameter))) + (monad.each ! + (function (_ parameterT) + (do phase.monad + [parameterJT (jvm_type parameterT)] + (case (parser.parameter? parameterJT) + {.#Some parameterJT} + (in parameterJT) + + {.#None} + (/////analysis.except ..non_parameter parameterT)))) + parametersT))] + (in (jvm.class class parametersJT)))) + + {.#Ex _} + (phase#in (jvm.class ..object_class (list))) + + {.#Function _} + (phase#in function.class) + + _ + (/////analysis.except ..non_jvm_type luxT))) + +(def (jvm_array_type objectT) + (-> .Type (Operation (Type Array))) + (do phase.monad + [objectJ (jvm_type objectT)] + (|> objectJ + ..signature + (<text>.result parser.array) + phase.lifted))) + +(def (primitive_array_length_handler primitive_type) + (-> (Type Primitive) Handler) + (function (_ extension_name analyse archive args) + (case args + (list arrayC) + (do phase.monad + [_ (typeA.inference ..int) + arrayA (<| (typeA.expecting {.#Primitive (|> (jvm.array primitive_type) + ..reflection) + (list)}) + (analyse archive arrayC))] + (in {/////analysis.#Extension extension_name (list arrayA)})) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def array::length::object + Handler + (function (_ extension_name analyse archive args) + (case args + (list arrayC) + (<| typeA.with_var + (function (_ [@read :read:])) + typeA.with_var + (function (_ [@write :write:])) + (do phase.monad + [_ (typeA.inference ..int) + arrayA (<| (typeA.expecting (.type_literal (array.Array' :read: :write:))) + (analyse archive arrayC)) + :read: (typeA.check (check.clean (list) :read:)) + :write: (typeA.check (check.clean (list) :write:)) + arrayJT (jvm_array_type (.type_literal (array.Array' :read: :write:)))] + (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature arrayJT)) + arrayA)}))) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def (new_primitive_array_handler primitive_type) + (-> (Type Primitive) Handler) + (function (_ extension_name analyse archive args) + (case args + (list lengthC) + (do phase.monad + [lengthA (<| (typeA.expecting ..int) + (analyse archive lengthC)) + _ (typeA.inference {.#Primitive (|> (jvm.array primitive_type) ..reflection) + (list)})] + (in {/////analysis.#Extension extension_name (list lengthA)})) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def array::new::object + Handler + (function (_ extension_name analyse archive args) + (case args + (list lengthC) + (do phase.monad + [lengthA (<| (typeA.expecting ..int) + (analyse archive lengthC)) + expectedT (///.lifted meta.expected_type) + expectedJT (jvm_array_type expectedT) + elementJT (case (parser.array? expectedJT) + {.#Some elementJT} + (in elementJT) + + {.#None} + (/////analysis.except ..non_array expectedT))] + (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature elementJT)) + lengthA)})) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def (check_parameter objectT) + (-> .Type (Operation (Type Parameter))) + (case objectT + (lux_array_type elementT _) + (/////analysis.except ..non_parameter objectT) + + {.#Primitive name parameters} + (`` (cond (or (,, (with_template [<type>] + [(text#= (..reflection <type>) name)] + + [jvm.boolean] + [jvm.byte] + [jvm.short] + [jvm.int] + [jvm.long] + [jvm.float] + [jvm.double] + [jvm.char])) + (text.starts_with? descriptor.array_prefix name)) + (/////analysis.except ..non_parameter objectT) + + ... else + (phase#in (jvm.class name (list))))) + + {.#Named name anonymous} + (check_parameter anonymous) + + {.#Var @var} + (do phase.monad + [:var: (typeA.check (check.peek @var))] + (case :var: + {.#Some :var:} + (check_parameter :var:) + + {.#None} + (in (jvm.class ..object_class (list))))) + + (^.or {.#Ex id} + {.#Parameter id}) + (phase#in (jvm.class ..object_class (list))) + + (^.with_template [<tag>] + [{<tag> env unquantified} + (check_parameter unquantified)]) + ([.#UnivQ] + [.#ExQ]) + + {.#Apply inputT abstractionT} + (case (type.applied (list inputT) abstractionT) + {.#Some outputT} + (check_parameter outputT) + + {.#None} + (/////analysis.except ..non_parameter objectT)) + + {.#Function _} + (phase#in function.class) + + _ + (/////analysis.except ..non_parameter objectT))) + +(def (check_jvm objectT) + (-> .Type (Operation (Type Value))) + (case objectT + {.#Primitive name {.#End}} + (`` (cond (,, (with_template [<type>] + [(text#= (..reflection <type>) name) + (phase#in <type>)] + + [jvm.boolean] + [jvm.byte] + [jvm.short] + [jvm.int] + [jvm.long] + [jvm.float] + [jvm.double] + [jvm.char])) + + (,, (with_template [<type>] + [(text#= (..reflection (jvm.array <type>)) name) + (phase#in (jvm.array <type>))] + + [jvm.boolean] + [jvm.byte] + [jvm.short] + [jvm.int] + [jvm.long] + [jvm.float] + [jvm.double] + [jvm.char])) + + (text.starts_with? descriptor.array_prefix name) + (let [[_ unprefixed] (maybe.trusted (text.split_by descriptor.array_prefix name))] + (at phase.monad each jvm.array + (check_jvm {.#Primitive unprefixed (list)}))) + + ... else + (phase#in (jvm.class name (list))))) + + (lux_array_type elementT _) + (|> elementT + check_jvm + (phase#each jvm.array)) + + {.#Primitive name parameters} + (do [! phase.monad] + [parameters (monad.each ! check_parameter parameters)] + (phase#in (jvm.class name parameters))) + + {.#Named name anonymous} + (check_jvm anonymous) + + (^.with_template [<tag>] + [{<tag> env unquantified} + (check_jvm unquantified)]) + ([.#UnivQ] + [.#ExQ]) + + {.#Apply inputT abstractionT} + (case (type.applied (list inputT) abstractionT) + {.#Some outputT} + (check_jvm outputT) + + {.#None} + (/////analysis.except ..non_object objectT)) + + _ + (check_parameter objectT))) + +(with_template [<name> <category> <parser>] + [(def .public (<name> mapping typeJ) + (-> Mapping (Type <category>) (Operation .Type)) + (case (|> typeJ ..signature (<text>.result (<parser> mapping))) + {try.#Success check} + (typeA.check check) + + {try.#Failure error} + (phase.failure error)))] + + [boxed_reflection_type Value luxT.boxed_type] + [reflection_type Value luxT.type] + [boxed_reflection_return Return luxT.boxed_return] + [reflection_return Return luxT.return] + ) + +(def (check_object objectT) + (-> .Type (Operation [External .Type])) + (do [! phase.monad] + [:object: (check_jvm objectT) + .let [name (..reflection :object:)]] + (if (dictionary.key? ..boxes name) + (/////analysis.except ..primitives_are_not_objects [name]) + (do ! + [:object: (reflection_type luxT.fresh :object:)] + (phase#in [name :object:]))))) + +(def (check_return type) + (-> .Type (Operation (Type Return))) + (if (same? .Any type) + (phase#in jvm.void) + (check_jvm type))) + +(def (read_primitive_array_handler lux_type jvm_type) + (-> .Type (Type Primitive) Handler) + (function (_ extension_name analyse archive args) + (case args + (list idxC arrayC) + (do phase.monad + [_ (typeA.inference lux_type) + idxA (<| (typeA.expecting ..int) + (analyse archive idxC)) + arrayA (<| (typeA.expecting {.#Primitive (|> (jvm.array jvm_type) ..reflection) + (list)}) + (analyse archive arrayC))] + (in {/////analysis.#Extension extension_name (list idxA arrayA)})) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def array::read::object + Handler + (function (_ extension_name analyse archive args) + (case args + (list idxC arrayC) + (<| typeA.with_var + (function (_ [@read :read:])) + typeA.with_var + (function (_ [@write :write:])) + (do phase.monad + [_ (typeA.inference :read:) + arrayA (<| (typeA.expecting (.type_literal (array.Array' :read: :write:))) + (analyse archive arrayC)) + idxA (<| (typeA.expecting ..int) + (analyse archive idxC)) + :read: (typeA.check (check.clean (list) :read:)) + :write: (typeA.check (check.clean (list) :write:)) + arrayJT (jvm_array_type (.type_literal (array.Array' :read: :write:)))] + (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature arrayJT)) + idxA + arrayA)}))) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def (write_primitive_array_handler lux_type jvm_type) + (-> .Type (Type Primitive) Handler) + (let [array_type {.#Primitive (|> (jvm.array jvm_type) ..reflection) + (list)}] + (function (_ extension_name analyse archive args) + (case args + (list idxC valueC arrayC) + (do phase.monad + [_ (typeA.inference array_type) + idxA (<| (typeA.expecting ..int) + (analyse archive idxC)) + valueA (<| (typeA.expecting lux_type) + (analyse archive valueC)) + arrayA (<| (typeA.expecting array_type) + (analyse archive arrayC))] + (in {/////analysis.#Extension extension_name (list idxA + valueA + arrayA)})) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 3 (list.size args)]))))) + +(def array::write::object + Handler + (function (_ extension_name analyse archive args) + (case args + (list idxC valueC arrayC) + (<| typeA.with_var + (function (_ [@read :read:])) + typeA.with_var + (function (_ [@write :write:])) + (do phase.monad + [_ (typeA.inference (.type_literal (array.Array' :read: :write:))) + arrayA (<| (typeA.expecting (.type_literal (array.Array' :read: :write:))) + (analyse archive arrayC)) + idxA (<| (typeA.expecting ..int) + (analyse archive idxC)) + valueA (<| (typeA.expecting :write:) + (analyse archive valueC)) + :read: (typeA.check (check.clean (list) :read:)) + :write: (typeA.check (check.clean (list) :write:)) + arrayJT (jvm_array_type (.type_literal (array.Array' :read: :write:)))] + (in {/////analysis.#Extension extension_name (list (/////analysis.text (..signature arrayJT)) + idxA + valueA + arrayA)}))) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 3 (list.size args)])))) + +(def bundle::array + Bundle + (<| (///bundle.prefix "array") + (|> ///bundle.empty + (dictionary.composite (<| (///bundle.prefix "length") + (|> ///bundle.empty + (///bundle.install (reflection.reflection reflection.boolean) (primitive_array_length_handler jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (primitive_array_length_handler jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (primitive_array_length_handler jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (primitive_array_length_handler jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (primitive_array_length_handler jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (primitive_array_length_handler jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (primitive_array_length_handler jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (primitive_array_length_handler jvm.char)) + (///bundle.install "object" array::length::object)))) + (dictionary.composite (<| (///bundle.prefix "new") + (|> ///bundle.empty + (///bundle.install (reflection.reflection reflection.boolean) (new_primitive_array_handler jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (new_primitive_array_handler jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (new_primitive_array_handler jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (new_primitive_array_handler jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (new_primitive_array_handler jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (new_primitive_array_handler jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (new_primitive_array_handler jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (new_primitive_array_handler jvm.char)) + (///bundle.install "object" array::new::object)))) + (dictionary.composite (<| (///bundle.prefix "read") + (|> ///bundle.empty + (///bundle.install (reflection.reflection reflection.boolean) (read_primitive_array_handler ..boolean jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (read_primitive_array_handler ..byte jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (read_primitive_array_handler ..short jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (read_primitive_array_handler ..int jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (read_primitive_array_handler ..long jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (read_primitive_array_handler ..float jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (read_primitive_array_handler ..double jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (read_primitive_array_handler ..char jvm.char)) + (///bundle.install "object" array::read::object)))) + (dictionary.composite (<| (///bundle.prefix "write") + (|> ///bundle.empty + (///bundle.install (reflection.reflection reflection.boolean) (write_primitive_array_handler ..boolean jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (write_primitive_array_handler ..byte jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (write_primitive_array_handler ..short jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (write_primitive_array_handler ..int jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (write_primitive_array_handler ..long jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (write_primitive_array_handler ..float jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (write_primitive_array_handler ..double jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (write_primitive_array_handler ..char jvm.char)) + (///bundle.install "object" array::write::object)))) + ))) + +(def object::null + Handler + (function (_ extension_name analyse archive args) + (case args + (list) + (do phase.monad + [expectedT (///.lifted meta.expected_type) + [_ :object:] (check_object expectedT) + _ (typeA.inference :object:)] + (in {/////analysis.#Extension extension_name (list)})) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 0 (list.size args)])))) + +(def object::null? + Handler + (function (_ extension_name analyse archive args) + (case args + (list objectC) + (do phase.monad + [_ (typeA.inference .Bit) + [objectT objectA] (typeA.inferring + (analyse archive objectC)) + _ (check_object objectT)] + (in {/////analysis.#Extension extension_name (list objectA)})) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def object::synchronized + Handler + (function (_ extension_name analyse archive args) + (case args + (list monitorC exprC) + (do phase.monad + [[monitorT monitorA] (typeA.inferring + (analyse archive monitorC)) + _ (check_object monitorT) + exprA (analyse archive exprC)] + (in {/////analysis.#Extension extension_name (list monitorA exprA)})) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def (object::throw class_loader) + (-> java/lang/ClassLoader Handler) + (function (_ extension_name analyse archive args) + (case args + (list exceptionC) + (do phase.monad + [_ (typeA.inference Nothing) + [exceptionT exceptionA] (typeA.inferring + (analyse archive exceptionC)) + [exception_class _] (check_object exceptionT) + ? (phase.lifted (reflection!.sub? class_loader "java.lang.Throwable" exception_class)) + _ (is (Operation Any) + (if ? + (in []) + (/////analysis.except non_throwable exception_class)))] + (in {/////analysis.#Extension extension_name (list exceptionA)})) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def (object::class class_loader) + (-> java/lang/ClassLoader Handler) + (function (_ extension_name analyse archive args) + (case args + (list classC) + (case classC + [_ {.#Text class}] + (do phase.monad + [_ (..ensure_fresh_class! class_loader class) + _ (typeA.inference {.#Primitive "java.lang.Class" (list {.#Primitive class (list)})}) + _ (phase.lifted (reflection!.load class_loader class))] + (in {/////analysis.#Extension extension_name (list (/////analysis.text class))})) + + _ + (/////analysis.except ///.invalid_syntax [extension_name %.code args])) + + _ + (/////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def (object::instance? class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [(all <>.and <code>.text <code>.any) + (function (_ extension_name analyse archive [sub_class objectC]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader sub_class) + _ (typeA.inference Bit) + [objectT objectA] (typeA.inferring + (analyse archive objectC)) + [object_class _] (check_object objectT) + ? (phase.lifted (reflection!.sub? class_loader object_class sub_class))] + (if ? + (in {/////analysis.#Extension extension_name (list (/////analysis.text sub_class) objectA)}) + (/////analysis.except cannot_possibly_be_an_instance (format sub_class " !<= " object_class)))))])) + +(def (class_candidate_parents class_loader source_name fromT target_name target_class) + (-> java/lang/ClassLoader External .Type External (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit]))) + (do [! phase.monad] + [source_class (phase.lifted (reflection!.load class_loader source_name)) + mapping (phase.lifted (reflection!.correspond source_class fromT))] + (monad.each ! + (function (_ superJT) + (do ! + [superJT (phase.lifted (reflection!.type superJT)) + .let [super_name (..reflection superJT)] + super_class (phase.lifted (reflection!.load class_loader super_name)) + superT (reflection_type mapping superJT)] + (in [[super_name superT] (java/lang/Class::isAssignableFrom super_class target_class)]))) + (case (java/lang/Class::getGenericSuperclass source_class) + {.#Some super} + (list.partial super (array.list {.#None} (java/lang/Class::getGenericInterfaces source_class))) + + {.#None} + (if (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers source_class)) + {.#Item (as java/lang/reflect/Type (ffi.class_for java/lang/Object)) + (array.list {.#None} (java/lang/Class::getGenericInterfaces source_class))} + (array.list {.#None} (java/lang/Class::getGenericInterfaces source_class))))))) + +(def (inheritance_candidate_parents class_loader fromT target_class toT fromC) + (-> java/lang/ClassLoader .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit]))) + (case fromT + {.#Primitive _ (list.partial self_classT super_classT super_interfacesT+)} + (monad.each phase.monad + (function (_ superT) + (do [! phase.monad] + [super_name (at ! each ..reflection (check_jvm superT)) + super_class (phase.lifted (reflection!.load class_loader super_name))] + (in [[super_name superT] + (java/lang/Class::isAssignableFrom super_class target_class)]))) + (list.partial super_classT super_interfacesT+)) + + _ + (/////analysis.except ..cannot_cast [fromT toT fromC]))) + +(def (object::cast class_loader) + (-> java/lang/ClassLoader Handler) + (function (_ extension_name analyse archive args) + (case args + (list fromC) + (do [! phase.monad] + [toT (///.lifted meta.expected_type) + target_name (at ! each ..reflection (check_jvm toT)) + [fromT fromA] (typeA.inferring + (analyse archive fromC)) + source_name (at ! each ..reflection (check_jvm fromT)) + can_cast? (is (Operation Bit) + (`` (cond (,, (with_template [<primitive> <object>] + [(let [=primitive (reflection.reflection <primitive>)] + (or (and (text#= =primitive source_name) + (or (text#= <object> target_name) + (text#= =primitive target_name))) + (and (text#= <object> source_name) + (text#= =primitive target_name)))) + (in true)] + + [reflection.boolean box.boolean] + [reflection.byte box.byte] + [reflection.short box.short] + [reflection.int box.int] + [reflection.long box.long] + [reflection.float box.float] + [reflection.double box.double] + [reflection.char box.char])) + + ... else + (do ! + [_ (phase.assertion ..primitives_are_not_objects [source_name] + (not (dictionary.key? ..boxes source_name))) + _ (phase.assertion ..primitives_are_not_objects [target_name] + (not (dictionary.key? ..boxes target_name))) + target_class (phase.lifted (reflection!.load class_loader target_name)) + _ (do ! + [source_class (phase.lifted (reflection!.load class_loader source_name))] + (phase.assertion ..cannot_cast [fromT toT fromC] + (java/lang/Class::isAssignableFrom source_class target_class)))] + (loop (again [[current_name currentT] [source_name fromT]]) + (if (text#= target_name current_name) + (in true) + (do ! + [candidate_parents (is (Operation (List [[Text .Type] Bit])) + (class_candidate_parents class_loader current_name currentT target_name target_class))] + (case (|> candidate_parents + (list.only product.right) + (list#each product.left)) + {.#Item [next_name nextT] _} + (again [next_name nextT]) + + {.#End} + (in false)))))))))] + (if can_cast? + (in {/////analysis.#Extension extension_name (list (/////analysis.text source_name) + (/////analysis.text target_name) + fromA)}) + (/////analysis.except ..cannot_cast [fromT toT fromC]))) + + _ + (/////analysis.except ///.invalid_syntax [extension_name %.code args])))) + +(def (bundle::object class_loader) + (-> java/lang/ClassLoader Bundle) + (<| (///bundle.prefix "object") + (|> ///bundle.empty + (///bundle.install "null" object::null) + (///bundle.install "null?" object::null?) + (///bundle.install "synchronized" object::synchronized) + (///bundle.install "throw" (object::throw class_loader)) + (///bundle.install "class" (object::class class_loader)) + (///bundle.install "instance?" (object::instance? class_loader)) + (///bundle.install "cast" (object::cast class_loader)) + ))) + +(def (get::static class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [..member + (function (_ extension_name analyse archive [class field]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader class) + [final? deprecated? fieldJT] (phase.lifted + (do try.monad + [class (reflection!.load class_loader class)] + (reflection!.static_field field class))) + _ (phase.assertion ..deprecated_field [class field] + (not deprecated?)) + fieldT (reflection_type luxT.fresh fieldJT) + _ (typeA.inference fieldT)] + (in (<| {/////analysis.#Extension extension_name} + (list (/////analysis.text class) + (/////analysis.text field) + (/////analysis.text (..signature fieldJT)))))))])) + +(def (put::static class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [(all <>.and ..member <code>.any) + (function (_ extension_name analyse archive [[class field] valueC]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader class) + _ (typeA.inference Any) + [final? deprecated? fieldJT] (phase.lifted + (do try.monad + [class (reflection!.load class_loader class)] + (reflection!.static_field field class))) + _ (phase.assertion ..deprecated_field [class field] + (not deprecated?)) + ... _ (phase.assertion ..cannot_set_a_final_field [class field] + ... (not final?)) + fieldT (reflection_type luxT.fresh fieldJT) + valueA (<| (typeA.expecting fieldT) + (analyse archive valueC))] + (in (<| {/////analysis.#Extension extension_name} + (list (/////analysis.text class) + (/////analysis.text field) + (/////analysis.text (..signature fieldJT)) + valueA)))))])) + +(def (get::virtual class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [(all <>.and ..member <code>.any) + (function (_ extension_name analyse archive [[class field] objectC]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader class) + [objectT objectA] (typeA.inferring + (analyse archive objectC)) + [deprecated? mapping fieldJT] (phase.lifted + (do try.monad + [class (reflection!.load class_loader class) + [final? deprecated? fieldJT] (reflection!.virtual_field field class) + mapping (reflection!.correspond class objectT)] + (in [deprecated? mapping fieldJT]))) + _ (phase.assertion ..deprecated_field [class field] + (not deprecated?)) + fieldT (reflection_type mapping fieldJT) + _ (typeA.inference fieldT)] + (in (<| {/////analysis.#Extension extension_name} + (list (/////analysis.text class) + (/////analysis.text field) + (/////analysis.text (..signature fieldJT)) + objectA)))))])) + +(def (put::virtual class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [(all <>.and ..member <code>.any <code>.any) + (function (_ extension_name analyse archive [[class field] valueC objectC]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader class) + [objectT objectA] (typeA.inferring + (analyse archive objectC)) + _ (typeA.inference objectT) + [final? deprecated? mapping fieldJT] (phase.lifted + (do try.monad + [class (reflection!.load class_loader class) + [final? deprecated? fieldJT] (reflection!.virtual_field field class) + mapping (reflection!.correspond class objectT)] + (in [final? deprecated? mapping fieldJT]))) + _ (phase.assertion ..deprecated_field [class field] + (not deprecated?)) + _ (phase.assertion ..cannot_set_a_final_field [class field] + (not final?)) + fieldT (reflection_type mapping fieldJT) + valueA (<| (typeA.expecting fieldT) + (analyse archive valueC))] + (in (<| {/////analysis.#Extension extension_name} + (list (/////analysis.text class) + (/////analysis.text field) + (/////analysis.text (..signature fieldJT)) + valueA + objectA)))))])) + +(.type Method_Style + (Variant + {#Static} + {#Abstract} + {#Virtual} + {#Special} + {#Interface})) + +(def (de_aliased aliasing) + (-> Aliasing (Type Value) (Type Value)) + (function (again it) + (`` (<| (case (parser.var? it) + {.#Some name} + (|> aliasing + (dictionary.value name) + (maybe#each jvm.var) + (maybe.else it)) + {.#None}) + (case (parser.class? it) + {.#Some [name parameters]} + (|> parameters + (list#each (|>> again (as (Type Parameter)))) + (jvm.class name)) + {.#None}) + (,, (with_template [<read> <as> <write>] + [(case (<read> it) + {.#Some :sub:} + (<write> (as (Type <as>) (again :sub:))) + {.#None})] + + [parser.array? Value jvm.array] + [parser.lower? Class jvm.lower] + [parser.upper? Class jvm.upper] + )) + it)))) + +(def (check_method aliasing class method_name method_style inputsJT method) + (-> Aliasing (java/lang/Class java/lang/Object) Text Method_Style (List (Type Value)) java/lang/reflect/Method (Operation Bit)) + (do phase.monad + [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method) + (array.list {.#None}) + (monad.each try.monad reflection!.type) + phase.lifted) + .let [modifiers (java/lang/reflect/Method::getModifiers method) + correct_class? (java/lang/Class::isAssignableFrom class (java/lang/reflect/Method::getDeclaringClass method)) + correct_method? (text#= method_name (java/lang/reflect/Method::getName method)) + same_static? (case method_style + {#Static} + (java/lang/reflect/Modifier::isStatic modifiers) + + _ + true) + same_special? (case method_style + {#Special} + (not (or (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class)) + (java/lang/reflect/Modifier::isAbstract modifiers))) + + _ + true) + same_inputs? (and (n.= (list.size inputsJT) + (list.size parameters)) + (list.every? (function (_ [expectedJC actualJC]) + (jvm#= expectedJC (de_aliased aliasing actualJC))) + (list.zipped_2 parameters inputsJT)))]] + (in (and correct_class? + correct_method? + same_static? + same_special? + same_inputs?)))) + +(def (check_constructor aliasing class inputsJT constructor) + (-> Aliasing (java/lang/Class java/lang/Object) (List (Type Value)) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit)) + (do phase.monad + [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) + (array.list {.#None}) + (monad.each try.monad reflection!.type) + phase.lifted)] + (in (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor)) + (n.= (list.size inputsJT) (list.size parameters)) + (list.every? (function (_ [expectedJC actualJC]) + (jvm#= expectedJC (de_aliased aliasing actualJC))) + (list.zipped_2 parameters inputsJT)))))) + +(def index_parameter + (-> Nat .Type) + (|>> (n.* 2) ++ {.#Parameter})) + +(def (jvm_type_var_mapping owner_tvars method_tvars) + (-> (List Text) (List Text) [(List .Type) Mapping]) + (let [jvm_tvars (list#composite owner_tvars method_tvars) + lux_tvars (|> jvm_tvars + list.reversed + list.enumeration + (list#each (function (_ [idx name]) + [name (index_parameter idx)])) + list.reversed) + num_owner_tvars (list.size owner_tvars) + owner_tvarsT (|> lux_tvars (list.first num_owner_tvars) (list#each product.right)) + mapping (dictionary.of_list text.hash lux_tvars)] + [owner_tvarsT mapping])) + +(def (lux_class it) + (-> (java/lang/Class java/lang/Object) (Type Class)) + (jvm.class (java/lang/Class::getName it) (list))) + +(with_template [<name> <type> <params>] + [(`` (def <name> + (-> (<type> (,, (template.spliced <params>))) (List (Type Class))) + (|>> (,, (template.symbol [<type> "::getExceptionTypes"])) + (array.list {.#None}) + (list#each ..lux_class))))] + + [concrete_method_exceptions java/lang/reflect/Method []] + [concrete_constructor_exceptions java/lang/reflect/Constructor [java/lang/Object]] + ) + +(def (return_type it) + (-> java/lang/reflect/Method (Try (Type Return))) + (reflection!.return + (case (java/lang/reflect/Method::getGenericReturnType it) + {.#Some it} + it + + {.#None} + (java/lang/reflect/Method::getReturnType it)))) + +(def (method_signature method_style method) + (-> Method_Style java/lang/reflect/Method (Operation Method_Signature)) + (let [owner (java/lang/reflect/Method::getDeclaringClass method) + owner_tvars (case method_style + {#Static} + (list) + + _ + (|> (java/lang/Class::getTypeParameters owner) + (array.list {.#None}) + (list#each (|>> java/lang/reflect/TypeVariable::getName)))) + method_tvars (|> (java/lang/reflect/Method::getTypeParameters method) + (array.list {.#None}) + (list#each (|>> java/lang/reflect/TypeVariable::getName))) + [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] + (do [! phase.monad] + [inputsT (|> (java/lang/reflect/Method::getGenericParameterTypes method) + (array.list {.#None}) + (monad.each ! (|>> reflection!.type phase.lifted)) + (phase#each (monad.each ! (..reflection_type mapping))) + phase#conjoint) + outputT (|> method + ..return_type + phase.lifted + (phase#each (..reflection_return mapping)) + phase#conjoint) + .let [concrete_exceptions (..concrete_method_exceptions method)] + concrete_exceptions (monad.each ! (..reflection_type mapping) concrete_exceptions) + generic_exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method) + (array.list {.#None}) + (monad.each ! (|>> reflection!.type phase.lifted)) + (phase#each (monad.each ! (..reflection_type mapping))) + phase#conjoint) + .let [methodT (<| (type.univ_q (dictionary.size mapping)) + (type.function (case method_style + {#Static} + inputsT + + _ + (list.partial {.#Primitive (java/lang/Class::getName owner) owner_tvarsT} + inputsT))) + outputT)]] + (in [methodT + (reflection!.deprecated? (java/lang/reflect/Method::getDeclaredAnnotations method)) + (if (list.empty? generic_exceptions) + concrete_exceptions + generic_exceptions)])))) + +(def (constructor_signature constructor) + (-> (java/lang/reflect/Constructor java/lang/Object) (Operation Method_Signature)) + (let [owner (java/lang/reflect/Constructor::getDeclaringClass constructor) + owner_tvars (|> (java/lang/Class::getTypeParameters owner) + (array.list {.#None}) + (list#each (|>> java/lang/reflect/TypeVariable::getName))) + method_tvars (|> (java/lang/reflect/Constructor::getTypeParameters constructor) + (array.list {.#None}) + (list#each (|>> java/lang/reflect/TypeVariable::getName))) + [owner_tvarsT mapping] (jvm_type_var_mapping owner_tvars method_tvars)] + (do [! phase.monad] + [inputsT (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) + (array.list {.#None}) + (monad.each ! (|>> reflection!.type phase.lifted)) + (phase#each (monad.each ! (reflection_type mapping))) + phase#conjoint) + .let [concrete_exceptions (..concrete_constructor_exceptions constructor)] + concrete_exceptions (monad.each ! (..reflection_type mapping) concrete_exceptions) + generic_exceptions (|> (java/lang/reflect/Constructor::getGenericExceptionTypes constructor) + (array.list {.#None}) + (monad.each ! (|>> reflection!.type phase.lifted)) + (phase#each (monad.each ! (reflection_type mapping))) + phase#conjoint) + .let [objectT {.#Primitive (java/lang/Class::getName owner) owner_tvarsT} + constructorT (<| (type.univ_q (dictionary.size mapping)) + (type.function inputsT) + objectT)]] + (in [constructorT + (reflection!.deprecated? (java/lang/reflect/Constructor::getDeclaredAnnotations constructor)) + (if (list.empty? generic_exceptions) + concrete_exceptions + generic_exceptions)])))) + +(.type Evaluation + (Variant + {#Pass Method_Signature} + {#Hint Method_Signature})) + +(with_template [<name> <tag>] + [(def <name> + (-> Evaluation (Maybe Method_Signature)) + (|>> (pipe.case + {<tag> output} + {.#Some output} + + _ + {.#None})))] + + [pass #Pass] + [hint #Hint] + ) + +(with_template [<name> <type> <method>] + [(def <name> + (-> <type> (List (Type Var))) + (|>> <method> + (array.list {.#None}) + (list#each (|>> java/lang/reflect/TypeVariable::getName jvm.var))))] + + [class_type_variables (java/lang/Class java/lang/Object) java/lang/Class::getTypeParameters] + [constructor_type_variables (java/lang/reflect/Constructor java/lang/Object) java/lang/reflect/Constructor::getTypeParameters] + [method_type_variables java/lang/reflect/Method java/lang/reflect/Method::getTypeParameters] + ) + +(def (aliasing expected actual) + (-> (List (Type Var)) (List (Type Var)) Aliasing) + (|> (list.zipped_2 (list#each parser.name actual) + (list#each parser.name expected)) + (dictionary.of_list text.hash))) + +(def (family_tree' it) + (-> (java/lang/Class java/lang/Object) + (List (java/lang/Class java/lang/Object))) + (let [interfaces (array.list {.#None} (java/lang/Class::getInterfaces it)) + supers (case (java/lang/Class::getSuperclass it) + {.#Some class} + (list.partial class interfaces) + + {.#None} + interfaces)] + (|> supers + (list#each family_tree') + list#conjoint + (list.partial it)))) + +(def family_tree + (-> (java/lang/Class java/lang/Object) + (List (java/lang/Class java/lang/Object))) + (|>> ..family_tree' + ... De-duplication + (list#mix (function (_ class all) + (dictionary.has (java/lang/Class::getName class) class all)) + (dictionary.empty text.hash)) + dictionary.values)) + +(def (all_declared_methods it) + (-> (java/lang/Class java/lang/Object) + (List java/lang/reflect/Method)) + (|> it + ..family_tree + (list#each (|>> java/lang/Class::getDeclaredMethods (array.list {.#None}))) + list#conjoint)) + +(def (method_candidate allow_inheritance? class_loader actual_class_tvars class_name actual_method_tvars method_name method_style inputsJT) + (-> Bit java/lang/ClassLoader (List (Type Var)) External (List (Type Var)) Text Method_Style (List (Type Value)) (Operation Method_Signature)) + (do [! phase.monad] + [class (phase.lifted (reflection!.load class_loader class_name)) + .let [expected_class_tvars (class_type_variables class)] + candidates (|> (if allow_inheritance? + (all_declared_methods class) + (array.list {.#None} (java/lang/Class::getDeclaredMethods class))) + (list.only (|>> java/lang/reflect/Method::getName (text#= method_name))) + (monad.each ! (is (-> java/lang/reflect/Method (Operation Evaluation)) + (function (_ method) + (do ! + [.let [expected_method_tvars (method_type_variables method) + aliasing (dictionary.composite (..aliasing expected_class_tvars actual_class_tvars) + (..aliasing expected_method_tvars actual_method_tvars))] + passes? (check_method aliasing class method_name method_style inputsJT method)] + (at ! each (if passes? + (|>> {#Pass}) + (|>> {#Hint})) + (method_signature method_style method)))))))] + (case (list.all pass candidates) + {.#Item method {.#End}} + (in method) + + {.#End} + (/////analysis.except ..no_candidates [actual_class_tvars class_name method_name actual_method_tvars inputsJT (list.all hint candidates)]) + + {.#Item method alternatives} + (if allow_inheritance? + (in method) + (/////analysis.except ..too_many_candidates [actual_class_tvars class_name method_name actual_method_tvars inputsJT (list.partial method alternatives)]))))) + +(def constructor_method + "<init>") + +(def (constructor_candidate class_loader actual_class_tvars class_name actual_method_tvars inputsJT) + (-> java/lang/ClassLoader (List (Type Var)) External (List (Type Var)) (List (Type Value)) (Operation Method_Signature)) + (do [! phase.monad] + [class (phase.lifted (reflection!.load class_loader class_name)) + .let [expected_class_tvars (class_type_variables class)] + candidates (|> class + java/lang/Class::getConstructors + (array.list {.#None}) + (monad.each ! (function (_ constructor) + (do ! + [.let [expected_method_tvars (constructor_type_variables constructor) + aliasing (dictionary.composite (..aliasing expected_class_tvars actual_class_tvars) + (..aliasing expected_method_tvars actual_method_tvars))] + passes? (check_constructor aliasing class inputsJT constructor)] + (at ! each + (if passes? + (|>> {#Pass}) + (|>> {#Hint})) + (constructor_signature constructor))))))] + (case (list.all pass candidates) + {.#Item constructor {.#End}} + (in constructor) + + {.#End} + (/////analysis.except ..no_candidates [actual_class_tvars class_name ..constructor_method actual_method_tvars inputsJT (list.all hint candidates)]) + + candidates + (/////analysis.except ..too_many_candidates [actual_class_tvars class_name ..constructor_method actual_method_tvars inputsJT candidates])))) + +(with_template [<name> <category> <parser>] + [(def .public <name> + (Parser (Type <category>)) + (<text>.then <parser> <code>.text))] + + [var Var parser.var] + [class Class parser.class] + [type Value parser.value] + [return Return parser.return] + ) + +(def input + (Parser (Typed Code)) + (<code>.tuple (<>.and ..type <code>.any))) + +(def (decorate_inputs typesT inputsA) + (-> (List (Type Value)) (List Analysis) (List Analysis)) + (|> inputsA + (list.zipped_2 (list#each (|>> ..signature /////analysis.text) typesT)) + (list#each (function (_ [type value]) + (/////analysis.tuple (list type value)))))) + +(def type_vars + (<code>.tuple (<>.some ..var))) + +(def (invoke::static class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [(all <>.and ..type_vars ..member ..type_vars (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars [class method] method_tvars argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader class) + .let [argsT (list#each product.left argsTC)] + [methodT deprecated? exceptionsT] (..method_candidate false class_loader class_tvars class method_tvars method {#Static} argsT) + _ (phase.assertion ..deprecated_method [class method methodT] + (not deprecated?)) + [outputT argsA] (inference.general archive analyse methodT (list#each product.right argsTC)) + outputJT (check_return outputT)] + (in {/////analysis.#Extension extension_name (list.partial (/////analysis.text (..signature (jvm.class class (list)))) + (/////analysis.text method) + (/////analysis.text (..signature outputJT)) + (decorate_inputs argsT argsA))})))])) + +(def (invoke::virtual class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [(all <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader class) + .let [argsT (list#each product.left argsTC)] + [methodT deprecated? exceptionsT] (..method_candidate true class_loader class_tvars class method_tvars method {#Virtual} argsT) + _ (phase.assertion ..deprecated_method [class method methodT] + (not deprecated?)) + [outputT allA] (inference.general archive analyse methodT (list.partial objectC (list#each product.right argsTC))) + .let [[objectA argsA] (case allA + {.#Item objectA argsA} + [objectA argsA] + + _ + (undefined))] + outputJT (check_return outputT)] + (in {/////analysis.#Extension extension_name (list.partial (/////analysis.text (..signature (jvm.class class (list)))) + (/////analysis.text method) + (/////analysis.text (..signature outputJT)) + objectA + (decorate_inputs argsT argsA))})))])) + +(def (invoke::special class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [(all <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars [class method] method_tvars objectC argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader class) + .let [argsT (list#each product.left argsTC)] + [methodT deprecated? exceptionsT] (..method_candidate false class_loader class_tvars class method_tvars method {#Special} argsT) + _ (phase.assertion ..deprecated_method [class method methodT] + (not deprecated?)) + [outputT allA] (inference.general archive analyse methodT (list.partial objectC (list#each product.right argsTC))) + .let [[objectA argsA] (case allA + {.#Item objectA argsA} + [objectA argsA] + + _ + (undefined))] + outputJT (check_return outputT)] + (in {/////analysis.#Extension extension_name (list.partial (/////analysis.text (..signature (jvm.class class (list)))) + (/////analysis.text method) + (/////analysis.text (..signature outputJT)) + objectA + (decorate_inputs argsT argsA))})))])) + +(def (invoke::interface class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [(all <>.and ..type_vars ..member ..type_vars <code>.any (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars [class_name method] method_tvars objectC argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader class_name) + .let [argsT (list#each product.left argsTC)] + class (phase.lifted (reflection!.load class_loader class_name)) + _ (phase.assertion non_interface class_name + (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))) + [methodT deprecated? exceptionsT] (..method_candidate true class_loader class_tvars class_name method_tvars method {#Interface} argsT) + _ (phase.assertion ..deprecated_method [class_name method methodT] + (not deprecated?)) + [outputT allA] (inference.general archive analyse methodT (list.partial objectC (list#each product.right argsTC))) + .let [[objectA argsA] (case allA + {.#Item objectA argsA} + [objectA argsA] + + _ + (undefined))] + outputJT (check_return outputT)] + (in {/////analysis.#Extension extension_name + (list.partial (/////analysis.text (..signature (jvm.class class_name (list)))) + (/////analysis.text method) + (/////analysis.text (..signature outputJT)) + objectA + (decorate_inputs argsT argsA))})))])) + +(def (invoke::constructor class_loader) + (-> java/lang/ClassLoader Handler) + (..custom + [(all <>.and ..type_vars <code>.text ..type_vars (<>.some ..input)) + (function (_ extension_name analyse archive [class_tvars class method_tvars argsTC]) + (do phase.monad + [_ (..ensure_fresh_class! class_loader class) + .let [argsT (list#each product.left argsTC)] + [methodT deprecated? exceptionsT] (..constructor_candidate class_loader class_tvars class method_tvars argsT) + _ (phase.assertion ..deprecated_method [class ..constructor_method methodT] + (not deprecated?)) + [outputT argsA] (inference.general archive analyse methodT (list#each product.right argsTC))] + (in {/////analysis.#Extension extension_name (list.partial (/////analysis.text (..signature (jvm.class class (list)))) + (decorate_inputs argsT argsA))})))])) + +(def (bundle::member class_loader) + (-> java/lang/ClassLoader Bundle) + (<| (///bundle.prefix "member") + (|> ///bundle.empty + (dictionary.composite (<| (///bundle.prefix "get") + (|> ///bundle.empty + (///bundle.install "static" (get::static class_loader)) + (///bundle.install "virtual" (get::virtual class_loader))))) + (dictionary.composite (<| (///bundle.prefix "put") + (|> ///bundle.empty + (///bundle.install "static" (put::static class_loader)) + (///bundle.install "virtual" (put::virtual class_loader))))) + (dictionary.composite (<| (///bundle.prefix "invoke") + (|> ///bundle.empty + (///bundle.install "static" (invoke::static class_loader)) + (///bundle.install "virtual" (invoke::virtual class_loader)) + (///bundle.install "special" (invoke::special class_loader)) + (///bundle.install "interface" (invoke::interface class_loader)) + (///bundle.install "constructor" (invoke::constructor class_loader)) + ))) + ))) + +(.type .public (Annotation_Parameter a) + [Text a]) + +(def annotation_parameter + (Parser (Annotation_Parameter Code)) + (<code>.tuple (<>.and <code>.text <code>.any))) + +(.type .public (Annotation a) + [Text (List (Annotation_Parameter a))]) + +(def .public annotation + (Parser (Annotation Code)) + (<code>.form (<>.and <code>.text (<>.some ..annotation_parameter)))) + +(def .public argument + (Parser Argument) + (<code>.tuple (<>.and <code>.text ..type))) + +(def (annotation_parameter_analysis [name value]) + (-> (Annotation_Parameter Analysis) Analysis) + (/////analysis.tuple (list (/////analysis.text name) value))) + +(def (annotation_analysis [name parameters]) + (-> (Annotation Analysis) Analysis) + (/////analysis.tuple (list.partial (/////analysis.text name) + (list#each annotation_parameter_analysis parameters)))) + +(with_template [<name> <category>] + [(def <name> + (-> (Type <category>) Analysis) + (|>> ..signature /////analysis.text))] + + [var_analysis Var] + [class_analysis Class] + [value_analysis Value] + [return_analysis Return] + ) + +(def (typed_analysis [type term]) + (-> (Typed Analysis) Analysis) + (/////analysis.tuple (list (value_analysis type) term))) + +(def (argument_analysis [argument argumentJT]) + (-> Argument Analysis) + (/////analysis.tuple + (list (/////analysis.text argument) + (value_analysis argumentJT)))) + +(with_template [<name> <only> <methods>] + [(def (<name> [type class]) + (-> [(Type Class) (java/lang/Class java/lang/Object)] + (Try (List [(Type Class) Text (Type Method)]))) + (|> class + <methods> + (list.only (|>> java/lang/reflect/Method::getModifiers + (predicate.or (|>> java/lang/reflect/Modifier::isPublic) + (|>> java/lang/reflect/Modifier::isProtected)))) + <only> + (monad.each try.monad + (function (_ method) + (do [! try.monad] + [.let [type_variables (|> (java/lang/reflect/Method::getTypeParameters method) + (array.list {.#None}) + (list#each (|>> java/lang/reflect/TypeVariable::getName + jvm.var)))] + inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method) + (array.list {.#None}) + (monad.each ! reflection!.type)) + return (..return_type method) + .let [concrete_exceptions (..concrete_method_exceptions method)] + generic_exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method) + (array.list {.#None}) + (monad.each ! reflection!.class))] + (in [type + (java/lang/reflect/Method::getName method) + (jvm.method [type_variables inputs return (if (list.empty? generic_exceptions) + concrete_exceptions + generic_exceptions)])]))))))] + + [abstract_methods (list.only (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract)) + (<| (array.list {.#None}) java/lang/Class::getDeclaredMethods)] + [methods (<|) + ..all_declared_methods] + ) + +(def jvm_package_separator ".") + +(with_template [<name> <methods>] + [(def (<name> class_loader) + (-> java/lang/ClassLoader (List (Type Class)) (Try (List [(Type Class) Text (Type Method)]))) + (|>> (monad.each try.monad (function (_ type) + (|> type + ..reflection + (reflection!.load class_loader) + (try#each (|>> [type]))))) + (try#each (monad.each try.monad <methods>)) + try#conjoint + (try#each list#conjoint)))] + + [all_abstract_methods ..abstract_methods] + [all_methods ..methods] + ) + +(with_template [<name>] + [(exception .public (<name> [expected (List [(Type Class) Text (Type Method)]) + actual (List [(Type Class) Text (Type Method)])]) + (let [%method (is (%.Format [(Type Class) Text (Type Method)]) + (function (_ [super name type]) + (format (..signature super) " :: " (%.text name) " " (..signature type))))] + (exception.report + "Expected Methods" (exception.listing %method expected) + "Actual Methods" (exception.listing %method actual))))] + + [missing_abstract_methods] + [invalid_overriden_methods] + ) + +(.type .public Visibility + (Variant + {#Public} + {#Private} + {#Protected} + {#Default})) + +(.type .public Finality Bit) +(.type .public Strictness Bit) + +(def .public public_tag "public") +(def .public private_tag "private") +(def .public protected_tag "protected") +(def .public default_tag "default") + +(def .public visibility' + (<text>.Parser Visibility) + (all <>.or + (<text>.this ..public_tag) + (<text>.this ..private_tag) + (<text>.this ..protected_tag) + (<text>.this ..default_tag) + )) + +(def .public visibility + (Parser Visibility) + (<text>.then ..visibility' <code>.text)) + +(def .public (visibility_analysis visibility) + (-> Visibility Analysis) + (/////analysis.text (case visibility + {#Public} ..public_tag + {#Private} ..private_tag + {#Protected} ..protected_tag + {#Default} ..default_tag))) + +(.type Exception + (Type Class)) + +(def .public parameter_types + (-> (List (Type Var)) (Check (List [(Type Var) .Type]))) + (monad.each check.monad + (function (_ parameterJ) + (do check.monad + [[_ parameterT] check.existential] + (in [parameterJ parameterT]))))) + +(.type .public (Abstract_Method a) + [Text + Visibility + (List (Annotation a)) + (List (Type Var)) + (List Argument) + (Type Return) + (List Exception)]) + +(def .public abstract_tag "abstract") + +(def .public abstract_method_definition + (Parser (Abstract_Method Code)) + (<| <code>.form + (<>.after (<code>.this_text ..abstract_tag)) + (all <>.and + <code>.text + ..visibility + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + (<code>.tuple (<>.some ..argument)) + ..return + (<code>.tuple (<>.some ..class))))) + +(def (method_mapping of_class parameters) + (-> Mapping (List (Type Var)) (Check Mapping)) + (|> parameters + ..parameter_types + (check#each (list#mix (function (_ [parameterJ parameterT] mapping) + (dictionary.has (parser.name parameterJ) parameterT mapping)) + of_class)))) + +(def class_mapping + (-> (List (Type Var)) (Check Mapping)) + (..method_mapping luxT.fresh)) + +(def .public (analyse_abstract_method analyse archive method) + (-> Phase Archive (Abstract_Method Code) (Operation Analysis)) + (let [[method_name visibility annotations vars arguments return exceptions] method] + (do [! phase.monad] + [mapping (typeA.check (method_mapping luxT.fresh vars)) + annotationsA (monad.each ! (function (_ [name parameters]) + (do ! + [parametersA (monad.each ! (function (_ [name value]) + (do ! + [valueA (analyse archive value)] + (in [name valueA]))) + parameters)] + (in [name parametersA]))) + annotations)] + (in (/////analysis.tuple (list (/////analysis.text ..abstract_tag) + (/////analysis.text method_name) + (visibility_analysis visibility) + (/////analysis.tuple (list#each annotation_analysis annotationsA)) + (/////analysis.tuple (list#each var_analysis vars)) + (/////analysis.tuple (list#each ..argument_analysis arguments)) + (return_analysis return) + (/////analysis.tuple (list#each class_analysis exceptions)) + )))))) + +(.type .public (Constructor a) + [Visibility + Strictness + (List (Annotation a)) + (List (Type Var)) + (List Exception) + Text + (List Argument) + (List (Typed a)) + a]) + +(def .public constructor_tag "init") + +(def .public constructor_definition + (Parser (Constructor Code)) + (<| <code>.form + (<>.after (<code>.this_text ..constructor_tag)) + (all <>.and + ..visibility + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + (<code>.tuple (<>.some ..class)) + <code>.text + (<code>.tuple (<>.some ..argument)) + (<code>.tuple (<>.some ..input)) + <code>.any))) + +(def (with_fake_parameter#pattern it) + (-> pattern.Pattern pattern.Pattern) + (case it + {pattern.#Simple _} + it + + {pattern.#Complex it} + {pattern.#Complex + (case it + {complex.#Variant it} + {complex.#Variant (revised complex.#value with_fake_parameter#pattern it)} + + {complex.#Tuple it} + {complex.#Tuple (list#each with_fake_parameter#pattern it)})} + + {pattern.#Bind it} + {pattern.#Bind (++ it)})) + +(def (with_fake_parameter it) + (-> Analysis Analysis) + (case it + {/////analysis.#Simple _} + it + + {/////analysis.#Structure it} + {/////analysis.#Structure + (case it + {complex.#Variant it} + {complex.#Variant (revised complex.#value with_fake_parameter it)} + + {complex.#Tuple it} + {complex.#Tuple (list#each with_fake_parameter it)})} + + {/////analysis.#Reference it} + {/////analysis.#Reference + (case it + {reference.#Variable it} + {reference.#Variable + (case it + {variable.#Local it} + {variable.#Local (++ it)} + + {variable.#Foreign _} + it)} + + {reference.#Constant _} + it)} + + {/////analysis.#Case value [head tail]} + {/////analysis.#Case (with_fake_parameter value) + (let [with_fake_parameter (is (-> /////analysis.Branch /////analysis.Branch) + (|>> (revised /////analysis.#when with_fake_parameter#pattern) + (revised /////analysis.#then with_fake_parameter)))] + [(with_fake_parameter head) + (list#each with_fake_parameter tail)])} + + {/////analysis.#Function environment body} + {/////analysis.#Function (list#each with_fake_parameter environment) + body} + + {/////analysis.#Apply parameter abstraction} + {/////analysis.#Apply (with_fake_parameter parameter) + (with_fake_parameter abstraction)} + + {/////analysis.#Extension name parameters} + {/////analysis.#Extension name + (list#each with_fake_parameter parameters)})) + +(def .public (hidden_method_body arity bodyA) + (-> Nat Analysis Analysis) + (<| /////analysis.tuple + (list (/////analysis.unit)) + (case arity + (^.or 0 1) + bodyA + + 2 + (let [forced_refencing (/////analysis.tuple (list#each (|>> /////analysis.local) (list.indices (++ arity))))] + {/////analysis.#Case (/////analysis.unit) + [[/////analysis.#when + {pattern.#Bind 2} + + /////analysis.#then + (/////analysis.tuple (list forced_refencing bodyA))] + (list)]}) + + _ + (let [forced_refencing (/////analysis.tuple (list#each (|>> /////analysis.local) (list.indices (++ arity))))] + {/////analysis.#Case (/////analysis.unit) + [[/////analysis.#when + {pattern.#Complex + {complex.#Tuple + (|> (-- arity) + list.indices + (list#each (|>> (n.+ 2) {pattern.#Bind})))}} + + /////analysis.#then + (/////analysis.tuple (list forced_refencing bodyA))] + (list)]})))) + +(def .public (analyse_constructor_method analyse archive selfT mapping method) + (-> Phase Archive .Type Mapping (Constructor Code) (Operation Analysis)) + (let [[visibility strict_fp? + annotations vars exceptions + self_name arguments super_arguments body] method] + (do [! phase.monad] + [mapping (typeA.check (method_mapping mapping vars)) + annotationsA (monad.each ! (function (_ [name parameters]) + (do ! + [parametersA (monad.each ! (function (_ [name value]) + (do ! + [valueA (analyse archive value)] + (in [name valueA]))) + parameters)] + (in [name parametersA]))) + annotations) + super_arguments (monad.each ! (function (_ [jvmT super_argC]) + (do ! + [luxT (reflection_type mapping jvmT) + super_argA (<| (typeA.expecting luxT) + (analyse archive super_argC))] + (in [jvmT super_argA]))) + super_arguments) + arguments' (monad.each ! + (function (_ [name jvmT]) + (do ! + [luxT (boxed_reflection_type mapping jvmT)] + (in [name luxT]))) + arguments) + [scope bodyA] (|> arguments' + {.#Item [self_name selfT]} + list.reversed + (list#mix scope.with_local (analyse archive body)) + (typeA.expecting .Any) + scope.with) + .let [arity (list.size arguments)]] + (in (/////analysis.tuple (list (/////analysis.text ..constructor_tag) + (visibility_analysis visibility) + (/////analysis.bit strict_fp?) + (/////analysis.tuple (list#each annotation_analysis annotationsA)) + (/////analysis.tuple (list#each var_analysis vars)) + (/////analysis.tuple (list#each class_analysis exceptions)) + (/////analysis.text self_name) + (/////analysis.tuple (list#each ..argument_analysis arguments)) + (/////analysis.tuple (list#each typed_analysis super_arguments)) + {/////analysis.#Function + (list#each (|>> /////analysis.variable) + (scope.environment scope)) + (<| (..hidden_method_body arity) + (case arity + 0 (with_fake_parameter bodyA) + _ bodyA))} + )))))) + +(.type .public (Virtual_Method a) + [Text + Visibility + Finality + Strictness + (List (Annotation a)) + (List (Type Var)) + Text + (List Argument) + (Type Return) + (List Exception) + a]) + +(def .public virtual_tag "virtual") + +(def .public virtual_method_definition + (Parser (Virtual_Method Code)) + (<| <code>.form + (<>.after (<code>.this_text ..virtual_tag)) + (all <>.and + <code>.text + ..visibility + <code>.bit + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + <code>.text + (<code>.tuple (<>.some ..argument)) + ..return + (<code>.tuple (<>.some ..class)) + <code>.any))) + +(.type .public (Method_Declaration a) + (Record + [#name Text + #annotations (List (Annotation a)) + #type_variables (List (Type Var)) + #exceptions (List (Type Class)) + #arguments (List (Type Value)) + #return (Type Return)])) + +(def .public method_declaration + (Parser (Method_Declaration Code)) + (<code>.form + (all <>.and + <code>.text + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + (<code>.tuple (<>.some ..class)) + (<code>.tuple (<>.some ..type)) + ..return + ))) + +(def .public (analyse_virtual_method analyse archive selfT mapping method) + (-> Phase Archive .Type Mapping (Virtual_Method Code) (Operation Analysis)) + (let [[method_name visibility + final? strict_fp? annotations vars + self_name arguments return exceptions + body] method] + (do [! phase.monad] + [mapping (typeA.check (method_mapping mapping vars)) + annotationsA (monad.each ! (function (_ [name parameters]) + (do ! + [parametersA (monad.each ! (function (_ [name value]) + (do ! + [valueA (analyse archive value)] + (in [name valueA]))) + parameters)] + (in [name parametersA]))) + annotations) + :return: (boxed_reflection_return mapping return) + arguments' (monad.each ! + (function (_ [name jvmT]) + (do ! + [luxT (boxed_reflection_type mapping jvmT)] + (in [name luxT]))) + arguments) + [scope bodyA] (|> arguments' + {.#Item [self_name selfT]} + list.reversed + (list#mix scope.with_local (analyse archive body)) + (typeA.expecting :return:) + scope.with) + .let [arity (list.size arguments)]] + (in (/////analysis.tuple (list (/////analysis.text ..virtual_tag) + (/////analysis.text method_name) + (visibility_analysis visibility) + (/////analysis.bit final?) + (/////analysis.bit strict_fp?) + (/////analysis.tuple (list#each annotation_analysis annotationsA)) + (/////analysis.tuple (list#each var_analysis vars)) + (/////analysis.text self_name) + (/////analysis.tuple (list#each ..argument_analysis arguments)) + (return_analysis return) + (/////analysis.tuple (list#each class_analysis exceptions)) + {/////analysis.#Function + (list#each (|>> /////analysis.variable) + (scope.environment scope)) + (<| (..hidden_method_body arity) + (case arity + 0 (with_fake_parameter bodyA) + _ bodyA))} + )))))) + +(.type .public (Static_Method a) + [Text + Visibility + Strictness + (List (Annotation a)) + (List (Type Var)) + (List Argument) + (Type Return) + (List Exception) + a]) + +(def .public static_tag "static") + +(def .public static_method_definition + (Parser (Static_Method Code)) + (<| <code>.form + (<>.after (<code>.this_text ..static_tag)) + (all <>.and + <code>.text + ..visibility + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + (<code>.tuple (<>.some ..argument)) + ..return + (<code>.tuple (<>.some ..class)) + <code>.any))) + +(def .public (analyse_static_method analyse archive mapping method) + (-> Phase Archive Mapping (Static_Method Code) (Operation Analysis)) + (let [[method_name visibility + strict_fp? annotations vars + arguments return exceptions + body] method] + (do [! phase.monad] + [mapping (typeA.check (method_mapping mapping vars)) + annotationsA (monad.each ! (function (_ [name parameters]) + (do ! + [parametersA (monad.each ! (function (_ [name value]) + (do ! + [valueA (analyse archive value)] + (in [name valueA]))) + parameters)] + (in [name parametersA]))) + annotations) + :return: (boxed_reflection_return mapping return) + arguments' (monad.each ! + (function (_ [name jvmT]) + (do ! + [luxT (boxed_reflection_type mapping jvmT)] + (in [name luxT]))) + arguments) + [scope bodyA] (|> arguments' + list.reversed + (list#mix scope.with_local (analyse archive body)) + (typeA.expecting :return:) + scope.with)] + (in (/////analysis.tuple (list (/////analysis.text ..static_tag) + (/////analysis.text method_name) + (visibility_analysis visibility) + (/////analysis.bit strict_fp?) + (/////analysis.tuple (list#each annotation_analysis annotationsA)) + (/////analysis.tuple (list#each var_analysis vars)) + (/////analysis.tuple (list#each ..argument_analysis arguments)) + (return_analysis return) + (/////analysis.tuple (list#each class_analysis + exceptions)) + {/////analysis.#Function + (list#each (|>> /////analysis.variable) + (scope.environment scope)) + (/////analysis.tuple (list bodyA))} + )))))) + +(.type .public (Overriden_Method a) + [(Type Class) + Text + Bit + (List (Annotation a)) + (List (Type Var)) + Text + (List Argument) + (Type Return) + (List (Type Class)) + a]) + +(def .public overriden_tag "override") + +(def .public overriden_method_definition + (Parser (Overriden_Method Code)) + (<| <code>.form + (<>.after (<code>.this_text ..overriden_tag)) + (all <>.and + ..class + <code>.text + <code>.bit + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..var)) + <code>.text + (<code>.tuple (<>.some ..argument)) + ..return + (<code>.tuple (<>.some ..class)) + <code>.any + ))) + +(exception .public (unknown_super [name Text + supers (List (Type Class))]) + (exception.report + "Name" (%.text name) + "Available" (exception.listing (|>> parser.read_class product.left) supers))) + +(exception .public (mismatched_super_parameters [name Text + expected Nat + actual Nat]) + (exception.report + "Name" (%.text name) + "Expected" (%.nat expected) + "Actual" (%.nat actual))) + +(def (override_mapping mapping supers parent_type) + (-> Mapping (List (Type Class)) (Type Class) (Operation (List [Text .Type]))) + (let [[parent_name parent_parameters] (parser.read_class parent_type)] + (case (list.one (function (_ super) + (let [[super_name super_parameters] (parser.read_class super)] + (if (text#= parent_name super_name) + {.#Some super_parameters} + {.#None}))) + supers) + {.#Some super_parameters} + (let [expected_count (list.size parent_parameters) + actual_count (list.size super_parameters)] + (if (n.= expected_count actual_count) + (do [! phase.monad] + [parent_parameters (|> parent_parameters + (monad.each maybe.monad parser.var?) + try.of_maybe + phase.lifted)] + (|> super_parameters + (monad.each ! (..reflection_type mapping)) + (at ! each (|>> (list.zipped_2 parent_parameters))))) + (phase.lifted (exception.except ..mismatched_super_parameters [parent_name expected_count actual_count])))) + + {.#None} + (phase.lifted (exception.except ..unknown_super [parent_name supers]))))) + +(def .public (with_override_mapping supers parent_type mapping) + (-> (List (Type Class)) (Type Class) Mapping (Operation Mapping)) + (do phase.monad + [override_mapping (..override_mapping mapping supers parent_type)] + (in (list#mix (function (_ [super_var bound_type] mapping) + (dictionary.has super_var bound_type mapping)) + mapping + override_mapping)))) + +(def .public (analyse_overriden_method analyse archive selfT mapping supers method) + (-> Phase Archive .Type Mapping (List (Type Class)) (Overriden_Method Code) (Operation Analysis)) + (let [[parent_type method_name + strict_fp? annotations vars + self_name arguments return exceptions + body] method] + (do [! phase.monad] + [mapping (..with_override_mapping supers parent_type mapping) + mapping (typeA.check (method_mapping mapping vars)) + annotationsA (monad.each ! (function (_ [name parameters]) + (do ! + [parametersA (monad.each ! (function (_ [name value]) + (do ! + [valueA (analyse archive value)] + (in [name valueA]))) + parameters)] + (in [name parametersA]))) + annotations) + arguments' (monad.each ! + (function (_ [name jvmT]) + (do ! + [luxT (boxed_reflection_type mapping jvmT)] + (in [name luxT]))) + arguments) + :return: (boxed_reflection_return mapping return) + [scope bodyA] (|> arguments' + {.#Item [self_name selfT]} + list.reversed + (list#mix scope.with_local (analyse archive body)) + (typeA.expecting :return:) + scope.with) + .let [arity (list.size arguments)]] + (in (/////analysis.tuple (list (/////analysis.text ..overriden_tag) + (class_analysis parent_type) + (/////analysis.text method_name) + (/////analysis.bit strict_fp?) + (/////analysis.tuple (list#each annotation_analysis annotationsA)) + (/////analysis.tuple (list#each var_analysis vars)) + (/////analysis.text self_name) + (/////analysis.tuple (list#each ..argument_analysis arguments)) + (return_analysis return) + (/////analysis.tuple (list#each class_analysis + exceptions)) + {/////analysis.#Function + (list#each (|>> /////analysis.variable) + (scope.environment scope)) + (<| (..hidden_method_body arity) + (case arity + 0 (with_fake_parameter bodyA) + _ bodyA))} + )))))) + +(def (matched? [sub sub_method subJT] [super super_method superJT]) + (-> [(Type Class) Text (Type Method)] [(Type Class) Text (Type Method)] Bit) + (and (at descriptor.equivalence = (jvm.descriptor super) (jvm.descriptor sub)) + (text#= super_method sub_method) + (jvm#= superJT subJT))) + +(def (mismatched_methods super_set sub_set) + (-> (List [(Type Class) Text (Type Method)]) + (List [(Type Class) Text (Type Method)]) + (List [(Type Class) Text (Type Method)])) + (list.only (function (_ sub) + (not (list.any? (matched? sub) super_set))) + sub_set)) + +(exception .public (class_parameter_mismatch [name Text + declaration (Type Class) + expected (List Text) + actual (List (Type Parameter))]) + (exception.report + "Class" (%.text name) + "Declaration" (signature.signature (jvm.signature declaration)) + "Expected (amount)" (%.nat (list.size expected)) + "Expected (parameters)" (exception.listing %.text expected) + "Actual (amount)" (%.nat (list.size actual)) + "Actual (parameters)" (exception.listing ..signature actual))) + +(def (super_aliasing class_loader class) + (-> java/lang/ClassLoader (Type Class) (Operation Aliasing)) + (do phase.monad + [.let [[name actual_parameters] (parser.read_class class)] + jvm_class (phase.lifted (reflection!.load class_loader name)) + .let [expected_parameters (|> (java/lang/Class::getTypeParameters jvm_class) + (array.list {.#None}) + (list#each (|>> java/lang/reflect/TypeVariable::getName)))] + _ (phase.assertion ..class_parameter_mismatch [name class expected_parameters actual_parameters] + (n.= (list.size expected_parameters) + (list.size actual_parameters)))] + (in (|> (list.zipped_2 expected_parameters actual_parameters) + (list#mix (function (_ [expected actual] mapping) + (case (parser.var? actual) + {.#Some actual} + (dictionary.has actual expected mapping) + + {.#None} + mapping)) + alias.fresh))))) + +(def (anonymous_class_name module id) + (-> Module Nat Text) + (let [global (text.replaced .module_separator ..jvm_package_separator module) + local (format "anonymous-class" (%.nat id))] + (format global ..jvm_package_separator local))) + +(def .public (require_complete_method_concretion class_loader supers methods) + (-> java/lang/ClassLoader (List (Type Class)) (List (Overriden_Method Code)) (Operation Any)) + (do [! phase.monad] + [required_abstract_methods (phase.lifted (all_abstract_methods class_loader supers)) + available_methods (phase.lifted (all_methods class_loader supers)) + overriden_methods (monad.each ! (function (_ [parent_type method_name + strict_fp? annotations type_vars + self_name arguments return exceptions + body]) + (do ! + [aliasing (super_aliasing class_loader parent_type)] + (in (|> (jvm.method [type_vars + (list#each product.right arguments) + return + exceptions]) + (alias.method aliasing) + [parent_type method_name])))) + methods) + .let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods) + invalid_overriden_methods (mismatched_methods available_methods overriden_methods)] + _ (phase.assertion ..missing_abstract_methods [required_abstract_methods overriden_methods] + (list.empty? missing_abstract_methods)) + _ (phase.assertion ..invalid_overriden_methods [available_methods invalid_overriden_methods] + (list.empty? invalid_overriden_methods))] + (in []))) + +(.type Declaration + [Text (List (Type Var))]) + +(.type Constant + [Text (List Annotation) (Type Value) Code]) + +(.type Variable + [Text (Modifier field.Field) (Modifier field.Field) (List Annotation) (Type Value)]) + +(.type Field + (Variant + {#Constant Constant} + {#Variable Variable})) + +(.type (Method_Definition a) + (Variant + {#Constructor (..Constructor a)} + {#Virtual_Method (..Virtual_Method a)} + {#Static_Method (..Static_Method a)} + {#Overriden_Method (..Overriden_Method a)} + {#Abstract_Method (..Abstract_Method a)})) + +(def class_name + (|>> parser.read_class product.left name.internal)) + +(def (mock_class [name parameters] super interfaces fields methods modifier) + (-> Declaration (Type Class) (List (Type Class)) + (List (Resource field.Field)) (List (Resource method.Method)) (Modifier class.Class) + (Try [External Binary])) + (let [signature (signature.inheritance (list#each jvm.signature parameters) + (jvm.signature super) + (list#each jvm.signature interfaces))] + (try#each (|>> (\\format.result class.format) + [name]) + (class.class version.v6_0 + (all modifier#composite + class.public + modifier) + (name.internal name) + {.#Some signature} + (..class_name super) + (list#each ..class_name interfaces) + fields + methods + sequence.empty)))) + +(def constant::modifier + (Modifier field.Field) + (all modifier#composite + field.public + field.static + field.final + )) + +(def (field_definition field) + (-> Field (Resource field.Field)) + (case field + ... TODO: Handle annotations. + {#Constant [name annotations type value]} + (case value + (^.with_template [<tag> <type> <constant>] + [[_ {<tag> value}] + (do pool.monad + [constant (`` (|> value (,, (template.spliced <constant>)))) + attribute (attribute.constant constant)] + (field.field ..constant::modifier name #1 <type> (sequence.sequence attribute)))]) + ([.#Bit jvm.boolean [(pipe.case #0 +0 #1 +1) .i64 i32.i32 constant.integer pool.integer]] + [.#Int jvm.byte [.i64 i32.i32 constant.integer pool.integer]] + [.#Int jvm.short [.i64 i32.i32 constant.integer pool.integer]] + [.#Int jvm.int [.i64 i32.i32 constant.integer pool.integer]] + [.#Int jvm.long [constant.long pool.long]] + [.#Frac jvm.float [ffi.double_to_float constant.float pool.float]] + [.#Frac jvm.double [constant.double pool.double]] + [.#Nat jvm.char [.i64 i32.i32 constant.integer pool.integer]] + [.#Text (jvm.class "java.lang.String" (list)) [pool.string]] + ) + + ... TODO: Tighten this pattern-matching so this catch-all clause isn't necessary. + _ + (undefined)) + + ... TODO: Handle annotations. + {#Variable [name visibility state annotations type]} + (field.field (modifier#composite visibility state) + name #1 type sequence.empty))) + +(def method_privacy + (-> ffi.Privacy (Modifier method.Method)) + (|>> (pipe.case + {ffi.#PublicP} method.public + {ffi.#PrivateP} method.private + {ffi.#ProtectedP} method.protected + {ffi.#DefaultP} modifier.empty))) + +(def constructor_name + "<init>") + +(def (mock_value valueT) + (-> (Type Value) (Bytecode Any)) + (case (jvm.primitive? valueT) + {.#Left classT} + _.aconst_null + + {.#Right primitiveT} + (cond (at jvm.equivalence = jvm.long primitiveT) + _.lconst_0 + + (at jvm.equivalence = jvm.float primitiveT) + _.fconst_0 + + (at jvm.equivalence = jvm.double primitiveT) + _.dconst_0 + + ... jvm.boolean jvm.byte jvm.short jvm.int jvm.char + _.iconst_0))) + +(def (mock_return :return:) + (-> (Type Return) (Bytecode Any)) + (case (jvm.void? :return:) + {.#Right :return:} + _.return + + {.#Left valueT} + (all _.composite + (mock_value valueT) + (case (jvm.primitive? valueT) + {.#Left classT} + _.areturn + + {.#Right primitiveT} + (cond (at jvm.equivalence = jvm.long primitiveT) + _.lreturn + + (at jvm.equivalence = jvm.float primitiveT) + _.freturn + + (at jvm.equivalence = jvm.double primitiveT) + _.dreturn + + ... jvm.boolean jvm.byte jvm.short jvm.int jvm.char + _.ireturn))))) + +(def (mock_method super method) + (-> (Type Class) (Method_Definition Code) (Resource method.Method)) + (case method + {#Constructor [privacy strict_floating_point? annotations variables exceptions + self arguments constructor_arguments + body]} + (method.method (all modifier#composite + (..method_privacy privacy) + (if strict_floating_point? + method.strict + modifier.empty)) + ..constructor_name + #0 (jvm.method [variables (list#each product.right arguments) jvm.void exceptions]) + (list) + {.#Some (all _.composite + (_.aload 0) + (|> constructor_arguments + (list#each (|>> product.left ..mock_value)) + (monad.all _.monad)) + (|> (jvm.method [(list) (list#each product.left constructor_arguments) jvm.void (list)]) + (_.invokespecial super ..constructor_name)) + _.return + )}) + + {#Overriden_Method [super name strict_floating_point? annotations variables + self arguments return exceptions + body]} + (method.method (all modifier#composite + method.public + (if strict_floating_point? + method.strict + modifier.empty)) + name + #0 (jvm.method [variables (list#each product.right arguments) return exceptions]) + (list) + {.#Some (..mock_return return)}) + + {#Virtual_Method [name privacy final? strict_floating_point? annotations variables + self arguments return exceptions + body]} + (method.method (all modifier#composite + (..method_privacy privacy) + (if strict_floating_point? + method.strict + modifier.empty) + (if final? + method.final + modifier.empty)) + name + #0 (jvm.method [variables (list#each product.right arguments) return exceptions]) + (list) + {.#Some (..mock_return return)}) + + {#Static_Method [name privacy strict_floating_point? annotations + variables arguments return exceptions + body]} + (method.method (all modifier#composite + method.static + (..method_privacy privacy) + (if strict_floating_point? + method.strict + modifier.empty)) + name + #0 (jvm.method [variables (list#each product.right arguments) return exceptions]) + (list) + {.#Some (..mock_return return)}) + + {#Abstract_Method [name privacy annotations + variables arguments return exceptions]} + (method.method (all modifier#composite + method.abstract + (..method_privacy privacy)) + name + #0 (jvm.method [variables (list#each product.right arguments) return exceptions]) + (list) + {.#None}) + )) + +(def (mock declaration super interfaces inheritance fields methods) + (-> Declaration + (Type Class) (List (Type Class)) + (Modifier class.Class) (List ..Field) (List (Method_Definition Code)) + (Try [External Binary])) + (mock_class declaration super interfaces + (list#each ..field_definition fields) + (list#each (..mock_method super) methods) + inheritance)) + +(def (class::anonymous class_loader host) + (-> java/lang/ClassLoader runtime.Host Handler) + (..custom + [(all <>.and + (<code>.tuple (<>.some ..var)) + ..class + (<code>.tuple (<>.some ..class)) + (<code>.tuple (<>.some ..input)) + (<code>.tuple (<>.some ..overriden_method_definition))) + (function (_ extension_name analyse archive [parameters + super_class + super_interfaces + constructor_args + methods]) + (do [! phase.monad] + [_ (..ensure_fresh_class! class_loader (..reflection super_class)) + _ (monad.each ! (|>> ..reflection (..ensure_fresh_class! class_loader)) super_interfaces) + + self_name (///.lifted (do meta.monad + [where meta.current_module_name + id meta.seed] + (in (..anonymous_class_name where id)))) + .let [selfT {.#Primitive self_name (list)}] + mock (<| phase.lifted + (..mock [self_name parameters] + super_class + super_interfaces + class.final + (list) + (list#each (|>> {#Overriden_Method}) methods))) + ... Necessary for reflection to work properly during analysis. + _ (phase.lifted (at host execute mock)) + + mapping (typeA.check (..class_mapping parameters)) + super_classT (typeA.check (luxT.check (luxT.class mapping) (..signature super_class))) + super_interfaceT+ (typeA.check (monad.each check.monad + (|>> ..signature (luxT.check (luxT.class mapping))) + super_interfaces)) + _ (typeA.inference selfT) + constructor_argsA+ (monad.each ! (function (_ [type term]) + (do ! + [argT (reflection_type mapping type) + termA (<| (typeA.expecting argT) + (analyse archive term))] + (in [type termA]))) + constructor_args) + .let [supers {.#Item super_class super_interfaces}] + _ (..require_complete_method_concretion class_loader supers methods) + methodsA (monad.each ! (analyse_overriden_method analyse archive selfT mapping supers) methods)] + (in {/////analysis.#Extension extension_name + (list (class_analysis super_class) + (/////analysis.tuple (list#each class_analysis super_interfaces)) + (/////analysis.tuple (list#each typed_analysis constructor_argsA+)) + (/////analysis.tuple methodsA))})))])) + +(def (bundle::class class_loader host) + (-> java/lang/ClassLoader runtime.Host Bundle) + (<| (///bundle.prefix "class") + (|> ///bundle.empty + (///bundle.install "anonymous" (class::anonymous class_loader host)) + ))) + +(def .public (bundle class_loader host) + (-> java/lang/ClassLoader runtime.Host Bundle) + (<| (///bundle.prefix "jvm") + (|> ///bundle.empty + (dictionary.composite bundle::conversion) + (dictionary.composite bundle::int) + (dictionary.composite bundle::long) + (dictionary.composite bundle::float) + (dictionary.composite bundle::double) + (dictionary.composite bundle::char) + (dictionary.composite bundle::array) + (dictionary.composite (bundle::object class_loader)) + (dictionary.composite (bundle::member class_loader)) + (dictionary.composite (bundle::class class_loader host)) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lua.lux new file mode 100644 index 000000000..803e0f40f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lua.lux @@ -0,0 +1,267 @@ +(.require + [library + [lux (.except) + ["[0]" ffi] + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser]] + [data + [collection + ["[0]" array] + ["[0]" dictionary] + ["[0]" list]]] + [meta + ["@" target (.only) + ["_" lua]] + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + ["[0]" type (.only) + ["[0]" check]]]]] + [// + ["/" lux (.only custom)] + [// + ["[0]" bundle] + [/// + ["[0]" analysis (.only Analysis Operation Phase Handler Bundle) + ["[1]/[0]" type]] + [/// + ["[0]" phase]]]]]) + +(def Nil + (for @.lua ffi.Nil + Any)) + +(def Object + (for @.lua (type_literal (ffi.Object Any)) + Any)) + +(def Function + (for @.lua ffi.Function + Any)) + +(def array::new + Handler + (custom + [<code>.any + (function (_ extension phase archive lengthC) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [lengthA (analysis/type.expecting Nat + (phase archive lengthC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list lengthA)}))))])) + +(def array::length + Handler + (custom + [<code>.any + (function (_ extension phase archive arrayC) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference Nat)] + (in {analysis.#Extension extension (list arrayA)}))))])) + +(def array::read + Handler + (custom + [(<>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference :read:)] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def array::write + Handler + (custom + [(all <>.and <code>.any <code>.any <code>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + valueA (analysis/type.expecting :write: + (phase archive valueC)) + arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list indexA valueA arrayA)}))))])) + +(def array::delete + Handler + (custom + [(all <>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def object::get + Handler + (custom + [(all <>.and <code>.text <code>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (analysis/type.expecting ..Object + (phase archive objectC)) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list (analysis.text fieldC) + objectA)})))])) + +(def object::do + Handler + (custom + [(all <>.and <code>.text <code>.any (<code>.tuple (<>.some <code>.any))) + (function (_ extension phase archive [methodC objectC inputsC]) + (do [! phase.monad] + [objectA (analysis/type.expecting ..Object + (phase archive objectC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list.partial (analysis.text methodC) + objectA + inputsA)})))])) + +(def bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "nil" (/.nullary ..Nil)) + (bundle.install "nil?" (/.unary Any Bit)) + ))) + +(with_template [<name> <fromT> <toT>] + [(def <name> + Handler + (custom + [<code>.any + (function (_ extension phase archive inputC) + (do [! phase.monad] + [inputA (analysis/type.expecting (type_literal <fromT>) + (phase archive inputC)) + _ (analysis/type.inference (type_literal <toT>))] + (in {analysis.#Extension extension (list inputA)})))]))] + + [utf8::encode Text (array.Array (I64 Any))] + [utf8::decode (array.Array (I64 Any)) Text] + ) + +(def bundle::utf8 + Bundle + (<| (bundle.prefix "utf8") + (|> bundle.empty + (bundle.install "encode" utf8::encode) + (bundle.install "decode" utf8::decode) + ))) + +(def lua::constant + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.inference Any)] + (in {analysis.#Extension extension (list (analysis.text name))})))])) + +(def lua::apply + Handler + (custom + [(all <>.and <code>.any (<code>.tuple (<>.some <code>.any))) + (function (_ extension phase archive [abstractionC inputsC]) + (do [! phase.monad] + [abstractionA (analysis/type.expecting ..Function + (phase archive abstractionC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference Any)] + (in {analysis.#Extension extension (list.partial abstractionA inputsA)})))])) + +(def lua::power + Handler + (custom + [(all <>.and <code>.any <code>.any) + (function (_ extension phase archive [powerC baseC]) + (do [! phase.monad] + [powerA (analysis/type.expecting Frac + (phase archive powerC)) + baseA (analysis/type.expecting Frac + (phase archive baseC)) + _ (analysis/type.inference Frac)] + (in {analysis.#Extension extension (list powerA baseA)})))])) + +(def lua::import + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.inference ..Object)] + (in {analysis.#Extension extension (list (analysis.text name))})))])) + +(def lua::function + Handler + (custom + [(all <>.and <code>.nat <code>.any) + (function (_ extension phase archive [arity abstractionC]) + (do phase.monad + [.let [inputT (type.tuple (list.repeated arity Any))] + abstractionA (analysis/type.expecting (-> inputT Any) + (phase archive abstractionC)) + _ (analysis/type.inference ..Function)] + (in {analysis.#Extension extension (list (analysis.nat arity) + abstractionA)})))])) + +(def .public bundle + Bundle + (<| (bundle.prefix "lua") + (|> bundle.empty + (dictionary.composite bundle::array) + (dictionary.composite bundle::object) + (dictionary.composite bundle::utf8) + + (bundle.install "constant" lua::constant) + (bundle.install "apply" lua::apply) + (bundle.install "power" lua::power) + (bundle.install "import" lua::import) + (bundle.install "function" lua::function) + (bundle.install "script universe" (/.nullary .Bit)) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lux.lux new file mode 100644 index 000000000..b053b850c --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/lux.lux @@ -0,0 +1,313 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" maybe] + ["[0]" try] + ["[0]" exception (.only exception)]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" dictionary (.only Dictionary)]]] + [math + [number + ["n" nat]]] + ["[0]" meta (.only) + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + [macro + ["^" pattern]] + [type + ["[0]" check]]]]] + ["[0]" /// (.only) + ["[1][0]" bundle] + ["/[1]" // + [// + ["[1][0]" analysis (.only Analysis Operation Phase Handler Bundle) + [evaluation (.only Eval)] + ["[0]A" type]] + [/// + ["[1]" phase] + [meta + [archive (.only Archive)]]]]]]) + +(def .public (custom [syntax handler]) + (All (_ s) + (-> [(Parser s) + (-> Text Phase Archive s (Operation Analysis))] + Handler)) + (function (_ extension_name analyse archive args) + (case (<code>.result syntax args) + {try.#Success inputs} + (handler extension_name analyse archive inputs) + + {try.#Failure _} + (////analysis.except ///.invalid_syntax [extension_name %.code args])))) + +(def (simple inputsT+ outputT) + (-> (List Type) Type Handler) + (let [num_expected (list.size inputsT+)] + (function (_ extension_name analyse archive args) + (let [num_actual (list.size args)] + (if (n.= num_expected num_actual) + (do [! ////.monad] + [_ (typeA.inference outputT) + argsA (monad.each ! + (function (_ [argT argC]) + (<| (typeA.expecting argT) + (analyse archive argC))) + (list.zipped_2 inputsT+ args))] + (in {////analysis.#Extension extension_name argsA})) + (////analysis.except ///.incorrect_arity [extension_name num_expected num_actual])))))) + +(def .public (nullary valueT) + (-> Type Handler) + (simple (list) valueT)) + +(def .public (unary inputT outputT) + (-> Type Type Handler) + (simple (list inputT) outputT)) + +(def .public (binary subjectT paramT outputT) + (-> Type Type Type Handler) + (simple (list subjectT paramT) outputT)) + +(def .public (trinary subjectT param0T param1T outputT) + (-> Type Type Type Type Handler) + (simple (list subjectT param0T param1T) outputT)) + +... TODO: Get rid of this ASAP +(these + (exception .public (char_text_must_be_size_1 [text Text]) + (exception.report + "Text" (%.text text))) + + (def text_char + (Parser text.Char) + (do <>.monad + [raw <code>.text] + (case (text.size raw) + 1 (in (|> raw (text.char 0) maybe.trusted)) + _ (<>.failure (exception.error ..char_text_must_be_size_1 [raw]))))) + + (def lux::syntax_char_case! + (..custom + [(all <>.and + <code>.any + (<code>.tuple (<>.some (<>.and (<code>.tuple (<>.many ..text_char)) + <code>.any))) + <code>.any) + (function (_ extension_name phase archive [input conditionals else]) + (do [! ////.monad] + [input (<| (typeA.expecting text.Char) + (phase archive input)) + expectedT (///.lifted meta.expected_type) + conditionals (monad.each ! (function (_ [cases branch]) + (do ! + [branch (<| (typeA.expecting expectedT) + (phase archive branch))] + (in [cases branch]))) + conditionals) + else (<| (typeA.expecting expectedT) + (phase archive else))] + (in (|> conditionals + (list#each (function (_ [cases branch]) + (////analysis.tuple + (list (////analysis.tuple (list#each (|>> ////analysis.nat) cases)) + branch)))) + (list.partial input else) + {////analysis.#Extension extension_name}))))]))) + +... "lux is" represents reference/pointer equality. +(def lux::is + Handler + (function (_ extension_name analyse archive args) + (<| typeA.with_var + (function (_ [@var :var:])) + ((binary :var: :var: Bit extension_name) + analyse archive args)))) + +... "lux try" provides a simple way to interact with the host platform's +... error_handling facilities. +(def lux::try + Handler + (function (_ extension_name analyse archive args) + (case args + (list opC) + (<| typeA.with_var + (function (_ [@var :var:])) + (do [! ////.monad] + [_ (typeA.inference (type_literal (Either Text :var:)))] + (|> opC + (analyse archive) + (typeA.expecting (type_literal (-> .Any :var:))) + (at ! each (|>> list {////analysis.#Extension extension_name}))))) + + _ + (////analysis.except ///.incorrect_arity [extension_name 1 (list.size args)])))) + +(def lux::in_module + Handler + (function (_ extension_name analyse archive argsC+) + (case argsC+ + (list [_ {.#Text module_name}] exprC) + (////analysis.with_current_module module_name + (analyse archive exprC)) + + _ + (////analysis.except ///.invalid_syntax [extension_name %.code argsC+])))) + +(def (lux::type::check eval) + (-> Eval Handler) + (function (_ extension_name analyse archive args) + (case args + (list typeC valueC) + (do [! ////.monad] + [actualT (at ! each (|>> (as Type)) + (eval archive Type typeC)) + _ (typeA.inference actualT)] + (<| (typeA.expecting actualT) + (analyse archive valueC))) + + _ + (////analysis.except ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def (lux::type::as eval) + (-> Eval Handler) + (function (_ extension_name analyse archive args) + (case args + (list typeC valueC) + (do [! ////.monad] + [actualT (at ! each (|>> (as Type)) + (eval archive Type typeC)) + _ (typeA.inference actualT) + [valueT valueA] (typeA.inferring + (analyse archive valueC))] + (in valueA)) + + _ + (////analysis.except ///.incorrect_arity [extension_name 2 (list.size args)])))) + +(def (caster input output) + (-> Type Type Handler) + (..custom + [<code>.any + (function (_ extension_name phase archive valueC) + (do [! ////.monad] + [_ (typeA.inference output)] + (<| (typeA.expecting input) + (phase archive valueC))))])) + +(exception .public (not_a_type [symbol Symbol]) + (exception.report + "Symbol" (%.symbol symbol))) + +(def lux::macro + Handler + (..custom + [<code>.any + (function (_ extension_name phase archive valueC) + (do [! ////.monad] + [_ (typeA.inference .Macro) + input_type (loop (again [input_name (symbol .Macro')]) + (do ! + [input_type (///.lifted (meta.definition (symbol .Macro')))] + (case input_type + (^.or {.#Definition [exported? def_type def_value]} + {.#Type [exported? def_value labels]}) + (in (as Type def_value)) + + (^.or {.#Tag _} + {.#Slot _}) + (////.failure (exception.error ..not_a_type [(symbol .Macro')])) + + {.#Alias real_name} + (again real_name))))] + (<| (typeA.expecting input_type) + (phase archive valueC))))])) + +(def (bundle::lux eval) + (-> Eval Bundle) + (|> ///bundle.empty + (///bundle.install "syntax char case!" lux::syntax_char_case!) + (///bundle.install "is" lux::is) + (///bundle.install "try" lux::try) + (///bundle.install "type check" (lux::type::check eval)) + (///bundle.install "type as" (lux::type::as eval)) + (///bundle.install "macro" ..lux::macro) + (///bundle.install "type check type" (..caster .Type .Type)) + (///bundle.install "in-module" lux::in_module))) + +(def bundle::io + Bundle + (<| (///bundle.prefix "io") + (|> ///bundle.empty + (///bundle.install "log" (unary Text Any)) + (///bundle.install "error" (unary Text Nothing)) + (///bundle.install "exit" (unary Int Nothing))))) + +(def I64* + (type_literal (I64 Any))) + +(def bundle::i64 + Bundle + (<| (///bundle.prefix "i64") + (|> ///bundle.empty + (///bundle.install "and" (binary I64* I64* I64)) + (///bundle.install "or" (binary I64* I64* I64)) + (///bundle.install "xor" (binary I64* I64* I64)) + (///bundle.install "left-shift" (binary Nat I64* I64)) + (///bundle.install "right-shift" (binary Nat I64* I64)) + (///bundle.install "=" (binary I64* I64* Bit)) + (///bundle.install "<" (binary Int Int Bit)) + (///bundle.install "+" (binary I64* I64* I64)) + (///bundle.install "-" (binary I64* I64* I64)) + (///bundle.install "*" (binary Int Int Int)) + (///bundle.install "/" (binary Int Int Int)) + (///bundle.install "%" (binary Int Int Int)) + (///bundle.install "f64" (unary Int Frac)) + (///bundle.install "char" (unary Int Text))))) + +(def bundle::f64 + Bundle + (<| (///bundle.prefix "f64") + (|> ///bundle.empty + (///bundle.install "+" (binary Frac Frac Frac)) + (///bundle.install "-" (binary Frac Frac Frac)) + (///bundle.install "*" (binary Frac Frac Frac)) + (///bundle.install "/" (binary Frac Frac Frac)) + (///bundle.install "%" (binary Frac Frac Frac)) + (///bundle.install "=" (binary Frac Frac Bit)) + (///bundle.install "<" (binary Frac Frac Bit)) + (///bundle.install "i64" (unary Frac Int)) + (///bundle.install "encode" (unary Frac Text)) + (///bundle.install "decode" (unary Text (type_literal (Maybe Frac))))))) + +(def bundle::text + Bundle + (<| (///bundle.prefix "text") + (|> ///bundle.empty + (///bundle.install "=" (binary Text Text Bit)) + (///bundle.install "<" (binary Text Text Bit)) + (///bundle.install "concat" (binary Text Text Text)) + (///bundle.install "index" (trinary Nat Text Text (type_literal (Maybe Nat)))) + (///bundle.install "size" (unary Text Nat)) + (///bundle.install "char" (binary Nat Text Nat)) + (///bundle.install "clip" (trinary Nat Nat Text Text)) + ))) + +(def .public (bundle eval) + (-> Eval Bundle) + (<| (///bundle.prefix "lux") + (|> ///bundle.empty + (dictionary.composite (bundle::lux eval)) + (dictionary.composite bundle::i64) + (dictionary.composite bundle::f64) + (dictionary.composite bundle::text) + (dictionary.composite bundle::io) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/php.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/php.lux new file mode 100644 index 000000000..b5a632992 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/php.lux @@ -0,0 +1,221 @@ +(.require + [library + [lux (.except) + ["[0]" ffi] + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser]] + [data + [collection + ["[0]" array (.only Array)] + ["[0]" dictionary] + ["[0]" list]]] + [meta + ["@" target (.only) + ["_" php]] + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + ["[0]" type (.only) + ["[0]" check]]]]] + [// + ["/" lux (.only custom)] + [// + ["[0]" bundle] + [// + ["[0]" analysis + ["[1]/[0]" type]] + [// + ["[0]" analysis (.only Analysis Operation Phase Handler Bundle)] + [/// + ["[0]" phase]]]]]]) + +(def array::new + Handler + (custom + [<code>.any + (function (_ extension phase archive lengthC) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [lengthA (analysis/type.with_type Nat + (phase archive lengthC)) + _ (analysis/type.infer (type_literal (Array :var:)))] + (in {analysis.#Extension extension (list lengthA)}))))])) + +(def array::length + Handler + (custom + [<code>.any + (function (_ extension phase archive arrayC) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [arrayA (analysis/type.with_type (type_literal (Array :var:)) + (phase archive arrayC)) + _ (analysis/type.infer Nat)] + (in {analysis.#Extension extension (list arrayA)}))))])) + +(def array::read + Handler + (custom + [(<>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + arrayA (analysis/type.with_type (type_literal (Array :var:)) + (phase archive arrayC)) + _ (analysis/type.infer :var:)] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def array::write + Handler + (custom + [(all <>.and <code>.any <code>.any <code>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + valueA (analysis/type.with_type :var: + (phase archive valueC)) + arrayA (analysis/type.with_type (type_literal (Array :var:)) + (phase archive arrayC)) + _ (analysis/type.infer (type_literal (Array :var:)))] + (in {analysis.#Extension extension (list indexA valueA arrayA)}))))])) + +(def array::delete + Handler + (custom + [(all <>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + arrayA (analysis/type.with_type (type_literal (Array :var:)) + (phase archive arrayC)) + _ (analysis/type.infer (type_literal (Array :var:)))] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def Null + (for @.php ffi.Null + Any)) + +(def Object + (for @.php (type_literal (ffi.Object Any)) + Any)) + +(def Function + (for @.php ffi.Function + Any)) + +(def object::new + Handler + (custom + [(all <>.and <code>.text (<>.some <code>.any)) + (function (_ extension phase archive [constructor inputsC]) + (do [! phase.monad] + [inputsA (monad.each ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (in {analysis.#Extension extension (list.partial (analysis.text constructor) inputsA)})))])) + +(def object::get + Handler + (custom + [(all <>.and <code>.text <code>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + _ (analysis/type.infer .Any)] + (in {analysis.#Extension extension (list (analysis.text fieldC) + objectA)})))])) + +(def object::do + Handler + (custom + [(all <>.and <code>.text <code>.any (<>.some <code>.any)) + (function (_ extension phase archive [methodC objectC inputsC]) + (do [! phase.monad] + [objectA (analysis/type.with_type ..Object + (phase archive objectC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer .Any)] + (in {analysis.#Extension extension (list.partial (analysis.text methodC) + objectA + inputsA)})))])) + +(def bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "new" object::new) + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "null" (/.nullary ..Null)) + (bundle.install "null?" (/.unary Any Bit)) + ))) + +(def php::constant + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Any)] + (in {analysis.#Extension extension (list (analysis.text name))})))])) + +(def php::apply + Handler + (custom + [(all <>.and <code>.any (<>.some <code>.any)) + (function (_ extension phase archive [abstractionC inputsC]) + (do [! phase.monad] + [abstractionA (analysis/type.with_type ..Function + (phase archive abstractionC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer Any)] + (in {analysis.#Extension extension (list.partial abstractionA inputsA)})))])) + +(def php::pack + Handler + (custom + [(all <>.and <code>.any <code>.any) + (function (_ extension phase archive [formatC dataC]) + (do [! phase.monad] + [formatA (analysis/type.with_type Text + (phase archive formatC)) + dataA (analysis/type.with_type (type_literal (Array (I64 Any))) + (phase archive dataC)) + _ (analysis/type.infer Text)] + (in {analysis.#Extension extension (list formatA dataA)})))])) + +(def .public bundle + Bundle + (<| (bundle.prefix "php") + (|> bundle.empty + (dictionary.composite bundle::array) + (dictionary.composite bundle::object) + + (bundle.install "constant" php::constant) + (bundle.install "apply" php::apply) + (bundle.install "pack" php::pack) + (bundle.install "script universe" (/.nullary .Bit)) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/python.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/python.lux new file mode 100644 index 000000000..1f7316fbd --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/python.lux @@ -0,0 +1,245 @@ +(.require + [library + [lux (.except) + ["[0]" ffi] + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser]] + [data + [collection + ["[0]" array] + ["[0]" dictionary] + ["[0]" list]]] + [meta + ["@" target (.only) + ["_" python]] + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + ["[0]" type (.only) + ["[0]" check]]]]] + [// + ["/" lux (.only custom)] + [// + ["[0]" bundle] + [/// + ["[0]" analysis (.only Analysis Operation Phase Handler Bundle) + ["[1]/[0]" type]] + [/// + ["[0]" phase]]]]]) + +(def array::new + Handler + (custom + [<code>.any + (function (_ extension phase archive lengthC) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [lengthA (analysis/type.expecting Nat + (phase archive lengthC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list lengthA)}))))])) + +(def array::length + Handler + (custom + [<code>.any + (function (_ extension phase archive arrayC) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference Nat)] + (in {analysis.#Extension extension (list arrayA)}))))])) + +(def array::read + Handler + (custom + [(<>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference :read:)] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def array::write + Handler + (custom + [(all <>.and <code>.any <code>.any <code>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + valueA (analysis/type.expecting :write: + (phase archive valueC)) + arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list indexA valueA arrayA)}))))])) + +(def array::delete + Handler + (custom + [(all <>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (analysis/type.expecting Nat + (phase archive indexC)) + arrayA (analysis/type.expecting (type_literal (array.Array' :read: :write:)) + (phase archive arrayC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def None + (for @.python ffi.None + Any)) + +(def Object + (for @.python (type_literal (ffi.Object Any)) + Any)) + +(def Function + (for @.python ffi.Function + Any)) + +(def Dict + (for @.python ffi.Dict + Any)) + +(def object::get + Handler + (custom + [(all <>.and <code>.text <code>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (analysis/type.expecting ..Object + (phase archive objectC)) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list (analysis.text fieldC) + objectA)})))])) + +(def object::do + Handler + (custom + [(all <>.and <code>.text <code>.any (<code>.tuple (<>.some <code>.any))) + (function (_ extension phase archive [methodC objectC inputsC]) + (do [! phase.monad] + [objectA (analysis/type.expecting ..Object + (phase archive objectC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list.partial (analysis.text methodC) + objectA + inputsA)})))])) + +(def bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "none" (/.nullary ..None)) + (bundle.install "none?" (/.unary Any Bit)) + ))) + +(def python::constant + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.inference Any)] + (in {analysis.#Extension extension (list (analysis.text name))})))])) + +(def python::import + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.inference ..Object)] + (in {analysis.#Extension extension (list (analysis.text name))})))])) + +(def python::apply + Handler + (custom + [(all <>.and <code>.any (<code>.tuple (<>.some <code>.any))) + (function (_ extension phase archive [abstractionC inputsC]) + (do [! phase.monad] + [abstractionA (analysis/type.expecting ..Function + (phase archive abstractionC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference Any)] + (in {analysis.#Extension extension (list.partial abstractionA inputsA)})))])) + +(def python::function + Handler + (custom + [(all <>.and <code>.nat <code>.any) + (function (_ extension phase archive [arity abstractionC]) + (do phase.monad + [.let [inputT (type.tuple (list.repeated arity Any))] + abstractionA (analysis/type.expecting (-> inputT Any) + (phase archive abstractionC)) + _ (analysis/type.inference ..Function)] + (in {analysis.#Extension extension (list (analysis.nat arity) + abstractionA)})))])) + +(def python::exec + Handler + (custom + [(all <>.and <code>.any <code>.any) + (function (_ extension phase archive [codeC globalsC]) + (do phase.monad + [codeA (analysis/type.expecting Text + (phase archive codeC)) + globalsA (analysis/type.expecting ..Dict + (phase archive globalsC)) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list codeA globalsA)})))])) + +(def .public bundle + Bundle + (<| (bundle.prefix "python") + (|> bundle.empty + (dictionary.composite bundle::array) + (dictionary.composite bundle::object) + + (bundle.install "constant" python::constant) + (bundle.install "import" python::import) + (bundle.install "apply" python::apply) + (bundle.install "function" python::function) + (bundle.install "exec" python::exec) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/r.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/r.lux new file mode 100644 index 000000000..6dc3f4c09 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/r.lux @@ -0,0 +1,37 @@ +(.require + [library + [lux (.except) + ["[0]" ffi] + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser]] + [data + [collection + ["[0]" array (.only Array)] + ["[0]" dictionary] + ["[0]" list]]] + [meta + ["@" target + ["_" r]] + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + ["[0]" type (.only) + ["[0]" check]]]]] + [// + ["/" lux (.only custom)] + [// + ["[0]" bundle] + [// + ["[0]" analysis + ["[1]/[0]" type]] + [// + ["[0]" analysis (.only Analysis Operation Phase Handler Bundle)] + [/// + ["[0]" phase]]]]]]) + +(def .public bundle + Bundle + (<| (bundle.prefix "r") + (|> bundle.empty + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/ruby.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/ruby.lux new file mode 100644 index 000000000..60c77b4e7 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/ruby.lux @@ -0,0 +1,214 @@ +(.require + [library + [lux (.except) + ["[0]" ffi] + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser]] + [data + [collection + ["[0]" array] + ["[0]" dictionary] + ["[0]" list]]] + [meta + ["@" target (.only) + ["_" ruby]] + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + ["[0]" type (.only) + ["[0]" check]]]]] + [// + ["/" lux (.only custom)] + [// + ["[0]" bundle] + [/// + ["[0]" analysis (.only Analysis Operation Phase Handler Bundle) + ["[1]/[0]" type]] + [/// + ["[0]" phase]]]]]) + +(def array::new + Handler + (custom + [<code>.any + (function (_ extension phase archive lengthC) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [lengthA (<| (analysis/type.expecting Nat) + (phase archive lengthC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list lengthA)}))))])) + +(def array::length + Handler + (custom + [<code>.any + (function (_ extension phase archive arrayC) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [arrayA (<| (analysis/type.expecting (type_literal (array.Array' :read: :write:))) + (phase archive arrayC)) + _ (analysis/type.inference Nat)] + (in {analysis.#Extension extension (list arrayA)}))))])) + +(def array::read + Handler + (custom + [(<>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (<| (analysis/type.expecting Nat) + (phase archive indexC)) + arrayA (<| (analysis/type.expecting (type_literal (array.Array' :read: :write:))) + (phase archive arrayC)) + _ (analysis/type.inference :read:)] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def array::write + Handler + (custom + [(all <>.and <code>.any <code>.any <code>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (<| (analysis/type.expecting Nat) + (phase archive indexC)) + valueA (<| (analysis/type.expecting :write:) + (phase archive valueC)) + arrayA (<| (analysis/type.expecting (type_literal (array.Array' :read: :write:))) + (phase archive arrayC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list indexA valueA arrayA)}))))])) + +(def array::delete + Handler + (custom + [(all <>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@read :read:])) + analysis/type.with_var + (function (_ [@write :write:])) + (do phase.monad + [indexA (<| (analysis/type.expecting Nat) + (phase archive indexC)) + arrayA (<| (analysis/type.expecting (type_literal (array.Array' :read: :write:))) + (phase archive arrayC)) + _ (analysis/type.inference (type_literal (array.Array' :read: :write:)))] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def Nil + (for @.ruby ffi.Nil + Any)) + +(def Object + (for @.ruby (type_literal (ffi.Object Any)) + Any)) + +(def Function + (for @.ruby ffi.Function + Any)) + +(def object::get + Handler + (custom + [(all <>.and <code>.text <code>.any) + (function (_ extension phase archive [fieldC objectC]) + (do phase.monad + [objectA (<| (analysis/type.expecting ..Object) + (phase archive objectC)) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list (analysis.text fieldC) + objectA)})))])) + +(def object::do + Handler + (custom + [(all <>.and <code>.text <code>.any (<code>.tuple (<>.some <code>.any))) + (function (_ extension phase archive [methodC objectC inputsC]) + (do [! phase.monad] + [objectA (<| (analysis/type.expecting ..Object) + (phase archive objectC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference .Any)] + (in {analysis.#Extension extension (list.partial (analysis.text methodC) + objectA + inputsA)})))])) + +(def bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "get" object::get) + (bundle.install "do" object::do) + (bundle.install "nil" (/.nullary ..Nil)) + (bundle.install "nil?" (/.unary Any Bit)) + ))) + +(def ruby::constant + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.inference Any)] + (in {analysis.#Extension extension (list (analysis.text name))})))])) + +(def ruby::apply + Handler + (custom + [(all <>.and <code>.any (<code>.tuple (<>.some <code>.any))) + (function (_ extension phase archive [abstractionC inputsC]) + (do [! phase.monad] + [abstractionA (<| (analysis/type.expecting ..Function) + (phase archive abstractionC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.expecting Any)) inputsC) + _ (analysis/type.inference Any)] + (in {analysis.#Extension extension (list.partial abstractionA inputsA)})))])) + +(def ruby::import + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.inference Bit)] + (in {analysis.#Extension extension (list (analysis.text name))})))])) + +(def .public bundle + Bundle + (<| (bundle.prefix "ruby") + (|> bundle.empty + (dictionary.composite bundle::array) + (dictionary.composite bundle::object) + + (bundle.install "constant" ruby::constant) + (bundle.install "apply" ruby::apply) + (bundle.install "import" ruby::import) + (bundle.install "script universe" (/.nullary .Bit)) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/scheme.lux new file mode 100644 index 000000000..089e5ae69 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/analysis/scheme.lux @@ -0,0 +1,164 @@ +(.require + [library + [lux (.except) + ["[0]" ffi] + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser]] + [data + [collection + ["[0]" array (.only Array)] + ["[0]" dictionary] + ["[0]" list]]] + [meta + ["@" target (.only) + ["_" scheme]] + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + ["[0]" type (.only) + ["[0]" check]]]]] + [// + ["/" lux (.only custom)] + [// + ["[0]" bundle] + [// + ["[0]" analysis + ["[1]/[0]" type]] + [// + ["[0]" analysis (.only Analysis Operation Phase Handler Bundle)] + [/// + ["[0]" phase]]]]]]) + +(def array::new + Handler + (custom + [<code>.any + (function (_ extension phase archive lengthC) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [lengthA (analysis/type.with_type Nat + (phase archive lengthC)) + _ (analysis/type.infer (type_literal (Array :var:)))] + (in {analysis.#Extension extension (list lengthA)}))))])) + +(def array::length + Handler + (custom + [<code>.any + (function (_ extension phase archive arrayC) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [arrayA (analysis/type.with_type (type_literal (Array :var:)) + (phase archive arrayC)) + _ (analysis/type.infer Nat)] + (in {analysis.#Extension extension (list arrayA)}))))])) + +(def array::read + Handler + (custom + [(<>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + arrayA (analysis/type.with_type (type_literal (Array :var:)) + (phase archive arrayC)) + _ (analysis/type.infer :var:)] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def array::write + Handler + (custom + [(all <>.and <code>.any <code>.any <code>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + valueA (analysis/type.with_type :var: + (phase archive valueC)) + arrayA (analysis/type.with_type (type_literal (Array :var:)) + (phase archive arrayC)) + _ (analysis/type.infer (type_literal (Array :var:)))] + (in {analysis.#Extension extension (list indexA valueA arrayA)}))))])) + +(def array::delete + Handler + (custom + [(all <>.and <code>.any <code>.any) + (function (_ extension phase archive [indexC arrayC]) + (<| analysis/type.with_var + (function (_ [@var :var:])) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + arrayA (analysis/type.with_type (type_literal (Array :var:)) + (phase archive arrayC)) + _ (analysis/type.infer (type_literal (Array :var:)))] + (in {analysis.#Extension extension (list indexA arrayA)}))))])) + +(def bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def Nil + (for @.scheme ffi.Nil + Any)) + +(def Function + (for @.scheme ffi.Function + Any)) + +(def bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "nil" (/.nullary ..Nil)) + (bundle.install "nil?" (/.unary Any Bit)) + ))) + +(def scheme::constant + Handler + (custom + [<code>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Any)] + (in {analysis.#Extension extension (list (analysis.text name))})))])) + +(def scheme::apply + Handler + (custom + [(all <>.and <code>.any (<>.some <code>.any)) + (function (_ extension phase archive [abstractionC inputsC]) + (do [! phase.monad] + [abstractionA (analysis/type.with_type ..Function + (phase archive abstractionC)) + inputsA (monad.each ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer Any)] + (in {analysis.#Extension extension (list.partial abstractionA inputsA)})))])) + +(def .public bundle + Bundle + (<| (bundle.prefix "scheme") + (|> bundle.empty + (dictionary.composite bundle::array) + (dictionary.composite bundle::object) + + (bundle.install "constant" scheme::constant) + (bundle.install "apply" scheme::apply) + (bundle.install "script universe" (/.nullary .Bit)) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/bundle.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/bundle.lux new file mode 100644 index 000000000..1436c1002 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/bundle.lux @@ -0,0 +1,29 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" dictionary (.only Dictionary)]]]]] + [// (.only Handler Bundle)]) + +(def .public empty + Bundle + (dictionary.empty text.hash)) + +(def .public (install name anonymous) + (All (_ s i o) + (-> Text (Handler s i o) + (-> (Bundle s i o) (Bundle s i o)))) + (dictionary.has name anonymous)) + +(def .public (prefix prefix) + (All (_ s i o) + (-> Text (-> (Bundle s i o) (Bundle s i o)))) + (|>> dictionary.entries + (list#each (function (_ [key val]) [(format prefix " " key) val])) + (dictionary.of_list text.hash))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/jvm.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/jvm.lux new file mode 100644 index 000000000..9585f0521 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/jvm.lux @@ -0,0 +1,984 @@ +(.require + [library + [lux (.except Type Definition Primitive) + ["[0]" ffi (.only import)] + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser (.use "[1]#[0]" monad)] + ["[0]" pipe] + ["[0]" try (.only Try) (.use "[1]#[0]" functor)] + ["[0]" exception]] + [data + ["[0]" product] + [binary (.only Binary) + ["[0]" \\format]] + ["[0]" text + ["%" \\format (.only format)] + ["<[1]>" \\parser]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" dictionary] + ["[0]" sequence] + ["[0]" set (.only Set)]]] + [math + [number + ["n" nat] + ["[0]" i32]]] + [meta + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + [macro + ["^" pattern] + ["[0]" template]] + [type + ["[0]" check (.only Check)]] + [target + [jvm + ["_" bytecode (.only Bytecode) (.use "[1]#[0]" monad)] + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + ["[0]" attribute] + ["[0]" field] + ["[0]" version] + ["[0]" method (.only Method)] + ["[0]" class] + ["[0]" constant (.only) + ["[0]" pool (.only Resource)]] + [encoding + ["[0]" name (.only External)]] + ["[0]" type (.only Type Constraint Argument Typed) + [category (.only Void Value Return Primitive Object Class Array Var Parameter)] + ["[0]T" lux (.only Mapping)] + ["[0]" signature] + ["[0]" reflection] + ["[0]" descriptor (.only Descriptor)] + ["[0]" parser]]]] + [compiler + ["[0]" phase] + [reference + [variable (.only Register)]] + [meta + [archive (.only Archive) + ["[0]" artifact] + ["[0]" unit]] + ["[0]" cache + [dependency + ["[1]" artifact]]]] + [language + [lux + ["[0]" generation] + ["[0]" declaration (.only Handler Bundle)] + ["[0]" analysis (.only Analysis) + ["[0]A" type] + ["[0]A" scope]] + ["[0]" synthesis (.only Synthesis) + ["<[1]>" \\parser]] + [phase + [generation + [jvm + ["[0]" runtime (.only Anchor Definition Extender)] + ["[0]" value]]] + ["[0]" extension (.only) + ["[0]" bundle] + [analysis + ["[0]" jvm]] + [generation + [jvm + ["[0]" host]]] + [declaration + ["/" lux]]]]]]]]]]) + +(type Operation + (declaration.Operation Anchor (Bytecode Any) Definition)) + +(def signature (|>> type.signature signature.signature)) +(def reflection (|>> type.reflection reflection.reflection)) + +(type Declaration + [Text (List (Type Var))]) + +(def declaration + (Parser Declaration) + (<code>.form (<>.and <code>.text (<>.some jvm.var)))) + +(def method_privacy + (-> ffi.Privacy (Modifier method.Method)) + (|>> (pipe.case + {ffi.#PublicP} method.public + {ffi.#PrivateP} method.private + {ffi.#ProtectedP} method.protected + {ffi.#DefaultP} modifier.empty))) + +(def visibility' + (<text>.Parser (Modifier field.Field)) + (`` (all <>.either + (,, (with_template [<label> <modifier>] + [(<>.after (<text>.this <label>) (<>#in <modifier>))] + + ["public" field.public] + ["private" field.private] + ["protected" field.protected] + ["default" modifier.empty]))))) + +(def visibility + (Parser (Modifier field.Field)) + (<text>.then ..visibility' <code>.text)) + +(def inheritance + (Parser (Modifier class.Class)) + (`` (all <>.either + (,, (with_template [<label> <modifier>] + [(<>.after (<code>.this_text <label>) (<>#in <modifier>))] + + ["final" class.final] + ["abstract" class.abstract] + ["default" modifier.empty]))))) + +(def state + (Parser (Modifier field.Field)) + (`` (all <>.either + (,, (with_template [<label> <modifier>] + [(<>.after (<code>.this_text <label>) (<>#in <modifier>))] + + ["volatile" field.volatile] + ["final" field.final] + ["default" modifier.empty]))))) + +(type Annotation Any) + +(def annotation + (Parser Annotation) + <code>.any) + +(def field_type + (Parser (Type Value)) + (<text>.then parser.value <code>.text)) + +(type Constant + [Text (List Annotation) (Type Value) Code]) + +(def constant + (Parser Constant) + (<| <code>.form + (<>.after (<code>.this_text "constant")) + (all <>.and + <code>.text + (<code>.tuple (<>.some ..annotation)) + ..field_type + <code>.any + ))) + +(type Variable + [Text (Modifier field.Field) (Modifier field.Field) Bit (List Annotation) (Type Value)]) + +(def variable + (Parser Variable) + (<| <code>.form + (<>.after (<code>.this_text "variable")) + (all <>.and + <code>.text + ..visibility + ..state + (<>.parses? (<code>.this_text jvm.static_tag)) + (<code>.tuple (<>.some ..annotation)) + ..field_type + ))) + +(type Field + (Variant + {#Constant Constant} + {#Variable Variable})) + +(def field + (Parser Field) + (all <>.or + ..constant + ..variable + )) + +(type (Method_Definition a) + (Variant + {#Constructor (jvm.Constructor a)} + {#Virtual_Method (jvm.Virtual_Method a)} + {#Static_Method (jvm.Static_Method a)} + {#Overriden_Method (jvm.Overriden_Method a)} + {#Abstract_Method (jvm.Abstract_Method a)})) + +(def method + (Parser (Method_Definition Code)) + (all <>.or + jvm.constructor_definition + jvm.virtual_method_definition + jvm.static_method_definition + jvm.overriden_method_definition + jvm.abstract_method_definition + )) + +(def $Object + (Type Class) + (type.class "java.lang.Object" (list))) + +(def constant::modifier + (Modifier field.Field) + (all modifier#composite + field.public + field.static + field.final)) + +(def (field_definition field) + (-> Field (Resource field.Field)) + (case field + ... TODO: Handle annotations. + {#Constant [name annotations type value]} + (case value + (^.with_template [<tag> <type> <constant>] + [[_ {<tag> value}] + (do pool.monad + [constant (`` (|> value (,, (template.spliced <constant>)))) + attribute (attribute.constant constant)] + (field.field ..constant::modifier name #1 <type> (sequence.sequence attribute)))]) + ([.#Bit type.boolean [(pipe.case #0 +0 #1 +1) .i64 i32.i32 constant.integer pool.integer]] + [.#Int type.byte [.i64 i32.i32 constant.integer pool.integer]] + [.#Int type.short [.i64 i32.i32 constant.integer pool.integer]] + [.#Int type.int [.i64 i32.i32 constant.integer pool.integer]] + [.#Int type.long [constant.long pool.long]] + [.#Frac type.float [ffi.double_to_float constant.float pool.float]] + [.#Frac type.double [constant.double pool.double]] + [.#Nat type.char [.i64 i32.i32 constant.integer pool.integer]] + [.#Text (type.class "java.lang.String" (list)) [pool.string]] + ) + + ... TODO: Tighten this pattern-matching so this catch-all clause isn't necessary. + _ + (undefined)) + + ... TODO: Handle annotations. + {#Variable [name visibility state static? annotations type]} + (field.field (all modifier#composite + (if static? + field.static + modifier.empty) + visibility + state) + name #1 type sequence.empty))) + +(def annotation_parameter_synthesis + (<synthesis>.Parser (jvm.Annotation_Parameter Synthesis)) + (<synthesis>.tuple (<>.and <synthesis>.text <synthesis>.any))) + +(def annotation_synthesis + (<synthesis>.Parser (jvm.Annotation Synthesis)) + (<synthesis>.tuple (<>.and <synthesis>.text (<>.some ..annotation_parameter_synthesis)))) + +(with_template [<name> <type> <text>] + [(def <name> + (<synthesis>.Parser (Type <type>)) + (<text>.then <text> <synthesis>.text))] + + [value_type_synthesis Value parser.value] + [class_type_synthesis Class parser.class] + [var_type_synthesis Var parser.var] + [return_type_synthesis Return parser.return] + ) + +(def argument_synthesis + (<synthesis>.Parser Argument) + (<synthesis>.tuple (<>.and <synthesis>.text ..value_type_synthesis))) + +(def input_synthesis + (<synthesis>.Parser (Typed Synthesis)) + (<synthesis>.tuple (<>.and ..value_type_synthesis <synthesis>.any))) + +(def (method_body arity) + (-> Nat (<synthesis>.Parser Synthesis)) + (<| (<>#each (function (_ [env offset inits it]) it)) + (<synthesis>.function 1) + (<synthesis>.loop (<>.exactly 0 <synthesis>.any)) + <synthesis>.tuple + (all <>.either + (<| (<>.after (<synthesis>.this_text "")) + (<>#each (host.hidden_method_body arity)) + <synthesis>.any) + <synthesis>.any))) + +(def constructor_synthesis + (<synthesis>.Parser (jvm.Constructor Synthesis)) + (<| <synthesis>.tuple + (<>.after (<synthesis>.this_text jvm.constructor_tag)) + (all <>.and + (<text>.then jvm.visibility' <synthesis>.text) + <synthesis>.bit + (<synthesis>.tuple (<>.some ..annotation_synthesis)) + (<synthesis>.tuple (<>.some ..var_type_synthesis)) + (<synthesis>.tuple (<>.some ..class_type_synthesis)) + <synthesis>.text + (do <>.monad + [args (<synthesis>.tuple (<>.some ..argument_synthesis))] + (all <>.and + (in args) + (<synthesis>.tuple (<>.some ..input_synthesis)) + (..method_body (list.size args)))) + ))) + +(def overriden_method_synthesis + (<synthesis>.Parser (jvm.Overriden_Method Synthesis)) + (<| <synthesis>.tuple + (<>.after (<synthesis>.this_text jvm.overriden_tag)) + (all <>.and + ..class_type_synthesis + <synthesis>.text + <synthesis>.bit + (<synthesis>.tuple (<>.some ..annotation_synthesis)) + (<synthesis>.tuple (<>.some ..var_type_synthesis)) + <synthesis>.text + (do [! <>.monad] + [args (<synthesis>.tuple (<>.some ..argument_synthesis))] + (all <>.and + (in args) + ..return_type_synthesis + (<synthesis>.tuple (<>.some ..class_type_synthesis)) + (..method_body (list.size args)))) + ))) + +(def virtual_method_synthesis + (<synthesis>.Parser (jvm.Virtual_Method Synthesis)) + (<| <synthesis>.tuple + (<>.after (<synthesis>.this_text jvm.virtual_tag)) + (all <>.and + <synthesis>.text + (<text>.then jvm.visibility' <synthesis>.text) + <synthesis>.bit + <synthesis>.bit + (<synthesis>.tuple (<>.some ..annotation_synthesis)) + (<synthesis>.tuple (<>.some ..var_type_synthesis)) + <synthesis>.text + (do <>.monad + [args (<synthesis>.tuple (<>.some ..argument_synthesis))] + (all <>.and + (in args) + ..return_type_synthesis + (<synthesis>.tuple (<>.some ..class_type_synthesis)) + (..method_body (list.size args)))) + ))) + +(def static_method_synthesis + (<synthesis>.Parser (jvm.Static_Method Synthesis)) + (<| <synthesis>.tuple + (<>.after (<synthesis>.this_text jvm.static_tag)) + (all <>.and + <synthesis>.text + (<text>.then jvm.visibility' <synthesis>.text) + <synthesis>.bit + (<synthesis>.tuple (<>.some ..annotation_synthesis)) + (<synthesis>.tuple (<>.some ..var_type_synthesis)) + (do <>.monad + [args (<synthesis>.tuple (<>.some ..argument_synthesis))] + (all <>.and + (in args) + ..return_type_synthesis + (<synthesis>.tuple (<>.some ..class_type_synthesis)) + (..method_body (list.size args)))) + ))) + +(def abstract_method_synthesis + (<synthesis>.Parser (jvm.Abstract_Method Synthesis)) + (<| <synthesis>.tuple + (<>.after (<synthesis>.this_text jvm.abstract_tag)) + (all <>.and + <synthesis>.text + (<text>.then jvm.visibility' <synthesis>.text) + (<synthesis>.tuple (<>.some ..annotation_synthesis)) + (<synthesis>.tuple (<>.some ..var_type_synthesis)) + (<synthesis>.tuple (<>.some ..argument_synthesis)) + ..return_type_synthesis + (<synthesis>.tuple (<>.some ..class_type_synthesis)) + ))) + +(def method_synthesis + (<synthesis>.Parser (Method_Definition Synthesis)) + (all <>.or + ..constructor_synthesis + ..virtual_method_synthesis + ..static_method_synthesis + ..overriden_method_synthesis + ..abstract_method_synthesis + )) + +(def composite + (-> (List (Bytecode Any)) (Bytecode Any)) + (|>> list.reversed + (list#mix _.composite (_#in [])))) + +(def constructor_name + "<init>") + +(def (method_argument lux_register argumentT jvm_register) + (-> Register (Type Value) Register [Register (Bytecode Any)]) + (case (type.primitive? argumentT) + {.#Left argumentT} + [(n.+ 1 jvm_register) + (if (n.= lux_register jvm_register) + (_#in []) + (all _.composite + (_.aload jvm_register) + (_.astore lux_register)))] + + {.#Right argumentT} + (template.let [(wrap_primitive <shift> <load> <type>) + [[(n.+ <shift> jvm_register) + (all _.composite + (<load> jvm_register) + (value.wrap <type>) + (_.astore lux_register))]]] + (`` (cond (,, (with_template [<shift> <load> <type>] + [(at type.equivalence = <type> argumentT) + (wrap_primitive <shift> <load> <type>)] + + [1 _.iload type.boolean] + [1 _.iload type.byte] + [1 _.iload type.short] + [1 _.iload type.int] + [1 _.iload type.char] + [1 _.fload type.float] + [2 _.lload type.long])) + + ... (at type.equivalence = type.double argumentT) + (wrap_primitive 2 _.dload type.double)))))) + +(def .public (method_arguments offset types) + (-> Nat (List (Type Value)) (Bytecode Any)) + (|> types + list.enumeration + (list#mix (function (_ [lux_register type] [jvm_register before]) + (let [[jvm_register' after] (method_argument (n.+ offset lux_register) type jvm_register)] + [jvm_register' (all _.composite before after)])) + (is [Register (Bytecode Any)] [offset (_#in [])])) + product.right)) + +(def (constructor_method_generation archive super_class method) + (-> Archive (Type Class) (jvm.Constructor Synthesis) (Operation (Resource Method))) + (<| (let [[privacy strict_floating_point? annotations method_tvars exceptions + self arguments constructor_argumentsS + bodyS] method + bodyS (case (list.size arguments) + 0 (host.without_fake_parameter bodyS) + _ bodyS)]) + (do [! phase.monad] + [generate declaration.generation]) + declaration.lifted_generation + (do ! + [constructor_argumentsG (monad.each ! (|>> product.right (generate archive)) + constructor_argumentsS) + bodyG (generate archive bodyS) + .let [[super_name super_vars] (parser.read_class super_class) + super_constructorT (type.method [(list) + (list#each product.left constructor_argumentsS) + type.void + (list)]) + argumentsT (list#each product.right arguments)]] + (in (method.method (all modifier#composite + (..method_privacy privacy) + (if strict_floating_point? + method.strict + modifier.empty)) + ..constructor_name + #1 (type.method [method_tvars argumentsT type.void exceptions]) + (list) + {.#Some (all _.composite + (_.aload 0) + (..composite constructor_argumentsG) + (_.invokespecial super_class ..constructor_name super_constructorT) + (method_arguments 1 argumentsT) + bodyG + _.return + )}))))) + +(def (method_return returnT) + (-> (Type Return) (Bytecode Any)) + (case (type.void? returnT) + {.#Right returnT} + _.return + + {.#Left returnT} + (case (type.primitive? returnT) + {.#Left returnT} + (case (type.class? returnT) + {.#Some class_name} + (all _.composite + (_.checkcast returnT) + _.areturn) + + {.#None} + _.areturn) + + {.#Right returnT} + (template.let [(unwrap_primitive <return> <type>) + [(all _.composite + (value.unwrap <type>) + <return>)]] + (`` (cond (,, (with_template [<return> <type>] + [(at type.equivalence = <type> returnT) + (unwrap_primitive <return> <type>)] + + [_.ireturn type.boolean] + [_.ireturn type.byte] + [_.ireturn type.short] + [_.ireturn type.int] + [_.ireturn type.char] + [_.freturn type.float] + [_.lreturn type.long])) + + ... (at type.equivalence = type.double returnT) + (unwrap_primitive _.dreturn type.double))))))) + +(def (overriden_method_generation archive method) + (-> Archive (jvm.Overriden_Method Synthesis) (Operation (Resource Method))) + (do [! phase.monad] + [.let [[super method_name strict_floating_point? annotations + method_tvars self arguments returnJ exceptionsJ + bodyS] method + bodyS (case (list.size arguments) + 0 (host.without_fake_parameter bodyS) + _ bodyS)] + generate declaration.generation] + (declaration.lifted_generation + (do ! + [bodyG (generate archive bodyS) + .let [argumentsT (list#each product.right arguments)]] + (in (method.method (all modifier#composite + method.public + (if strict_floating_point? + method.strict + modifier.empty)) + method_name + #1 (type.method [method_tvars argumentsT returnJ exceptionsJ]) + (list) + {.#Some (all _.composite + (method_arguments 1 argumentsT) + bodyG + (method_return returnJ))})))))) + +(def (virtual_method_generation archive method) + (-> Archive (jvm.Virtual_Method Synthesis) (Operation (Resource Method))) + (do [! phase.monad] + [.let [[method_name privacy final? strict_floating_point? annotations method_tvars + self arguments returnJ exceptionsJ + bodyS] method + bodyS (case (list.size arguments) + 0 (host.without_fake_parameter bodyS) + _ bodyS)] + generate declaration.generation] + (declaration.lifted_generation + (do ! + [bodyG (generate archive bodyS) + .let [argumentsT (list#each product.right arguments)]] + (in (method.method (all modifier#composite + (..method_privacy privacy) + (if strict_floating_point? + method.strict + modifier.empty) + (if final? + method.final + modifier.empty)) + method_name + #1 (type.method [method_tvars argumentsT returnJ exceptionsJ]) + (list) + {.#Some (all _.composite + (method_arguments 1 argumentsT) + bodyG + (method_return returnJ))})))))) + +(def (static_method_generation archive method) + (-> Archive (jvm.Static_Method Synthesis) (Operation (Resource Method))) + (do [! phase.monad] + [.let [[method_name privacy strict_floating_point? annotations method_tvars + arguments returnJ exceptionsJ + bodyS] method] + generate declaration.generation] + (declaration.lifted_generation + (do ! + [bodyG (generate archive bodyS) + .let [argumentsT (list#each product.right arguments)]] + (in (method.method (all modifier#composite + (..method_privacy privacy) + method.static + (if strict_floating_point? + method.strict + modifier.empty)) + method_name + #1 (type.method [method_tvars argumentsT returnJ exceptionsJ]) + (list) + {.#Some (all _.composite + (method_arguments 0 argumentsT) + bodyG + (method_return returnJ))})))))) + +(def (abstract_method_generation method) + (-> (jvm.Abstract_Method Synthesis) (Resource Method)) + (let [[name privacy annotations variables + arguments return exceptions] method] + (method.method (all modifier#composite + (..method_privacy privacy) + method.abstract) + name + #1 (type.method [variables (list#each product.right arguments) return exceptions]) + (list) + {.#None}))) + +(def (method_generation archive super_class method) + (-> Archive (Type Class) (Method_Definition Synthesis) (Operation (Resource Method))) + (case method + {#Constructor method} + (..constructor_method_generation archive super_class method) + + {#Overriden_Method method} + (..overriden_method_generation archive method) + + {#Virtual_Method method} + (..virtual_method_generation archive method) + + {#Static_Method method} + (..static_method_generation archive method) + + {#Abstract_Method method} + (at phase.monad in (..abstract_method_generation method)))) + +(def (method_definition archive super interfaces [mapping selfT] [analyse synthesize generate]) + (-> Archive + (Type Class) + (List (Type Class)) + [Mapping .Type] + [analysis.Phase + synthesis.Phase + (generation.Phase Anchor (Bytecode Any) Definition)] + (-> (Method_Definition Code) (Operation [(Set unit.ID) (Resource Method)]))) + (function (_ methodC) + (do phase.monad + [methodA (is (Operation Analysis) + (declaration.lifted_analysis + (case methodC + {#Constructor method} + (jvm.analyse_constructor_method analyse archive selfT mapping method) + + {#Virtual_Method method} + (jvm.analyse_virtual_method analyse archive selfT mapping method) + + {#Static_Method method} + (jvm.analyse_static_method analyse archive mapping method) + + {#Overriden_Method method} + (jvm.analyse_overriden_method analyse archive selfT mapping (list.partial super interfaces) method) + + {#Abstract_Method method} + (jvm.analyse_abstract_method analyse archive method)))) + methodS (is (Operation Synthesis) + (declaration.lifted_synthesis + (synthesize archive methodA))) + dependencies (declaration.lifted_generation + (cache.dependencies archive methodS)) + methodS' (|> methodS + list + (<synthesis>.result ..method_synthesis) + phase.lifted) + methodG (method_generation archive super methodS')] + (in [dependencies methodG])))) + +(def class_name + (|>> parser.read_class product.left name.internal)) + +(def (mock_class [name parameters] super interfaces fields methods modifier) + (-> Declaration (Type Class) (List (Type Class)) + (List (Resource field.Field)) (List (Resource method.Method)) (Modifier class.Class) + (Try [External Binary])) + (let [signature (signature.inheritance (list#each type.signature parameters) + (type.signature super) + (list#each type.signature interfaces))] + (try#each (|>> (\\format.result class.format) + [name]) + (class.class version.v6_0 + (all modifier#composite + class.public + modifier) + (name.internal name) + {.#Some signature} + (..class_name super) + (list#each ..class_name interfaces) + fields + methods + sequence.empty)))) + +(def (mock_value valueT) + (-> (Type Value) (Bytecode Any)) + (case (type.primitive? valueT) + {.#Left classT} + _.aconst_null + + {.#Right primitiveT} + (cond (at type.equivalence = type.long primitiveT) + _.lconst_0 + + (at type.equivalence = type.float primitiveT) + _.fconst_0 + + (at type.equivalence = type.double primitiveT) + _.dconst_0 + + ... type.boolean type.byte type.short type.int type.char + _.iconst_0))) + +(def (mock_return returnT) + (-> (Type Return) (Bytecode Any)) + (case (type.void? returnT) + {.#Right returnT} + _.return + + {.#Left valueT} + (all _.composite + (mock_value valueT) + (case (type.primitive? valueT) + {.#Left classT} + _.areturn + + {.#Right primitiveT} + (cond (at type.equivalence = type.long primitiveT) + _.lreturn + + (at type.equivalence = type.float primitiveT) + _.freturn + + (at type.equivalence = type.double primitiveT) + _.dreturn + + ... type.boolean type.byte type.short type.int type.char + _.ireturn))))) + +(def (mock_method super method) + (-> (Type Class) (Method_Definition Code) (Resource method.Method)) + (case method + {#Constructor [privacy strict_floating_point? annotations variables exceptions + self arguments constructor_arguments + body]} + (method.method (all modifier#composite + (..method_privacy privacy) + (if strict_floating_point? + method.strict + modifier.empty)) + ..constructor_name + #1 (type.method [variables (list#each product.right arguments) type.void exceptions]) + (list) + {.#Some (all _.composite + (_.aload 0) + (|> constructor_arguments + (list#each (|>> product.left ..mock_value)) + (monad.all _.monad)) + (|> (type.method [(list) (list#each product.left constructor_arguments) type.void (list)]) + (_.invokespecial super ..constructor_name)) + _.return + )}) + + {#Overriden_Method [super name strict_floating_point? annotations variables + self arguments return exceptions + body]} + (method.method (all modifier#composite + method.public + (if strict_floating_point? + method.strict + modifier.empty)) + name + #1 (type.method [variables (list#each product.right arguments) return exceptions]) + (list) + {.#Some (..mock_return return)}) + + {#Virtual_Method [name privacy final? strict_floating_point? annotations variables + self arguments return exceptions + body]} + (method.method (all modifier#composite + (..method_privacy privacy) + (if strict_floating_point? + method.strict + modifier.empty) + (if final? + method.final + modifier.empty)) + name + #1 (type.method [variables (list#each product.right arguments) return exceptions]) + (list) + {.#Some (..mock_return return)}) + + {#Static_Method [name privacy strict_floating_point? annotations + variables arguments return exceptions + body]} + (method.method (all modifier#composite + method.static + (..method_privacy privacy) + (if strict_floating_point? + method.strict + modifier.empty)) + name + #1 (type.method [variables (list#each product.right arguments) return exceptions]) + (list) + {.#Some (..mock_return return)}) + + {#Abstract_Method [name privacy annotations + variables arguments return exceptions]} + (method.method (all modifier#composite + method.abstract + (..method_privacy privacy)) + name + #1 (type.method [variables (list#each product.right arguments) return exceptions]) + (list) + {.#None}) + )) + +(def (mock declaration super interfaces inheritance fields methods) + (-> Declaration + (Type Class) (List (Type Class)) + (Modifier class.Class) (List ..Field) (List (Method_Definition Code)) + (Try [External Binary])) + (mock_class declaration super interfaces + (list#each ..field_definition fields) + (list#each (..mock_method super) methods) + inheritance)) + +(with_template [<name> <type> <parser>] + [(def <name> + (Parser <type>) + (do [! <>.monad] + [raw <code>.text] + (<>.lifted (<text>.result <parser> raw))))] + + [class_declaration [External (List (Type Var))] parser.declaration'] + ) + +(def (save_class! name bytecode dependencies) + (-> Text Binary (Set unit.ID) (Operation Any)) + (declaration.lifted_generation + (do [! phase.monad] + [.let [artifact [name bytecode]] + artifact_id (generation.learn_custom name dependencies) + _ (generation.execute! artifact) + _ (generation.save! artifact_id {.#Some name} artifact) + _ (generation.log! (format "JVM Class " name))] + (in [])))) + +(def jvm::class + (Handler Anchor (Bytecode Any) Definition) + (/.custom + [(all <>.and + ..class_declaration + jvm.class + (<code>.tuple (<>.some jvm.class)) + ..inheritance + (<code>.tuple (<>.some ..annotation)) + (<code>.tuple (<>.some ..field)) + (<code>.tuple (<>.some ..method))) + (function (_ extension phase archive + [class_declaration + super + interfaces + inheritance + ... TODO: Handle annotations. + annotations + fields + methods]) + (do [! phase.monad] + [.let [[name parameters] class_declaration + type_declaration (signature.inheritance (list#each type.signature parameters) + (type.signature super) + (list#each type.signature interfaces))] + mock (<| phase.lifted + (..mock class_declaration + super + interfaces + inheritance + fields + methods)) + ... Necessary for reflection to work properly during analysis. + _ (declaration.lifted_generation + (generation.execute! mock)) + parameters (declaration.lifted_analysis + (typeA.check (jvm.parameter_types parameters))) + .let [mapping (list#mix (function (_ [parameterJ parameterT] mapping) + (dictionary.has (parser.name parameterJ) parameterT mapping)) + luxT.fresh + parameters) + selfT {.#Primitive name (list#each product.right parameters)}] + state (extension.lifted phase.state) + methods (monad.each ! (..method_definition archive super interfaces [mapping selfT] + [(the [declaration.#analysis declaration.#phase] state) + (the [declaration.#synthesis declaration.#phase] state) + (the [declaration.#generation declaration.#phase] state)]) + methods) + .let [all_dependencies (cache.all (list#each product.left methods))] + bytecode (<| (at ! each (\\format.result class.format)) + phase.lifted + (class.class version.v6_0 + (all modifier#composite + class.public + inheritance) + (name.internal name) + {.#Some type_declaration} + (..class_name super) + (list#each ..class_name interfaces) + (list#each ..field_definition fields) + (list#each product.right methods) + sequence.empty)) + _ (..save_class! name bytecode all_dependencies)] + (in declaration.no_requirements)))])) + +(def (method_declaration (open "/[0]")) + (-> (jvm.Method_Declaration Code) (Resource Method)) + (let [type (type.method [/#type_variables /#arguments /#return /#exceptions])] + (method.method (all modifier#composite + method.public + method.abstract) + /#name + #1 type + (list) + {.#None}))) + +(def jvm::class::interface + (Handler Anchor (Bytecode Any) Definition) + (/.custom + [(all <>.and + ..class_declaration + (<code>.tuple (<>.some jvm.class)) + ... TODO: Handle annotations. + (<code>.tuple (<>.some ..annotation)) + (<>.some jvm.method_declaration)) + (function (_ extension_name phase archive [[name parameters] supers annotations method_declarations]) + (declaration.lifted_generation + (do [! phase.monad] + [bytecode (<| (at ! each (\\format.result class.format)) + phase.lifted + (class.class version.v6_0 + (all modifier#composite + class.public + class.abstract + class.interface) + (name.internal name) + {.#Some (signature.inheritance (list#each type.signature parameters) + (type.signature $Object) + (list#each type.signature supers))} + (name.internal "java.lang.Object") + (list#each ..class_name supers) + (list) + (list#each ..method_declaration method_declarations) + sequence.empty)) + artifact_id (generation.learn_custom name unit.none) + .let [artifact [name bytecode]] + _ (generation.execute! artifact) + _ (generation.save! artifact_id {.#Some name} artifact) + _ (generation.log! (format "JVM Interface " (%.text name)))] + (in declaration.no_requirements))))])) + +(import java/lang/ClassLoader + "[1]::[0]") + +(def .public (bundle class_loader extender) + (-> java/lang/ClassLoader Extender (Bundle Anchor (Bytecode Any) Definition)) + (<| (bundle.prefix "jvm") + (|> bundle.empty + (dictionary.has "class" jvm::class) + (dictionary.has "class interface" ..jvm::class::interface) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/lux.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/lux.lux new file mode 100644 index 000000000..0262cf5eb --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/lux.lux @@ -0,0 +1,570 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + [io (.only IO)] + ["<>" parser] + ["[0]" maybe (.use "[1]#[0]" functor)] + ["[0]" try] + ["[0]" exception (.only exception)]] + [data + ["[0]" binary] + ["[0]" product] + ["[0]" text + ["%" \\format (.only format)]] + [collection + ["[0]" dictionary] + ["[0]" array] + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set (.only Set)]]] + [math + [number + ["n" nat]]] + ["[0]" meta (.only) + ["@" target] + ["[0]" code + ["<[1]>" \\parser (.only Parser)]] + [macro + ["^" pattern]] + ["[0]" type (.only sharing) (.use "[1]#[0]" equivalence) + ["[0]" check]]]]] + ["[0]" /// (.only Extender) + ["[1][0]" bundle] + ["[1][0]" analysis] + ["/[1]" // + ["/[1]" // + ["[1][0]" analysis (.only) + [macro (.only Expander)] + ["[1]/[0]" evaluation] + ["[0]A" type] + ["[0]A" module] + ["[0]" scope]] + ["[1][0]" synthesis (.only Synthesis)] + ["[1][0]" generation] + ["[1][0]" declaration (.only Import Requirements Phase Operation Handler Bundle)] + ["[1][0]" program (.only Program)] + [/// + ["[0]" phase] + [meta + ["[0]" archive (.only Archive) + ["[0]" artifact] + ["[0]" module] + ["[0]" unit]] + ["[0]" cache + [dependency + ["[1]/[0]" artifact]]]]]]]]) + +(def .public (custom [syntax handler]) + (All (_ anchor expression declaration s) + (-> [(Parser s) + (-> Text + (Phase anchor expression declaration) + Archive + s + (Operation anchor expression declaration Requirements))] + (Handler anchor expression declaration))) + (function (_ extension_name phase archive inputs) + (case (<code>.result syntax inputs) + {try.#Success inputs} + (handler extension_name phase archive inputs) + + {try.#Failure error} + (phase.except ///.invalid_syntax [extension_name %.code inputs])))) + +(def (context [@module @artifact]) + (-> unit.ID unit.ID) + ... TODO: Find a better way that doesn't rely on clever tricks. + [@module (n.- (++ @artifact) 0)]) + +... TODO: Inline "evaluate!'" into "evaluate!" ASAP +(def (evaluate!' archive generate code//type codeS) + (All (_ anchor expression declaration) + (-> Archive + (/////generation.Phase anchor expression declaration) + Type + Synthesis + (Operation anchor expression declaration [Type expression Any]))) + (/////declaration.lifted_generation + (do phase.monad + [module /////generation.module + id /////generation.next + codeG (generate archive codeS) + @module (/////generation.module_id module archive) + codeV (/////generation.evaluate! (..context [@module id]) [{.#None} codeG])] + (in [code//type codeG codeV])))) + +(def .public (evaluate! archive type codeC) + (All (_ anchor expression declaration) + (-> Archive Type Code (Operation anchor expression declaration [Type expression Any]))) + (do phase.monad + [state (///.lifted phase.state) + .let [analyse (the [/////declaration.#analysis /////declaration.#phase] state) + synthesize (the [/////declaration.#synthesis /////declaration.#phase] state) + generate (the [/////declaration.#generation /////declaration.#phase] state)] + [_ codeA] (<| /////declaration.lifted_analysis + scope.with + typeA.fresh + (typeA.expecting type) + (analyse archive codeC)) + codeS (/////declaration.lifted_synthesis + (synthesize archive codeA))] + (evaluate!' archive generate type codeS))) + +... TODO: Inline "definition'" into "definition" ASAP +(def (definition' archive generate [module name] code//type codeS) + (All (_ anchor expression declaration) + (-> Archive + (/////generation.Phase anchor expression declaration) + Symbol + Type + Synthesis + (Operation anchor expression declaration [Type expression Any]))) + (/////declaration.lifted_generation + (do phase.monad + [dependencies (cache/artifact.dependencies archive codeS) + [interim_artifacts codeG] (/////generation.with_interim_artifacts archive + (generate archive codeS)) + .let [@abstraction (case codeS + (/////synthesis.function/abstraction [env arity body]) + (|> interim_artifacts + list.last + (maybe#each (|>> [arity]))) + + _ + {.#None})] + @module (phase.lifted (archive.id module archive)) + @self (/////generation.learn [name @abstraction] false (list#mix set.has dependencies interim_artifacts)) + [target_name value declaration] (/////generation.define! [@module @self] {.#None} [(maybe#each product.right @abstraction) codeG]) + _ (/////generation.save! @self {.#None} declaration)] + (in [code//type codeG value])))) + +(def (definition archive name expected codeC) + (All (_ anchor expression declaration) + (-> Archive Symbol (Maybe Type) Code + (Operation anchor expression declaration [Type expression Any]))) + (do [! phase.monad] + [state (///.lifted phase.state) + .let [analyse (the [/////declaration.#analysis /////declaration.#phase] state) + synthesize (the [/////declaration.#synthesis /////declaration.#phase] state) + generate (the [/////declaration.#generation /////declaration.#phase] state)] + [_ code//type codeA] (/////declaration.lifted_analysis + (scope.with + (typeA.fresh + (case expected + {.#None} + (do ! + [[code//type codeA] (typeA.inferring + (analyse archive codeC)) + code//type (typeA.check (check.clean (list) code//type))] + (in [code//type codeA])) + + {.#Some expected} + (do ! + [codeA (<| (typeA.expecting expected) + (analyse archive codeC))] + (in [expected codeA])))))) + codeS (/////declaration.lifted_synthesis + (synthesize archive codeA))] + (definition' archive generate name code//type codeS))) + +(with_template [<full> <partial> <learn>] + [... TODO: Inline "<partial>" into "<full>" ASAP + (def (<partial> archive generate extension codeT codeS) + (All (_ anchor expression declaration) + (-> Archive + (/////generation.Phase anchor expression declaration) + Text + Type + Synthesis + (Operation anchor expression declaration [expression Any]))) + (do phase.monad + [current_module (/////declaration.lifted_analysis + (///.lifted meta.current_module_name))] + (/////declaration.lifted_generation + (do phase.monad + [dependencies (cache/artifact.dependencies archive codeS) + [interim_artifacts codeG] (/////generation.with_interim_artifacts archive + (generate archive codeS)) + @module (phase.lifted (archive.id current_module archive)) + @self (<learn> extension (list#mix set.has dependencies interim_artifacts)) + [target_name value declaration] (/////generation.define! [@module @self] {.#None} [{.#None} codeG]) + _ (/////generation.save! @self {.#None} declaration)] + (in [codeG value]))))) + + (def .public (<full> archive extension codeT codeC) + (All (_ anchor expression declaration) + (-> Archive Text Type Code + (Operation anchor expression declaration [expression Any]))) + (do phase.monad + [state (///.lifted phase.state) + .let [analyse (the [/////declaration.#analysis /////declaration.#phase] state) + synthesize (the [/////declaration.#synthesis /////declaration.#phase] state) + generate (the [/////declaration.#generation /////declaration.#phase] state)] + [_ codeA] (<| /////declaration.lifted_analysis + scope.with + typeA.fresh + (typeA.expecting codeT) + (analyse archive codeC)) + codeS (/////declaration.lifted_synthesis + (synthesize archive codeA))] + (<partial> archive generate extension codeT codeS)))] + + [analyser analyser' /////generation.learn_analyser] + [synthesizer synthesizer' /////generation.learn_synthesizer] + [generator generator' /////generation.learn_generator] + [declaration declaration' /////generation.learn_declaration] + ) + +... TODO: Get rid of this function ASAP. +(def (refresh expander host_analysis) + (All (_ anchor expression declaration) + (-> Expander /////analysis.Bundle (Operation anchor expression declaration Any))) + (do phase.monad + [[bundle state] phase.state + .let [eval (/////analysis/evaluation.evaluator expander + (the [/////declaration.#synthesis /////declaration.#state] state) + (the [/////declaration.#generation /////declaration.#state] state) + (the [/////declaration.#generation /////declaration.#phase] state)) + previous_analysis_extensions (the [/////declaration.#analysis /////declaration.#state ///.#bundle] state)]] + (phase.with [bundle + (revised [/////declaration.#analysis /////declaration.#state] + (is (-> /////analysis.State+ /////analysis.State+) + (|>> product.right + [(|> previous_analysis_extensions + (dictionary.composite (///analysis.bundle eval host_analysis)))])) + state)]))) + +(def (announce_definition! short type) + (All (_ anchor expression declaration) + (-> Text Type (Operation anchor expression declaration Any))) + (/////declaration.lifted_generation + (/////generation.log! (format short " : " (%.type type))))) + +(def (lux::def expander host_analysis) + (-> Expander /////analysis.Bundle Handler) + (function (_ extension_name phase archive inputsC+) + (case inputsC+ + (list [_ {.#Symbol ["" short_name]}] valueC exported?C) + (do phase.monad + [current_module (/////declaration.lifted_analysis + (///.lifted meta.current_module_name)) + .let [full_name [current_module short_name]] + [type valueT value] (..definition archive full_name {.#None} valueC) + [_ _ exported?] (evaluate! archive Bit exported?C) + _ (/////declaration.lifted_analysis + (moduleA.define short_name {.#Definition [(as Bit exported?) type value]})) + _ (..refresh expander host_analysis) + _ (..announce_definition! short_name type)] + (in /////declaration.no_requirements)) + + _ + (phase.except ///.invalid_syntax [extension_name %.code inputsC+])))) + +(def (announce_labels! labels owner) + (All (_ anchor expression declaration) + (-> (List Text) Type (Operation anchor expression declaration (List Any)))) + (/////declaration.lifted_generation + (monad.each phase.monad + (function (_ tag) + (/////generation.log! (format tag " : Tag of " (%.type owner)))) + labels))) + +(def (deftype_tagged expander host_analysis) + (-> Expander /////analysis.Bundle Handler) + (..custom + [(all <>.and <code>.local <code>.any + (<>.or (<code>.variant (<>.some <code>.text)) + (<code>.tuple (<>.some <code>.text))) + <code>.any) + (function (_ extension_name phase archive [short_name valueC labels exported?C]) + (do phase.monad + [current_module (/////declaration.lifted_analysis + (///.lifted meta.current_module_name)) + .let [full_name [current_module short_name]] + [_ _ exported?] (evaluate! archive Bit exported?C) + .let [exported? (as Bit exported?)] + [type valueT value] (..definition archive full_name {.#Some .Type} valueC) + labels (/////declaration.lifted_analysis + (do phase.monad + [.let [[record? labels] (case labels + {.#Left tags} + [false tags] + + {.#Right slots} + [true slots])] + _ (case labels + {.#End} + (moduleA.define short_name {.#Definition [exported? type value]}) + + {.#Item labels} + (moduleA.define short_name {.#Type [exported? (as .Type value) (if record? + {.#Right labels} + {.#Left labels})]})) + _ (moduleA.declare_labels record? labels exported? (as .Type value))] + (in labels))) + _ (..refresh expander host_analysis) + _ (..announce_definition! short_name type) + _ (..announce_labels! labels (as Type value))] + (in /////declaration.no_requirements)))])) + +(def imports + (Parser (List Import)) + (|> (<code>.tuple (<>.and <code>.text <code>.text)) + <>.some + <code>.tuple)) + +(def defmodule + Handler + (..custom + [..imports + (function (_ extension_name phase archive imports) + (do [! phase.monad] + [_ (/////declaration.lifted_analysis + (monad.each ! (function (_ [module alias]) + (do ! + [_ (moduleA.import module)] + (case alias + "" (in []) + _ (moduleA.alias alias module)))) + imports))] + (in [/////declaration.#imports imports + /////declaration.#referrals (list)])))])) + +(exception .public (cannot_alias_an_alias [local Alias + foreign Alias + target Symbol]) + (exception.report + "Local alias" (%.symbol local) + "Foreign alias" (%.symbol foreign) + "Target definition" (%.symbol target))) + +(exception .public (cannot_alias_a_label [local Alias + foreign Alias]) + (exception.report + "Alias" (%.symbol local) + "Label" (%.symbol foreign))) + +(def (define_alias alias original) + (-> Text Symbol (/////analysis.Operation Any)) + (do phase.monad + [current_module (///.lifted meta.current_module_name) + constant (///.lifted (meta.definition original))] + (case constant + {.#Alias de_aliased} + (phase.except ..cannot_alias_an_alias [[current_module alias] original de_aliased]) + + (^.or {.#Definition _} + {.#Type _}) + (moduleA.define alias {.#Alias original}) + + (^.or {.#Tag _} + {.#Slot _}) + (phase.except ..cannot_alias_a_label [[current_module alias] original])))) + +(def defalias + Handler + (..custom + [(all <>.and <code>.local <code>.symbol) + (function (_ extension_name phase archive [alias def_name]) + (do phase.monad + [_ (///.lifted + (phase.sub [(the [/////declaration.#analysis /////declaration.#state]) + (has [/////declaration.#analysis /////declaration.#state])] + (define_alias alias def_name)))] + (in /////declaration.no_requirements)))])) + +... TODO: Stop requiring these types and the "swapped" function below to make types line-up. +(with_template [<name> <anonymous>] + [(def <name> + Type + (with_expansions [<original> binary.Binary] + (let [_ <original>] + {.#Named (symbol <original>) + <anonymous>})))] + + [Binary|Python (Primitive "bytearray")] + [Binary|DEFAULT (type_literal (array.Array (I64 Any)))] + ) + +(def (swapped original replacement) + (-> Type Type Type Type) + (function (again type) + (if (type#= original type) + replacement + (case type + {.#Primitive name parameters} + {.#Primitive name (list#each again parameters)} + + (^.with_template [<tag>] + [{<tag> left right} + {<tag> (again left) (again right)}]) + ([.#Sum] + [.#Product] + [.#Function] + [.#Apply]) + + (^.or {.#Parameter _} + {.#Var _} + {.#Ex _}) + type + + (^.with_template [<tag>] + [{<tag> closure body} + {<tag> closure (again body)}]) + ([.#UnivQ] + [.#ExQ]) + + {.#Named name anonymous} + {.#Named name (again anonymous)})))) + +(with_template [<description> <mame> <def_type> <type> <scope> <definer>] + [(def (<mame> [anchorT expressionT declarationT] extender) + (All (_ anchor expression declaration) + (-> [Type Type Type] Extender + (Handler anchor expression declaration))) + (function (handler extension_name phase archive inputsC+) + (case inputsC+ + (list nameC valueC) + (do phase.monad + [target_platform (/////declaration.lifted_analysis + (///.lifted meta.target)) + [_ _ name] (evaluate! archive Text nameC) + [_ handlerV] (<definer> archive (as Text name) + (let [raw_type (type_literal <def_type>)] + (case target_platform + (^.or (static @.jvm) + (static @.js)) + raw_type + + (static @.python) + (swapped binary.Binary Binary|Python raw_type) + + _ + (swapped binary.Binary Binary|DEFAULT raw_type))) + valueC) + _ (<| <scope> + (///.install extender (as Text name)) + (sharing [anchor expression declaration] + (is (Handler anchor expression declaration) + handler) + (is <type> + (as_expected handlerV)))) + _ (/////declaration.lifted_generation + (/////generation.log! (format <description> " " (%.text (as Text name)))))] + (in /////declaration.no_requirements)) + + _ + (phase.except ///.invalid_syntax [extension_name %.code inputsC+]))))] + + ["Analysis" + defanalysis + /////analysis.Handler /////analysis.Handler + /////declaration.lifted_analysis + ..analyser] + ["Synthesis" + defsynthesis + /////synthesis.Handler /////synthesis.Handler + /////declaration.lifted_synthesis + ..synthesizer] + ["Generation" + defgeneration + (/////generation.Handler anchorT expressionT declarationT) (/////generation.Handler anchor expression declaration) + /////declaration.lifted_generation + ..generator] + ["Declaration" + defdeclaration + (/////declaration.Handler anchorT expressionT declarationT) (/////declaration.Handler anchor expression declaration) + (<|) + ..declaration] + ) + +... TODO; Both "prepare-program" and "define-program" exist only +... because the old compiler couldn't handle a fully-inlined definition +... for "defprogram". Inline them ASAP. +(def (prepare_program archive analyse synthesize programC) + (All (_ anchor expression declaration output) + (-> Archive + /////analysis.Phase + /////synthesis.Phase + Code + (Operation anchor expression declaration Synthesis))) + (do phase.monad + [[_ programA] (<| /////declaration.lifted_analysis + scope.with + typeA.fresh + (typeA.expecting (type_literal (-> (List Text) (IO Any)))) + (analyse archive programC))] + (/////declaration.lifted_synthesis + (synthesize archive programA)))) + +(def (define_program archive @module generate program programS) + (All (_ anchor expression declaration output) + (-> Archive + module.ID + (/////generation.Phase anchor expression declaration) + (Program expression declaration) + Synthesis + (/////generation.Operation anchor expression declaration Any))) + (do phase.monad + [dependencies (cache/artifact.dependencies archive programS) + [interim_artifacts programG] (/////generation.with_interim_artifacts archive + (generate archive programS)) + @self (/////generation.learn [/////program.name {.#None}] true (list#mix set.has dependencies interim_artifacts))] + (/////generation.save! @self {.#None} (program [@module @self] programG)))) + +(def (defprogram program) + (All (_ anchor expression declaration) + (-> (Program expression declaration) (Handler anchor expression declaration))) + (function (handler extension_name phase archive inputsC+) + (case inputsC+ + (list programC) + (do phase.monad + [state (///.lifted phase.state) + .let [analyse (the [/////declaration.#analysis /////declaration.#phase] state) + synthesize (the [/////declaration.#synthesis /////declaration.#phase] state) + generate (the [/////declaration.#generation /////declaration.#phase] state)] + programS (prepare_program archive analyse synthesize programC) + current_module (/////declaration.lifted_analysis + (///.lifted meta.current_module_name)) + @module (phase.lifted (archive.id current_module archive)) + _ (/////declaration.lifted_generation + (define_program archive @module generate program programS))] + (in /////declaration.no_requirements)) + + _ + (phase.except ///.invalid_syntax [extension_name %.code inputsC+])))) + +(def (bundle::def expander host_analysis program anchorT,expressionT,declarationT extender) + (All (_ anchor expression declaration) + (-> Expander + /////analysis.Bundle + (Program expression declaration) + [Type Type Type] + Extender + (Bundle anchor expression declaration))) + (<| (///bundle.prefix "def") + (|> ///bundle.empty + (dictionary.has "module" defmodule) + (dictionary.has "alias" defalias) + (dictionary.has "type tagged" (deftype_tagged expander host_analysis)) + (dictionary.has "analysis" (defanalysis anchorT,expressionT,declarationT extender)) + (dictionary.has "synthesis" (defsynthesis anchorT,expressionT,declarationT extender)) + (dictionary.has "generation" (defgeneration anchorT,expressionT,declarationT extender)) + (dictionary.has "declaration" (defdeclaration anchorT,expressionT,declarationT extender)) + (dictionary.has "program" (defprogram program)) + ))) + +(def .public (bundle expander host_analysis program anchorT,expressionT,declarationT extender) + (All (_ anchor expression declaration) + (-> Expander + /////analysis.Bundle + (Program expression declaration) + [Type Type Type] + Extender + (Bundle anchor expression declaration))) + (<| (///bundle.prefix "lux") + (|> ///bundle.empty + (dictionary.has "def" (lux::def expander host_analysis)) + (dictionary.composite (..bundle::def expander host_analysis program anchorT,expressionT,declarationT extender))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/common_lisp.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/common_lisp.lux new file mode 100644 index 000000000..94afa28d6 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/common_lisp.lux @@ -0,0 +1,18 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + ["[0]" / + ["[1][0]" common] + ["[1][0]" host] + [//// + [generation + [common_lisp + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (dictionary.composite /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/common_lisp/common.lux new file mode 100644 index 000000000..41b1165c9 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/common_lisp/common.lux @@ -0,0 +1,182 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function] + ["[0]" try]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" dictionary] + ["[0]" set] + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["f" frac]]] + [meta + ["@" target (.only) + ["_" common_lisp (.only Expression)]]]]] + ["[0]" //// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["[0]" reference] + ["//" common_lisp + ["[1][0]" runtime (.only Operation Phase Handler Bundle Generator)] + ["[1][0]" case]]] + [// + ["[0]" generation] + ["[0]" synthesis (.only %synthesis) + ["<s>" \\parser (.only Parser)]] + [/// + ["[1]" phase]]]]]) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.result parser input) + {try.#Success input'} + (handler extension_name phase archive input') + + {try.#Failure error} + (/////.except extension.invalid_syntax [extension_name %synthesis input])))) + +(def !unary + (template (_ function) + (|>> list _.apply (|> (_.constant function))))) + +... ... TODO: Get rid of this ASAP +... (def lux::syntax_char_case! +... (..custom [(all <>.and +... <s>.any +... <s>.any +... (<>.some (<s>.tuple (all <>.and +... (<s>.tuple (<>.many <s>.i64)) +... <s>.any)))) +... (function (_ extension_name phase archive [input else conditionals]) +... (do [! /////.monad] +... [@input (at ! each _.var (generation.symbol "input")) +... inputG (phase archive input) +... elseG (phase archive else) +... conditionalsG (is (Operation (List [Expression Expression])) +... (monad.each ! (function (_ [chars branch]) +... (do ! +... [branchG (phase archive branch)] +... (in [(|> chars (list#each (|>> .int _.int (_.=/2 @input))) _.or) +... branchG]))) +... conditionals))] +... (in (_.let (list [@input inputG]) +... (list (list#mix (function (_ [test then] else) +... (_.if test then else)) +... elseG +... conditionalsG))))))])) + +(def lux_procs + Bundle + (|> /.empty + ... (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary _.eq/2)) + ... (/.install "try" (unary //runtime.lux//try)) + )) + +... (def (capped operation parameter subject) +... (-> (-> Expression Expression Expression) +... (-> Expression Expression Expression)) +... (//runtime.i64//64 (operation parameter subject))) + +(def i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary _.logand/2)) + (/.install "or" (binary _.logior/2)) + (/.install "xor" (binary _.logxor/2)) + (/.install "left-shift" (binary _.ash/2)) + (/.install "right-shift" (binary (product.uncurried //runtime.i64//right_shifted))) + (/.install "=" (binary _.=/2)) + (/.install "<" (binary _.</2)) + (/.install "+" (binary _.+/2)) + (/.install "-" (binary _.-/2)) + (/.install "*" (binary _.*/2)) + (/.install "/" (binary _.floor/2)) + (/.install "%" (binary _.rem/2)) + ... (/.install "f64" (unary (_.//2 (_.float +1.0)))) + (/.install "char" (unary (|>> _.code_char/1 _.string/1))) + ))) + +(def f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + ... (/.install "=" (binary (product.uncurried _.=/2))) + ... (/.install "<" (binary (product.uncurried _.</2))) + ... (/.install "+" (binary (product.uncurried _.+/2))) + ... (/.install "-" (binary (product.uncurried _.-/2))) + ... (/.install "*" (binary (product.uncurried _.*/2))) + ... (/.install "/" (binary (product.uncurried _.//2))) + ... (/.install "%" (binary (product.uncurried _.rem/2))) + ... (/.install "i64" (unary _.truncate/1)) + (/.install "encode" (unary _.write_to_string/1)) + ... (/.install "decode" (unary //runtime.f64//decode)) + ))) + +(def (text//index [offset sub text]) + (Trinary (Expression Any)) + (//runtime.text//index offset sub text)) + +(def (text//clip [offset length text]) + (Trinary (Expression Any)) + (//runtime.text//clip offset length text)) + +(def (text//char [index text]) + (Binary (Expression Any)) + (_.char_code/1 (_.char/2 [text index]))) + +(def text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary _.string=/2)) + ... (/.install "<" (binary (product.uncurried _.string<?/2))) + (/.install "concat" (binary (function (_ [left right]) + (_.concatenate/3 [(_.symbol "string") left right])))) + (/.install "index" (trinary ..text//index)) + (/.install "size" (unary _.length/1)) + (/.install "char" (binary ..text//char)) + (/.install "clip" (trinary ..text//clip)) + ))) + +(def (io//log! message) + (Unary (Expression Any)) + (_.progn (list (_.write_line/1 message) + //runtime.unit))) + +(def io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary _.error/1)) + ))) + +(def .public bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + (dictionary.composite lux_procs) + (dictionary.composite i64_procs) + (dictionary.composite f64_procs) + (dictionary.composite text_procs) + (dictionary.composite io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/common_lisp/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/common_lisp/host.lux new file mode 100644 index 000000000..987668fa2 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/common_lisp/host.lux @@ -0,0 +1,15 @@ +(.require + [library + [lux (.except)]] + [//// + ["/" bundle] + [// + [generation + [common_lisp + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (<| (/.prefix "common_lisp") + (|> /.empty + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/js.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/js.lux new file mode 100644 index 000000000..9dde05bab --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/js.lux @@ -0,0 +1,18 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + ["[0]" / + ["[1][0]" common] + ["[1][0]" host] + [//// + [generation + [js + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (dictionary.composite /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/js/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/js/common.lux new file mode 100644 index 000000000..772660310 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/js/common.lux @@ -0,0 +1,253 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" try]] + [data + ["[0]" product] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" dictionary]]] + [math + [number + ["f" frac]]] + [meta + ["@" target (.only) + ["_" js (.only Literal Expression Statement)]] + [macro + ["^" pattern]]]]] + ["[0]" //// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" js + ["[1][0]" runtime (.only Operation Phase Phase! Handler Bundle Generator)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["[1][0]" function]]] + [// + ["[0]" synthesis (.only %synthesis) + ["<s>" \\parser (.only Parser)]] + [/// + ["[1]" phase (.use "[1]#[0]" monad)]]]]]) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.result parser input) + {try.#Success input'} + (handler extension_name phase archive input') + + {try.#Failure error} + (/////.except extension.invalid_syntax [extension_name %synthesis input])))) + +... [Procedures] +... [[Bits]] +(with_template [<name> <op>] + [(def (<name> [paramG subjectG]) + (Binary Expression) + (<op> subjectG (//runtime.i64::number paramG)))] + + [i64::left_shifted //runtime.i64::left_shifted] + [i64::right_shifted //runtime.i64::right_shifted] + ) + +... [[Numbers]] +(def f64//decode + (Unary Expression) + (|>> list + (_.apply (_.var "parseFloat")) + _.return + (_.closure (list)) + //runtime.lux//try)) + +(def i64::char + (Unary Expression) + (|>> //runtime.i64::number + (list) + (_.apply (_.var "String.fromCharCode")))) + +... [[Text]] +(def (text//concat [leftG rightG]) + (Binary Expression) + (|> leftG (_.do "concat" (list rightG)))) + +(def (text//clip [startG endG subjectG]) + (Trinary Expression) + (//runtime.text//clip startG endG subjectG)) + +(def (text//index [startG partG subjectG]) + (Trinary Expression) + (//runtime.text//index startG partG subjectG)) + +... [[IO]] +(def (io//log messageG) + (Unary Expression) + (all _., + (//runtime.io//log messageG) + //runtime.unit)) + +(def .public (statement expression archive synthesis) + Phase! + (case synthesis + ... TODO: Get rid of this ASAP + {synthesis.#Extension "lux syntax char case!" parameters} + (do /////.monad + [body (expression archive synthesis)] + (in (as Statement body))) + + (^.with_template [<tag>] + [(<tag> value) + (/////#each _.return (expression archive synthesis))]) + ([synthesis.bit] + [synthesis.i64] + [synthesis.f64] + [synthesis.text] + [synthesis.variant] + [synthesis.tuple] + [synthesis.branch/get] + [synthesis.function/apply]) + + (^.with_template [<tag>] + [{<tag> value} + (/////#each _.return (expression archive synthesis))]) + ([synthesis.#Reference] + [synthesis.#Extension]) + + (synthesis.branch/case case) + (//case.case! statement expression archive case) + + (synthesis.branch/exec it) + (//case.exec! statement expression archive it) + + (synthesis.branch/let let) + (//case.let! statement expression archive let) + + (synthesis.branch/if if) + (//case.if! statement expression archive if) + + (synthesis.loop/scope scope) + (//loop.scope! statement expression archive scope) + + (synthesis.loop/again updates) + (//loop.again! statement expression archive updates) + + (synthesis.function/abstraction abstraction) + (/////#each _.return (//function.function statement expression archive abstraction)) + )) + +... TODO: Get rid of this ASAP +(def lux::syntax_char_case! + (..custom [(all <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple (all <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do [! /////.monad] + [inputG (phase archive input) + else! (..statement phase archive else) + conditionals! (is (Operation (List [(List Literal) + Statement])) + (monad.each ! (function (_ [chars branch]) + (do ! + [branch! (..statement phase archive branch)] + (in [(list#each (|>> .int _.int) chars) + branch!]))) + conditionals))] + ... (in (_.apply (_.closure (list) + ... (_.switch (_.the //runtime.i64_low_field inputG) + ... conditionals! + ... {.#Some (_.return else!)})) + ... (list))) + (in (<| (as Expression) + (is Statement) + (_.switch (_.the //runtime.i64_low_field inputG) + conditionals! + {.#Some else!})))))])) + +... [Bundles] +(def lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurried _.=))) + (/.install "try" (unary //runtime.lux//try)))) + +(def i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurried //runtime.i64::and))) + (/.install "or" (binary (product.uncurried //runtime.i64::or))) + (/.install "xor" (binary (product.uncurried //runtime.i64::xor))) + (/.install "left-shift" (binary i64::left_shifted)) + (/.install "right-shift" (binary i64::right_shifted)) + (/.install "=" (binary (product.uncurried //runtime.i64::=))) + (/.install "<" (binary (product.uncurried //runtime.i64::<))) + (/.install "+" (binary (product.uncurried //runtime.i64::+))) + (/.install "-" (binary (product.uncurried //runtime.i64::-))) + (/.install "*" (binary (product.uncurried //runtime.i64::*))) + (/.install "/" (binary (product.uncurried //runtime.i64::/))) + (/.install "%" (binary (product.uncurried //runtime.i64::%))) + (/.install "f64" (unary //runtime.i64::number)) + (/.install "char" (unary i64::char)) + ))) + +(def f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "+" (binary (product.uncurried _.+))) + (/.install "-" (binary (product.uncurried _.-))) + (/.install "*" (binary (product.uncurried _.*))) + (/.install "/" (binary (product.uncurried _./))) + (/.install "%" (binary (product.uncurried _.%))) + (/.install "=" (binary (product.uncurried _.=))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "i64" (unary //runtime.i64::of_number)) + (/.install "encode" (unary (_.do "toString" (list)))) + (/.install "decode" (unary f64//decode))))) + +(def text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurried _.=))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "concat" (binary text//concat)) + (/.install "index" (trinary text//index)) + (/.install "size" (unary (|>> (_.the "length") //runtime.i64::of_number))) + (/.install "char" (binary (product.uncurried //runtime.text//char))) + (/.install "clip" (trinary text//clip)) + ))) + +(def io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary io//log)) + (/.install "error" (unary //runtime.io//error))))) + +(def .public bundle + Bundle + (<| (/.prefix "lux") + (|> lux_procs + (dictionary.composite i64_procs) + (dictionary.composite f64_procs) + (dictionary.composite text_procs) + (dictionary.composite io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/js/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/js/host.lux new file mode 100644 index 000000000..b15b0ae3f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/js/host.lux @@ -0,0 +1,162 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + [collection + ["[0]" dictionary] + ["[0]" list]]] + [meta + [target + ["_" js (.only Var Expression)]]]]] + ["[0]" // + ["[1][0]" common (.only custom)] + ["//[1]" /// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" js + ["[1][0]" runtime (.only Operation Phase Handler Bundle + with_vars)]]] + ["/[1]" // + ["[0]" generation] + [synthesis + ["<s>" \\parser (.only Parser)]] + ["//[1]" /// + ["[1][0]" phase]]]]]]) + +(def array::new + (Unary Expression) + (|>> (_.the //runtime.i64_low_field) list (_.new (_.var "Array")))) + +(def array::length + (Unary Expression) + (|>> (_.the "length") //runtime.i64::of_number)) + +(def (array::read [indexG arrayG]) + (Binary Expression) + (_.at (_.the //runtime.i64_low_field indexG) + arrayG)) + +(def (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//delete indexG arrayG)) + +(def array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def object::new + (custom + [(all <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [constructorS inputsS]) + (do [! ////////phase.monad] + [constructorG (phase archive constructorS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.new constructorG inputsG))))])) + +(def object::get + Handler + (custom + [(all <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (in (_.the fieldS objectG))))])) + +(def object::do + Handler + (custom + [(all <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do [! ////////phase.monad] + [objectG (phase archive objectS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.do methodS inputsG objectG))))])) + +(with_template [<!> <?> <unit>] + [(def <!> (Nullary Expression) (function.constant <unit>)) + (def <?> (Unary Expression) (_.= <unit>))] + + [object::null object::null? _.null] + [object::undefined object::undefined? _.undefined] + ) + +(def object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "new" object::new) + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "null" (nullary object::null)) + (/.install "null?" (unary object::null?)) + (/.install "undefined" (nullary object::undefined)) + (/.install "undefined?" (unary object::undefined?)) + ))) + +(def js::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (at ////////phase.monad in (_.var name)))])) + +(def js::apply + (custom + [(all <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do [! ////////phase.monad] + [abstractionG (phase archive abstractionS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.apply abstractionG inputsG))))])) + +(def js::function + (custom + [(all <>.and <s>.i64 <s>.any) + (function (_ extension phase archive [arity abstractionS]) + (do [! ////////phase.monad] + [abstractionG (phase archive abstractionS) + .let [variable (is (-> Text (Operation Var)) + (|>> generation.symbol + (at ! each _.var)))] + g!inputs (monad.each ! (function (_ _) (variable "input")) + (list.repeated (.nat arity) [])) + g!abstraction (variable "abstraction")] + (in (_.closure g!inputs + (all _.then + (_.define g!abstraction abstractionG) + (_.return (case (.nat arity) + 0 (_.apply_1 g!abstraction //runtime.unit) + 1 (_.apply g!abstraction g!inputs) + _ (_.apply_1 g!abstraction (_.array g!inputs)))))))))])) + +(def .public bundle + Bundle + (<| (/.prefix "js") + (|> /.empty + (dictionary.composite ..array) + (dictionary.composite ..object) + + (/.install "constant" js::constant) + (/.install "apply" js::apply) + (/.install "type-of" (unary _.type_of)) + (/.install "function" js::function) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/jvm.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/jvm.lux new file mode 100644 index 000000000..6bed843bd --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/jvm.lux @@ -0,0 +1,20 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + ["[0]" / + ["[1][0]" common] + ["[1][0]" host] + [//// + [generation + [jvm + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (all dictionary.composite + /common.bundle + /host.bundle + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/jvm/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/jvm/common.lux new file mode 100644 index 000000000..9520433e1 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/jvm/common.lux @@ -0,0 +1,414 @@ +(.require + [library + [lux (.except Type Label Primitive) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" try]] + [data + ["[0]" product] + [collection + ["[0]" list (.use "[1]#[0]" monad)] + ["[0]" dictionary]]] + [math + [number + ["f" frac] + ["[0]" i32]]] + [meta + [target + [jvm + ["_" bytecode (.only Label Bytecode) (.use "[1]#[0]" monad)] + [encoding + ["[0]" signed (.only S4)]] + ["[0]" type (.only Type) + [category (.only Primitive Class)]]]]]]] + ["[0]" ///// + [generation + [extension (.only Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)] + ["///" jvm + ["[1][0]" value] + ["[1][0]" runtime (.only Operation Phase Bundle Handler)] + ["[1][0]" function + ["[1]" abstract]]]] + [extension + ["[1]extension" /] + ["[1][0]" bundle]] + [// + ["[0]" synthesis (.only Synthesis %synthesis) + ["<[1]>" \\parser (.only Parser)]] + [/// + ["[1]" phase] + [meta + [archive (.only Archive)]]]]]) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Text Phase Archive s (Operation (Bytecode Any)))] + Handler)) + (function (_ extension_name phase archive input) + (case (<synthesis>.result parser input) + {try.#Success input'} + (handler extension_name phase archive input') + + {try.#Failure error} + (/////.except /////extension.invalid_syntax [extension_name synthesis.%synthesis input])))) + +(def $Boolean (type.class "java.lang.Boolean" (list))) +(def $Double (type.class "java.lang.Double" (list))) +(def $Character (type.class "java.lang.Character" (list))) +(def $String (type.class "java.lang.String" (list))) +(def $CharSequence (type.class "java.lang.CharSequence" (list))) +(def $Object (type.class "java.lang.Object" (list))) +(def $PrintStream (type.class "java.io.PrintStream" (list))) +(def $System (type.class "java.lang.System" (list))) +(def $Error (type.class "java.lang.Error" (list))) + +(def lux_int + (Bytecode Any) + (all _.composite + _.i2l + (///value.wrap type.long))) + +(def jvm_int + (Bytecode Any) + (all _.composite + (///value.unwrap type.long) + _.l2i)) + +(def (predicate bytecode) + (-> (-> Label (Bytecode Any)) + (Bytecode Any)) + (do _.monad + [@then _.new_label + @end _.new_label] + (all _.composite + (bytecode @then) + (_.getstatic $Boolean "FALSE" $Boolean) + (_.goto @end) + (_.set_label @then) + (_.getstatic $Boolean "TRUE" $Boolean) + (_.set_label @end) + ))) + +... TODO: Get rid of this ASAP +(def lux::syntax_char_case! + (..custom [(all <>.and + <synthesis>.any + <synthesis>.any + (<>.some (<synthesis>.tuple (all <>.and + (<synthesis>.tuple (<>.many <synthesis>.i64)) + <synthesis>.any)))) + (function (_ extension_name phase archive [inputS elseS conditionalsS]) + (do [! /////.monad] + [@end ///runtime.forge_label + inputG (phase archive inputS) + elseG (phase archive elseS) + conditionalsG+ (is (Operation (List [(List [S4 Label]) + (Bytecode Any)])) + (monad.each ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch) + @branch ///runtime.forge_label] + (in [(list#each (function (_ char) + [(try.trusted (signed.s4 (.int char))) @branch]) + chars) + (all _.composite + (_.set_label @branch) + branchG + (_.when_continuous (_.goto @end)))]))) + conditionalsS)) + .let [table (|> conditionalsG+ + (list#each product.left) + list#conjoint) + conditionalsG (|> conditionalsG+ + (list#each product.right) + (monad.all _.monad))]] + (in (do _.monad + [@else _.new_label] + (all _.composite + inputG (///value.unwrap type.long) _.l2i + (_.lookupswitch @else table) + conditionalsG + (_.set_label @else) + elseG + (<| (_.when_acknowledged @end) + (_.set_label @end)) + )))))])) + +(def (lux::is [referenceG sampleG]) + (Binary (Bytecode Any)) + (all _.composite + referenceG + sampleG + (..predicate _.if_acmpeq))) + +(def (lux::try riskyG) + (Unary (Bytecode Any)) + (all _.composite + riskyG + (_.checkcast ///function.class) + ///runtime.try)) + +(def bundle::lux + Bundle + (|> (is Bundle /////bundle.empty) + (/////bundle.install "syntax char case!" ..lux::syntax_char_case!) + (/////bundle.install "is" (binary ..lux::is)) + (/////bundle.install "try" (unary ..lux::try)))) + +(with_template [<name> <op>] + [(def (<name> [maskG inputG]) + (Binary (Bytecode Any)) + (all _.composite + inputG (///value.unwrap type.long) + maskG (///value.unwrap type.long) + <op> (///value.wrap type.long)))] + + [i64::and _.land] + [i64::or _.lor] + [i64::xor _.lxor] + ) + +(with_template [<name> <op>] + [(def (<name> [shiftG inputG]) + (Binary (Bytecode Any)) + (all _.composite + inputG (///value.unwrap type.long) + shiftG ..jvm_int + <op> (///value.wrap type.long)))] + + [i64::left_shifted _.lshl] + [i64::right_shifted _.lushr] + ) + +(with_template [<name> <type> <op>] + [(def (<name> [paramG subjectG]) + (Binary (Bytecode Any)) + (all _.composite + subjectG (///value.unwrap <type>) + paramG (///value.unwrap <type>) + <op> (///value.wrap <type>)))] + + [i64::+ type.long _.ladd] + [i64::- type.long _.lsub] + [i64::* type.long _.lmul] + [i64::/ type.long _.ldiv] + [i64::% type.long _.lrem] + + [f64::+ type.double _.dadd] + [f64::- type.double _.dsub] + [f64::* type.double _.dmul] + [f64::/ type.double _.ddiv] + [f64::% type.double _.drem] + ) + +(with_template [<eq> <lt> <type> <cmp>] + [(with_template [<name> <reference>] + [(def (<name> [paramG subjectG]) + (Binary (Bytecode Any)) + (all _.composite + subjectG (///value.unwrap <type>) + paramG (///value.unwrap <type>) + <cmp> + <reference> + (..predicate _.if_icmpeq)))] + + [<eq> _.iconst_0] + [<lt> _.iconst_m1])] + + [i64::= i64::< type.long _.lcmp] + [f64::= f64::< type.double _.dcmpg] + ) + +(def (::toString class from) + (-> (Type Class) (Type Primitive) (Bytecode Any)) + (_.invokestatic class "toString" (type.method [(list) (list from) ..$String (list)]))) + +(with_template [<name> <prepare> <transform>] + [(def (<name> inputG) + (Unary (Bytecode Any)) + (all _.composite + inputG + <prepare> + <transform>))] + + [i64::f64 + (///value.unwrap type.long) + (all _.composite + _.l2d + (///value.wrap type.double))] + + [i64::char + (///value.unwrap type.long) + (all _.composite + _.l2i + _.i2c + (..::toString ..$Character type.char))] + + [f64::i64 + (///value.unwrap type.double) + (all _.composite + _.d2l + (///value.wrap type.long))] + + [f64::encode + (///value.unwrap type.double) + (..::toString ..$Double type.double)] + + [f64::decode + (_.checkcast $String) + ///runtime.decode_frac] + ) + +(def bundle::i64 + Bundle + (<| (/////bundle.prefix "i64") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "and" (binary ..i64::and)) + (/////bundle.install "or" (binary ..i64::or)) + (/////bundle.install "xor" (binary ..i64::xor)) + (/////bundle.install "left-shift" (binary ..i64::left_shifted)) + (/////bundle.install "right-shift" (binary ..i64::right_shifted)) + (/////bundle.install "=" (binary ..i64::=)) + (/////bundle.install "<" (binary ..i64::<)) + (/////bundle.install "+" (binary ..i64::+)) + (/////bundle.install "-" (binary ..i64::-)) + (/////bundle.install "*" (binary ..i64::*)) + (/////bundle.install "/" (binary ..i64::/)) + (/////bundle.install "%" (binary ..i64::%)) + (/////bundle.install "f64" (unary ..i64::f64)) + (/////bundle.install "char" (unary ..i64::char))))) + +(def bundle::f64 + Bundle + (<| (/////bundle.prefix "f64") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "+" (binary ..f64::+)) + (/////bundle.install "-" (binary ..f64::-)) + (/////bundle.install "*" (binary ..f64::*)) + (/////bundle.install "/" (binary ..f64::/)) + (/////bundle.install "%" (binary ..f64::%)) + (/////bundle.install "=" (binary ..f64::=)) + (/////bundle.install "<" (binary ..f64::<)) + (/////bundle.install "i64" (unary ..f64::i64)) + (/////bundle.install "encode" (unary ..f64::encode)) + (/////bundle.install "decode" (unary ..f64::decode))))) + +(def (text::size inputG) + (Unary (Bytecode Any)) + (all _.composite + inputG + (_.checkcast $String) + (_.invokevirtual ..$String "length" (type.method [(list) (list) type.int (list)])) + ..lux_int)) + +(def no_op (Bytecode Any) (_#in [])) + +(with_template [<name> <pre_subject> <pre_param> <op> <post>] + [(def (<name> [paramG subjectG]) + (Binary (Bytecode Any)) + (all _.composite + subjectG <pre_subject> + paramG <pre_param> + <op> <post>))] + + [text::= ..no_op ..no_op + (_.invokevirtual ..$Object "equals" (type.method [(list) (list ..$Object) type.boolean (list)])) + (///value.wrap type.boolean)] + [text::< (_.checkcast $String) (_.checkcast $String) + (_.invokevirtual ..$String "compareTo" (type.method [(list) (list ..$String) type.int (list)])) + (..predicate _.iflt)] + [text::char (_.checkcast $String) ..jvm_int + (_.invokevirtual ..$String "charAt" (type.method [(list) (list type.int) type.char (list)])) + ..lux_int] + ) + +(def (text::concat [leftG rightG]) + (Binary (Bytecode Any)) + (all _.composite + leftG (_.checkcast $String) + rightG (_.checkcast $String) + (_.invokevirtual ..$String "concat" (type.method [(list) (list ..$String) ..$String (list)])))) + +(def (text::clip [offset! length! subject!]) + (Trinary (Bytecode Any)) + (all _.composite + subject! (_.checkcast $String) + offset! ..jvm_int + _.dup + length! ..jvm_int + _.iadd + (_.invokevirtual ..$String "substring" (type.method [(list) (list type.int type.int) ..$String (list)])))) + +(def index_method (type.method [(list) (list ..$String type.int) type.int (list)])) +(def (text::index [startG partG textG]) + (Trinary (Bytecode Any)) + (do _.monad + [@not_found _.new_label + @end _.new_label] + (all _.composite + textG (_.checkcast $String) + partG (_.checkcast $String) + startG ..jvm_int + (_.invokevirtual ..$String "indexOf" index_method) + _.dup + _.iconst_m1 + (_.if_icmpeq @not_found) + ..lux_int + ///runtime.some_injection + (_.goto @end) + (_.set_label @not_found) + _.pop + ///runtime.none_injection + (_.set_label @end)))) + +(def bundle::text + Bundle + (<| (/////bundle.prefix "text") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "=" (binary ..text::=)) + (/////bundle.install "<" (binary ..text::<)) + (/////bundle.install "concat" (binary ..text::concat)) + (/////bundle.install "index" (trinary ..text::index)) + (/////bundle.install "size" (unary ..text::size)) + (/////bundle.install "char" (binary ..text::char)) + (/////bundle.install "clip" (trinary ..text::clip))))) + +(def string_method (type.method [(list) (list ..$String) type.void (list)])) +(def (io::log messageG) + (Unary (Bytecode Any)) + (all _.composite + (_.getstatic ..$System "out" ..$PrintStream) + messageG + (_.checkcast $String) + (_.invokevirtual ..$PrintStream "println" ..string_method) + ///runtime.unit)) + +(def (io::error messageG) + (Unary (Bytecode Any)) + (all _.composite + (_.new ..$Error) + _.dup + messageG + (_.checkcast $String) + (_.invokespecial ..$Error "<init>" ..string_method) + _.athrow)) + +(def bundle::io + Bundle + (<| (/////bundle.prefix "io") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "log" (unary ..io::log)) + (/////bundle.install "error" (unary ..io::error))))) + +(def .public bundle + Bundle + (<| (/////bundle.prefix "lux") + (|> bundle::lux + (dictionary.composite ..bundle::i64) + (dictionary.composite ..bundle::f64) + (dictionary.composite ..bundle::text) + (dictionary.composite ..bundle::io)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/jvm/host.lux new file mode 100644 index 000000000..668af9d43 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/jvm/host.lux @@ -0,0 +1,1390 @@ +(.require + [library + [lux (.except Type Primitive) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" maybe (.use "[1]#[0]" functor)] + ["[0]" exception (.only exception)]] + [data + ["[0]" product] + [binary + ["[0]" \\format]] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format] + ["<[1]>" \\parser]] + [collection + ["[0]" list (.use "[1]#[0]" monad mix monoid)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" set (.only Set)] + ["[0]" sequence]]] + [math + [number + ["n" nat] + ["[0]" i32]]] + [meta + [macro + ["^" pattern] + ["[0]" template]] + [target + [jvm + ["[0]" version] + ["[0]" modifier (.use "[1]#[0]" monoid)] + ["[0]" method (.only Method)] + ["[0]" class (.only Class)] + [constant + [pool (.only Resource)]] + [encoding + ["[0]" name]] + ["_" bytecode (.only Bytecode) (.use "[1]#[0]" monad) + ["__" instruction (.only Primitive_Array_Type)]] + ["[0]" type (.only Type Typed Argument) + ["[0]" category (.only Void Value' Value Return' Return Primitive Object Array Var Parameter)] + ["[0]" box] + ["[0]" reflection] + ["[0]" signature] + ["[0]" parser]]]]]]] + ["[0]" // + [common (.only custom)] + ["///[1]" //// + [generation + [extension (.only Nullary Unary Binary Trinary Variadic + nullary unary binary trinary variadic)] + ["///" jvm (.only) + ["[1][0]" runtime (.only Operation Bundle Phase Handler)] + ["[1][0]" reference] + ["[1][0]" value] + [function + [field + [variable + ["[0]" foreign]]]]]] + [extension + ["[1][0]" bundle] + [analysis + ["/" jvm]]] + ["/[1]" // + ["[1][0]" generation] + ["[0]" synthesis (.only Synthesis Path %synthesis) + ["<[1]>" \\parser (.only Parser)]] + [analysis (.only Environment) + ["[0]" complex]] + [/// + ["[1]" phase] + ["[1][0]" reference (.only) + ["[2][0]" variable (.only Variable Register)]] + [meta + ["[0]" archive (.only Archive) + ["[0]" artifact] + ["[0]" unit]] + ["[0]" cache + [dependency + ["[1]/[0]" artifact]]]]]]]]) + +(with_template [<name> <0>] + [(def <name> + (Bytecode Any) + (all _.composite + _.l2i + <0>))] + + [l2s _.i2s] + [l2b _.i2b] + [l2c _.i2c] + ) + +(with_template [<conversion> <name>] + [(def (<name> inputG) + (Unary (Bytecode Any)) + (if (same? _.nop <conversion>) + inputG + (all _.composite + inputG + <conversion>)))] + + [_.d2f conversion::double_to_float] + [_.d2i conversion::double_to_int] + [_.d2l conversion::double_to_long] + + [_.f2d conversion::float_to_double] + [_.f2i conversion::float_to_int] + [_.f2l conversion::float_to_long] + + [_.i2b conversion::int_to_byte] + [_.i2c conversion::int_to_char] + [_.i2d conversion::int_to_double] + [_.i2f conversion::int_to_float] + [_.i2l conversion::int_to_long] + [_.i2s conversion::int_to_short] + + [_.l2d conversion::long_to_double] + [_.l2f conversion::long_to_float] + [_.l2i conversion::long_to_int] + [..l2s conversion::long_to_short] + [..l2b conversion::long_to_byte] + [..l2c conversion::long_to_char] + + [_.i2b conversion::char_to_byte] + [_.i2s conversion::char_to_short] + [_.nop conversion::char_to_int] + [_.i2l conversion::char_to_long] + + [_.i2l conversion::byte_to_long] + + [_.i2l conversion::short_to_long] + ) + +(def bundle::conversion + Bundle + (<| (/////bundle.prefix "conversion") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "double-to-float" (unary conversion::double_to_float)) + (/////bundle.install "double-to-int" (unary conversion::double_to_int)) + (/////bundle.install "double-to-long" (unary conversion::double_to_long)) + + (/////bundle.install "float-to-double" (unary conversion::float_to_double)) + (/////bundle.install "float-to-int" (unary conversion::float_to_int)) + (/////bundle.install "float-to-long" (unary conversion::float_to_long)) + + (/////bundle.install "int-to-byte" (unary conversion::int_to_byte)) + (/////bundle.install "int-to-char" (unary conversion::int_to_char)) + (/////bundle.install "int-to-double" (unary conversion::int_to_double)) + (/////bundle.install "int-to-float" (unary conversion::int_to_float)) + (/////bundle.install "int-to-long" (unary conversion::int_to_long)) + (/////bundle.install "int-to-short" (unary conversion::int_to_short)) + + (/////bundle.install "long-to-double" (unary conversion::long_to_double)) + (/////bundle.install "long-to-float" (unary conversion::long_to_float)) + (/////bundle.install "long-to-int" (unary conversion::long_to_int)) + (/////bundle.install "long-to-short" (unary conversion::long_to_short)) + (/////bundle.install "long-to-byte" (unary conversion::long_to_byte)) + (/////bundle.install "long-to-char" (unary conversion::long_to_char)) + + (/////bundle.install "char-to-byte" (unary conversion::char_to_byte)) + (/////bundle.install "char-to-short" (unary conversion::char_to_short)) + (/////bundle.install "char-to-int" (unary conversion::char_to_int)) + (/////bundle.install "char-to-long" (unary conversion::char_to_long)) + + (/////bundle.install "byte-to-long" (unary conversion::byte_to_long)) + + (/////bundle.install "short-to-long" (unary conversion::short_to_long)) + ))) + +(with_template [<name> <op>] + [(def (<name> [parameter! subject!]) + (Binary (Bytecode Any)) + (all _.composite + subject! + parameter! + <op>))] + + [int::+ _.iadd] + [int::- _.isub] + [int::* _.imul] + [int::/ _.idiv] + [int::% _.irem] + [int::and _.iand] + [int::or _.ior] + [int::xor _.ixor] + [int::shl _.ishl] + [int::shr _.ishr] + [int::ushr _.iushr] + + [long::+ _.ladd] + [long::- _.lsub] + [long::* _.lmul] + [long::/ _.ldiv] + [long::% _.lrem] + [long::and _.land] + [long::or _.lor] + [long::xor _.lxor] + [long::shl _.lshl] + [long::shr _.lshr] + [long::ushr _.lushr] + + [float::+ _.fadd] + [float::- _.fsub] + [float::* _.fmul] + [float::/ _.fdiv] + [float::% _.frem] + + [double::+ _.dadd] + [double::- _.dsub] + [double::* _.dmul] + [double::/ _.ddiv] + [double::% _.drem] + ) + +(def $Boolean (type.class box.boolean (list))) +(def falseG (_.getstatic ..$Boolean "FALSE" ..$Boolean)) +(def trueG (_.getstatic ..$Boolean "TRUE" ..$Boolean)) + +(with_template [<name> <op>] + [(def (<name> [reference subject]) + (Binary (Bytecode Any)) + (do _.monad + [@then _.new_label + @end _.new_label] + (all _.composite + subject + reference + (<op> @then) + falseG + (_.goto @end) + (_.set_label @then) + trueG + (_.set_label @end))))] + + [int::= _.if_icmpeq] + [int::< _.if_icmplt] + + [char::= _.if_icmpeq] + [char::< _.if_icmplt] + ) + +(with_template [<name> <op> <reference>] + [(def (<name> [reference subject]) + (Binary (Bytecode Any)) + (do _.monad + [@then _.new_label + @end _.new_label] + (all _.composite + subject + reference + <op> + (_.int (i32.i32 (.i64 <reference>))) + (_.if_icmpeq @then) + falseG + (_.goto @end) + (_.set_label @then) + trueG + (_.set_label @end))))] + + [long::= _.lcmp +0] + [long::< _.lcmp -1] + + [float::= _.fcmpg +0] + [float::< _.fcmpg -1] + + [double::= _.dcmpg +0] + [double::< _.dcmpg -1] + ) + +(def bundle::int + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.int)) + (|> (is Bundle /////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 "and" (binary int::and)) + (/////bundle.install "or" (binary int::or)) + (/////bundle.install "xor" (binary int::xor)) + (/////bundle.install "shl" (binary int::shl)) + (/////bundle.install "shr" (binary int::shr)) + (/////bundle.install "ushr" (binary int::ushr)) + ))) + +(def bundle::long + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.long)) + (|> (is Bundle /////bundle.empty) + (/////bundle.install "+" (binary long::+)) + (/////bundle.install "-" (binary long::-)) + (/////bundle.install "*" (binary long::*)) + (/////bundle.install "/" (binary long::/)) + (/////bundle.install "%" (binary long::%)) + (/////bundle.install "=" (binary long::=)) + (/////bundle.install "<" (binary long::<)) + (/////bundle.install "and" (binary long::and)) + (/////bundle.install "or" (binary long::or)) + (/////bundle.install "xor" (binary long::xor)) + (/////bundle.install "shl" (binary long::shl)) + (/////bundle.install "shr" (binary long::shr)) + (/////bundle.install "ushr" (binary long::ushr)) + ))) + +(def bundle::float + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.float)) + (|> (is Bundle /////bundle.empty) + (/////bundle.install "+" (binary float::+)) + (/////bundle.install "-" (binary float::-)) + (/////bundle.install "*" (binary float::*)) + (/////bundle.install "/" (binary float::/)) + (/////bundle.install "%" (binary float::%)) + (/////bundle.install "=" (binary float::=)) + (/////bundle.install "<" (binary float::<)) + ))) + +(def bundle::double + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.double)) + (|> (is Bundle /////bundle.empty) + (/////bundle.install "+" (binary double::+)) + (/////bundle.install "-" (binary double::-)) + (/////bundle.install "*" (binary double::*)) + (/////bundle.install "/" (binary double::/)) + (/////bundle.install "%" (binary double::%)) + (/////bundle.install "=" (binary double::=)) + (/////bundle.install "<" (binary double::<)) + ))) + +(def bundle::char + Bundle + (<| (/////bundle.prefix (reflection.reflection reflection.char)) + (|> (is Bundle /////bundle.empty) + (/////bundle.install "=" (binary char::=)) + (/////bundle.install "<" (binary char::<)) + ))) + +(with_template [<name> <category> <parser>] + [(def .public <name> + (Parser (Type <category>)) + (<text>.then <parser> <synthesis>.text))] + + [var Var parser.var] + [class category.Class parser.class] + [object Object parser.object] + [value Value parser.value] + [return Return parser.return] + ) + +(def reflection + (All (_ category) + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(def signature + (All (_ category) + (-> (Type category) Text)) + (|>> type.signature signature.signature)) + +(exception .public (not_an_object_array [arrayJT (Type Array)]) + (exception.report + "JVM Type" (..signature arrayJT))) + +(def .public object_array + (Parser (Type Object)) + (do <>.monad + [arrayJT (<text>.then parser.array <synthesis>.text)] + (case (parser.array? arrayJT) + {.#Some elementJT} + (case (parser.object? elementJT) + {.#Some elementJT} + (in elementJT) + + {.#None} + (<>.failure (exception.error ..not_an_object_array [arrayJT]))) + + {.#None} + (undefined)))) + +(def (primitive_array_length_handler jvm_primitive) + (-> (Type Primitive) Handler) + (..custom + [<synthesis>.any + (function (_ extension_name generate archive arrayS) + (do //////.monad + [arrayG (generate archive arrayS)] + (in (all _.composite + arrayG + (_.checkcast (type.array jvm_primitive)) + _.arraylength))))])) + +(def array::length::object + Handler + (..custom + [(all <>.and ..object_array <synthesis>.any) + (function (_ extension_name generate archive [elementJT arrayS]) + (do //////.monad + [arrayG (generate archive arrayS)] + (in (all _.composite + arrayG + (_.checkcast (type.array elementJT)) + _.arraylength))))])) + +(def (new_primitive_array_handler jvm_primitive) + (-> Primitive_Array_Type Handler) + (..custom + [<synthesis>.any + (function (_ extension_name generate archive [lengthS]) + (do //////.monad + [lengthG (generate archive lengthS)] + (in (all _.composite + lengthG + (_.newarray jvm_primitive)))))])) + +(def array::new::object + Handler + (..custom + [(all <>.and ..object <synthesis>.any) + (function (_ extension_name generate archive [objectJT lengthS]) + (do //////.monad + [lengthG (generate archive lengthS)] + (in (all _.composite + lengthG + (_.anewarray objectJT)))))])) + +(def (read_primitive_array_handler jvm_primitive loadG) + (-> (Type Primitive) (Bytecode Any) Handler) + (..custom + [(all <>.and <synthesis>.any <synthesis>.any) + (function (_ extension_name generate archive [idxS arrayS]) + (do //////.monad + [arrayG (generate archive arrayS) + idxG (generate archive idxS)] + (in (all _.composite + arrayG + (_.checkcast (type.array jvm_primitive)) + idxG + loadG))))])) + +(def array::read::object + Handler + (..custom + [(all <>.and ..object_array <synthesis>.any <synthesis>.any) + (function (_ extension_name generate archive [elementJT idxS arrayS]) + (do //////.monad + [arrayG (generate archive arrayS) + idxG (generate archive idxS)] + (in (all _.composite + arrayG + (_.checkcast (type.array elementJT)) + idxG + _.aaload))))])) + +(def (write_primitive_array_handler jvm_primitive storeG) + (-> (Type Primitive) (Bytecode Any) Handler) + (..custom + [(all <>.and <synthesis>.any <synthesis>.any <synthesis>.any) + (function (_ extension_name generate archive [idxS valueS arrayS]) + (do //////.monad + [arrayG (generate archive arrayS) + idxG (generate archive idxS) + valueG (generate archive valueS)] + (in (all _.composite + arrayG + (_.checkcast (type.array jvm_primitive)) + _.dup + idxG + valueG + storeG))))])) + +(def array::write::object + Handler + (..custom + [(all <>.and ..object_array <synthesis>.any <synthesis>.any <synthesis>.any) + (function (_ extension_name generate archive [elementJT idxS valueS arrayS]) + (do //////.monad + [arrayG (generate archive arrayS) + idxG (generate archive idxS) + valueG (generate archive valueS)] + (in (all _.composite + arrayG + (_.checkcast (type.array elementJT)) + _.dup + idxG + valueG + _.aastore))))])) + +(def bundle::array + Bundle + (<| (/////bundle.prefix "array") + (|> /////bundle.empty + (dictionary.composite (<| (/////bundle.prefix "length") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (primitive_array_length_handler type.boolean)) + (/////bundle.install (reflection.reflection reflection.byte) (primitive_array_length_handler type.byte)) + (/////bundle.install (reflection.reflection reflection.short) (primitive_array_length_handler type.short)) + (/////bundle.install (reflection.reflection reflection.int) (primitive_array_length_handler type.int)) + (/////bundle.install (reflection.reflection reflection.long) (primitive_array_length_handler type.long)) + (/////bundle.install (reflection.reflection reflection.float) (primitive_array_length_handler type.float)) + (/////bundle.install (reflection.reflection reflection.double) (primitive_array_length_handler type.double)) + (/////bundle.install (reflection.reflection reflection.char) (primitive_array_length_handler type.char)) + (/////bundle.install "object" array::length::object)))) + (dictionary.composite (<| (/////bundle.prefix "new") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (new_primitive_array_handler __.t_boolean)) + (/////bundle.install (reflection.reflection reflection.byte) (new_primitive_array_handler __.t_byte)) + (/////bundle.install (reflection.reflection reflection.short) (new_primitive_array_handler __.t_short)) + (/////bundle.install (reflection.reflection reflection.int) (new_primitive_array_handler __.t_int)) + (/////bundle.install (reflection.reflection reflection.long) (new_primitive_array_handler __.t_long)) + (/////bundle.install (reflection.reflection reflection.float) (new_primitive_array_handler __.t_float)) + (/////bundle.install (reflection.reflection reflection.double) (new_primitive_array_handler __.t_double)) + (/////bundle.install (reflection.reflection reflection.char) (new_primitive_array_handler __.t_char)) + (/////bundle.install "object" array::new::object)))) + (dictionary.composite (<| (/////bundle.prefix "read") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (read_primitive_array_handler type.boolean _.baload)) + (/////bundle.install (reflection.reflection reflection.byte) (read_primitive_array_handler type.byte _.baload)) + (/////bundle.install (reflection.reflection reflection.short) (read_primitive_array_handler type.short _.saload)) + (/////bundle.install (reflection.reflection reflection.int) (read_primitive_array_handler type.int _.iaload)) + (/////bundle.install (reflection.reflection reflection.long) (read_primitive_array_handler type.long _.laload)) + (/////bundle.install (reflection.reflection reflection.float) (read_primitive_array_handler type.float _.faload)) + (/////bundle.install (reflection.reflection reflection.double) (read_primitive_array_handler type.double _.daload)) + (/////bundle.install (reflection.reflection reflection.char) (read_primitive_array_handler type.char _.caload)) + (/////bundle.install "object" array::read::object)))) + (dictionary.composite (<| (/////bundle.prefix "write") + (|> /////bundle.empty + (/////bundle.install (reflection.reflection reflection.boolean) (write_primitive_array_handler type.boolean _.bastore)) + (/////bundle.install (reflection.reflection reflection.byte) (write_primitive_array_handler type.byte _.bastore)) + (/////bundle.install (reflection.reflection reflection.short) (write_primitive_array_handler type.short _.sastore)) + (/////bundle.install (reflection.reflection reflection.int) (write_primitive_array_handler type.int _.iastore)) + (/////bundle.install (reflection.reflection reflection.long) (write_primitive_array_handler type.long _.lastore)) + (/////bundle.install (reflection.reflection reflection.float) (write_primitive_array_handler type.float _.fastore)) + (/////bundle.install (reflection.reflection reflection.double) (write_primitive_array_handler type.double _.dastore)) + (/////bundle.install (reflection.reflection reflection.char) (write_primitive_array_handler type.char _.castore)) + (/////bundle.install "object" array::write::object)))) + ))) + +(def (object::null _) + (Nullary (Bytecode Any)) + _.aconst_null) + +(def (object::null? objectG) + (Unary (Bytecode Any)) + (do _.monad + [@then _.new_label + @end _.new_label] + (all _.composite + objectG + (_.ifnull @then) + ..falseG + (_.goto @end) + (_.set_label @then) + ..trueG + (_.set_label @end)))) + +(def (object::synchronized [monitorG exprG]) + (Binary (Bytecode Any)) + (all _.composite + monitorG + _.dup + _.monitorenter + exprG + _.swap + _.monitorexit)) + +(def (object::throw exceptionG) + (Unary (Bytecode Any)) + (all _.composite + exceptionG + _.athrow)) + +(def $Class (type.class "java.lang.Class" (list))) +(def $String (type.class "java.lang.String" (list))) + +(def object::class + Handler + (..custom + [<synthesis>.text + (function (_ extension_name generate archive [class]) + (do //////.monad + [] + (in (all _.composite + (_.string class) + (_.invokestatic ..$Class "forName" (type.method [(list) (list ..$String) ..$Class (list)]))))))])) + +(def object::instance? + Handler + (..custom + [(all <>.and <synthesis>.text <synthesis>.any) + (function (_ extension_name generate archive [class objectS]) + (do //////.monad + [objectG (generate archive objectS)] + (in (all _.composite + objectG + (_.instanceof (type.class class (list))) + (///value.wrap type.boolean)))))])) + +(def object::cast + Handler + (..custom + [(all <>.and <synthesis>.text <synthesis>.text <synthesis>.any) + (function (_ extension_name generate archive [from to valueS]) + (do //////.monad + [valueG (generate archive valueS)] + (in (`` (cond (,, (with_template [<object> <type>] + [(and (text#= (..reflection <type>) from) + (text#= <object> to)) + (all _.composite + valueG + (///value.wrap <type>)) + + (and (text#= <object> from) + (text#= (..reflection <type>) to)) + (all _.composite + valueG + (///value.unwrap <type>))] + + [box.boolean type.boolean] + [box.byte type.byte] + [box.short type.short] + [box.int type.int] + [box.long type.long] + [box.char type.char] + [box.float type.float] + [box.double type.double])) + ... else + valueG)))))])) + +(def bundle::object + Bundle + (<| (/////bundle.prefix "object") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "null" (nullary object::null)) + (/////bundle.install "null?" (unary object::null?)) + (/////bundle.install "synchronized" (binary object::synchronized)) + (/////bundle.install "throw" (unary object::throw)) + (/////bundle.install "class" object::class) + (/////bundle.install "instance?" object::instance?) + (/////bundle.install "cast" object::cast) + ))) + +(def get::static + Handler + (..custom + [(all <>.and <synthesis>.text <synthesis>.text ..value) + (function (_ extension_name generate archive [class field :unboxed:]) + (at //////.monad in (_.getstatic (type.class class (list)) field :unboxed:)))])) + +(def unitG + (_.string synthesis.unit)) + +(def put::static + Handler + (..custom + [(all <>.and <synthesis>.text <synthesis>.text ..value <synthesis>.any) + (function (_ extension_name generate archive [class field :unboxed: valueS]) + (do //////.monad + [valueG (generate archive valueS)] + (in (all _.composite + valueG + (case (parser.object? :unboxed:) + {.#Some :unboxed:} + (_.checkcast :unboxed:) + + {.#None} + (_#in [])) + (_.putstatic (type.class class (list)) field :unboxed:) + ..unitG))))])) + +(def get::virtual + Handler + (..custom + [(all <>.and <synthesis>.text <synthesis>.text ..value <synthesis>.any) + (function (_ extension_name generate archive [class field :unboxed: objectS]) + (do //////.monad + [objectG (generate archive objectS) + .let [:class: (type.class class (list)) + getG (_.getfield :class: field :unboxed:)]] + (in (all _.composite + objectG + (_.checkcast :class:) + getG))))])) + +(def put::virtual + Handler + (..custom + [(all <>.and <synthesis>.text <synthesis>.text ..value <synthesis>.any <synthesis>.any) + (function (_ extension_name generate archive [class field :unboxed: valueS objectS]) + (do //////.monad + [valueG (generate archive valueS) + objectG (generate archive objectS) + .let [:class: (type.class class (list)) + putG (case (parser.object? :unboxed:) + {.#Some :unboxed:} + (all _.composite + (_.checkcast :unboxed:) + (_.putfield :class: field :unboxed:)) + + {.#None} + (_.putfield :class: field :unboxed:))]] + (in (all _.composite + objectG + (_.checkcast :class:) + _.dup + valueG + putG))))])) + +(type Input + (Typed Synthesis)) + +(def input + (Parser Input) + (<synthesis>.tuple (<>.and ..value <synthesis>.any))) + +(def (generate_input generate archive [valueT valueS]) + (-> Phase Archive Input (Operation (Typed (Bytecode Any)))) + (do //////.monad + [valueG (generate archive valueS)] + (case (type.primitive? valueT) + {.#Right valueT} + (in [valueT valueG]) + + {.#Left valueT} + (in [valueT (all _.composite + valueG + (_.checkcast valueT))])))) + +(def (prepare_output outputT) + (-> (Type Return) (Bytecode Any)) + (case (type.void? outputT) + {.#Right outputT} + ..unitG + + {.#Left outputT} + (_#in []))) + +(def invoke::static + Handler + (..custom + [(all <>.and ..class <synthesis>.text ..return (<>.some ..input)) + (function (_ extension_name generate archive [class method outputT inputsTS]) + (do [! //////.monad] + [inputsTG (monad.each ! (generate_input generate archive) inputsTS)] + (in (all _.composite + (monad.each _.monad product.right inputsTG) + (_.invokestatic class method (type.method [(list) (list#each product.left inputsTG) outputT (list)])) + (prepare_output outputT)))))])) + +(with_template [<check_cast?> <name> <invoke>] + [(def <name> + Handler + (..custom + [(all <>.and ..class <synthesis>.text ..return <synthesis>.any (<>.some ..input)) + (function (_ extension_name generate archive [class method outputT objectS inputsTS]) + (do [! //////.monad] + [objectG (generate archive objectS) + inputsTG (monad.each ! (generate_input generate archive) inputsTS)] + (in (all _.composite + objectG + (if <check_cast?> + (_.checkcast class) + (_#in [])) + (monad.each _.monad product.right inputsTG) + (<invoke> class method (type.method [(list) (list#each product.left inputsTG) outputT (list)])) + (prepare_output outputT)))))]))] + + [#1 invoke::virtual _.invokevirtual] + [#0 invoke::special _.invokespecial] + [#1 invoke::interface _.invokeinterface] + ) + +(def invoke::constructor + Handler + (..custom + [(all <>.and ..class (<>.some ..input)) + (function (_ extension_name generate archive [class inputsTS]) + (do [! //////.monad] + [inputsTG (monad.each ! (generate_input generate archive) inputsTS)] + (in (all _.composite + (_.new class) + _.dup + (monad.each _.monad product.right inputsTG) + (_.invokespecial class "<init>" (type.method [(list) (list#each product.left inputsTG) type.void (list)]))))))])) + +(def bundle::member + Bundle + (<| (/////bundle.prefix "member") + (|> (is Bundle /////bundle.empty) + (dictionary.composite (<| (/////bundle.prefix "get") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "static" get::static) + (/////bundle.install "virtual" get::virtual)))) + (dictionary.composite (<| (/////bundle.prefix "put") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "static" put::static) + (/////bundle.install "virtual" put::virtual)))) + (dictionary.composite (<| (/////bundle.prefix "invoke") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "static" invoke::static) + (/////bundle.install "virtual" invoke::virtual) + (/////bundle.install "special" invoke::special) + (/////bundle.install "interface" invoke::interface) + (/////bundle.install "constructor" invoke::constructor)))) + ))) + +(def annotation_parameter + (Parser (/.Annotation_Parameter Synthesis)) + (<synthesis>.tuple (<>.and <synthesis>.text <synthesis>.any))) + +(def annotation + (Parser (/.Annotation Synthesis)) + (<synthesis>.tuple (<>.and <synthesis>.text (<>.some ..annotation_parameter)))) + +(def argument + (Parser Argument) + (<synthesis>.tuple (<>.and <synthesis>.text ..value))) + +(def .public (hidden_method_body arity body) + (-> Nat Synthesis Synthesis) + (with_expansions [<oops> (panic! (%.format (%.nat arity) " " (synthesis.%synthesis body)))] + (case [arity body] + (^.or [0 _] + [1 _]) + body + + [2 {synthesis.#Control {synthesis.#Branch {synthesis.#Let _ 2 (synthesis.tuple (list _ hidden))}}}] + hidden + + [_ {synthesis.#Control {synthesis.#Branch {synthesis.#Case _ path}}}] + (loop (again [path (is Path path)]) + (case path + {synthesis.#Seq _ next} + (again next) + + {synthesis.#Then (synthesis.tuple (list _ hidden))} + hidden + + _ + <oops>)) + + _ + <oops>))) + +(def (without_fake_parameter#path without_fake_parameter) + (-> (-> Synthesis Synthesis) + (-> Path Path)) + (function (again it) + (case it + (^.or {synthesis.#Pop} + {synthesis.#Access _}) + it + + {synthesis.#Bind it} + {synthesis.#Bind (-- it)} + + {synthesis.#Bit_Fork when then else} + {synthesis.#Bit_Fork when + (again then) + (maybe#each again else)} + + (^.with_template [<tag>] + [{<tag> [head tail]} + {<tag> [(revised synthesis.#then again head) + (list#each (revised synthesis.#then again) tail)]}]) + ([synthesis.#I64_Fork] + [synthesis.#F64_Fork] + [synthesis.#Text_Fork]) + + (^.with_template [<tag>] + [{<tag> left right} + {<tag> (again left) (again right)}]) + ([synthesis.#Seq] + [synthesis.#Alt]) + + {synthesis.#Then it} + {synthesis.#Then (without_fake_parameter it)}))) + +(def .public (without_fake_parameter it) + (-> Synthesis Synthesis) + (case it + {synthesis.#Simple _} + it + + {synthesis.#Structure it} + {synthesis.#Structure + (case it + {complex.#Variant it} + {complex.#Variant (revised complex.#value without_fake_parameter it)} + + {complex.#Tuple it} + {complex.#Tuple (list#each without_fake_parameter it)})} + + {synthesis.#Reference it} + {synthesis.#Reference + (case it + {//////reference.#Variable it} + {//////reference.#Variable + (case it + {//////variable.#Local it} + {//////variable.#Local (-- it)} + + {//////variable.#Foreign _} + it)} + + {//////reference.#Constant _} + it)} + + {synthesis.#Control it} + {synthesis.#Control + (case it + {synthesis.#Branch it} + {synthesis.#Branch + (case it + {synthesis.#Exec before after} + {synthesis.#Exec (without_fake_parameter before) + (without_fake_parameter after)} + + {synthesis.#Let value register body} + {synthesis.#Let (without_fake_parameter value) + (-- register) + (without_fake_parameter body)} + + {synthesis.#If when then else} + {synthesis.#If (without_fake_parameter when) + (without_fake_parameter then) + (without_fake_parameter else)} + + {synthesis.#Get members record} + {synthesis.#Get members + (without_fake_parameter record)} + + {synthesis.#Case value path} + {synthesis.#Case (without_fake_parameter value) + (without_fake_parameter#path without_fake_parameter path)})} + + {synthesis.#Loop it} + {synthesis.#Loop + (case it + {synthesis.#Scope [synthesis.#start start + synthesis.#inits inits + synthesis.#iteration iteration]} + {synthesis.#Scope [synthesis.#start (-- start) + synthesis.#inits (list#each without_fake_parameter inits) + synthesis.#iteration iteration]} + + {synthesis.#Again _} + it)} + + {synthesis.#Function it} + {synthesis.#Function + (case it + {synthesis.#Abstraction [synthesis.#environment environment + synthesis.#arity arity + synthesis.#body body]} + {synthesis.#Abstraction [synthesis.#environment (list#each without_fake_parameter environment) + synthesis.#arity arity + synthesis.#body body]} + + {synthesis.#Apply [synthesis.#function function + synthesis.#arguments arguments]} + {synthesis.#Apply [synthesis.#function (without_fake_parameter function) + synthesis.#arguments (list#each without_fake_parameter arguments)]})})} + + {synthesis.#Extension name parameters} + {synthesis.#Extension name (list#each without_fake_parameter parameters)})) + +(def overriden_method_definition + (Parser [(Environment Synthesis) (/.Overriden_Method Synthesis)]) + (<synthesis>.tuple (do <>.monad + [_ (<synthesis>.this_text /.overriden_tag) + ownerT ..class + name <synthesis>.text + strict_fp? <synthesis>.bit + annotations (<synthesis>.tuple (<>.some ..annotation)) + vars (<synthesis>.tuple (<>.some ..var)) + self_name <synthesis>.text + arguments (<synthesis>.tuple (<>.some ..argument)) + returnT ..return + exceptionsT (<synthesis>.tuple (<>.some ..class)) + [environment _ _ body] (<| (<synthesis>.function 1) + (<synthesis>.loop (<>.exactly 0 <synthesis>.any)) + <synthesis>.tuple + (<>.after <synthesis>.any) + <synthesis>.any) + .let [arity (list.size arguments)]] + (in [environment + [ownerT name + strict_fp? annotations vars + self_name arguments returnT exceptionsT + (<| (..hidden_method_body arity) + (case arity + 0 (without_fake_parameter body) + _ body))]])))) + +(def (normalize_path normalize) + (-> (-> Synthesis Synthesis) + (-> Path Path)) + (function (again path) + (case path + (synthesis.path/then bodyS) + (synthesis.path/then (normalize bodyS)) + + (^.with_template [<tag>] + [{<tag> leftP rightP} + {<tag> (again leftP) (again rightP)}]) + ([synthesis.#Alt] + [synthesis.#Seq]) + + (^.with_template [<tag>] + [{<tag> _} + path]) + ([synthesis.#Pop] + [synthesis.#Bind] + [synthesis.#Access]) + + {synthesis.#Bit_Fork when then else} + {synthesis.#Bit_Fork when (again then) (maybe#each again else)} + + (^.with_template [<tag>] + [{<tag> [[exampleH nextH] tail]} + {<tag> [[exampleH (again nextH)] + (list#each (function (_ [example next]) + [example (again next)]) + tail)]}]) + ([synthesis.#I64_Fork] + [synthesis.#F64_Fork] + [synthesis.#Text_Fork])))) + +(type Mapping + (Dictionary Synthesis Variable)) + +(def (normalize_method_body mapping) + (-> Mapping Synthesis Synthesis) + (function (again body) + (case body + (^.with_template [<tag>] + [<tag> + body]) + ([{synthesis.#Simple _}] + [(synthesis.constant _)]) + + (synthesis.variant [lefts right? sub]) + (synthesis.variant [lefts right? (again sub)]) + + (synthesis.tuple members) + (synthesis.tuple (list#each again members)) + + (synthesis.variable var) + (|> mapping + (dictionary.value body) + (maybe.else var) + synthesis.variable) + + (synthesis.branch/case [inputS pathS]) + (synthesis.branch/case [(again inputS) (normalize_path again pathS)]) + + (synthesis.branch/exec [this that]) + (synthesis.branch/exec [(again this) (again that)]) + + (synthesis.branch/let [inputS register outputS]) + (synthesis.branch/let [(again inputS) register (again outputS)]) + + (synthesis.branch/if [testS thenS elseS]) + (synthesis.branch/if [(again testS) (again thenS) (again elseS)]) + + (synthesis.branch/get [path recordS]) + (synthesis.branch/get [path (again recordS)]) + + (synthesis.loop/scope [offset initsS+ bodyS]) + (synthesis.loop/scope [offset (list#each again initsS+) (again bodyS)]) + + (synthesis.loop/again updatesS+) + (synthesis.loop/again (list#each again updatesS+)) + + (synthesis.function/abstraction [environment arity bodyS]) + (synthesis.function/abstraction [(list#each (function (_ captured) + (case captured + (synthesis.variable var) + (|> mapping + (dictionary.value captured) + (maybe.else var) + synthesis.variable) + + _ + captured)) + environment) + arity + bodyS]) + + (synthesis.function/apply [functionS inputsS+]) + (synthesis.function/apply [(again functionS) (list#each again inputsS+)]) + + {synthesis.#Extension [name inputsS+]} + {synthesis.#Extension [name (list#each again inputsS+)]}))) + +(def $Object + (type.class "java.lang.Object" (list))) + +(def (anonymous_init_method env inputsTI) + (-> (Environment Synthesis) (List (Typed (Bytecode Any))) (Type category.Method)) + (type.method [(list) + (list.repeated (n.+ (list.size inputsTI) (list.size env)) ..$Object) + type.void + (list)])) + +(def (with_anonymous_init class env super_class inputsTG) + (-> (Type category.Class) (Environment Synthesis) (Type category.Class) (List (Typed (Bytecode Any))) (Resource Method)) + (let [inputs_offset (list.size inputsTG) + inputs! (|> inputsTG + list.enumeration + (list#each (function (_ [register [type term]]) + (let [then! (case (type.primitive? type) + {.#Right type} + (///value.unwrap type) + + {.#Left type} + (_.checkcast type))] + (all _.composite + (_.aload (++ register)) + then!)))) + list.reversed + (list#mix _.composite (_#in []))) + store_captured! (|> env + list.size + list.indices + (monad.each _.monad (.function (_ register) + (all _.composite + (_.aload 0) + (_.aload (n.+ inputs_offset (++ register))) + (_.putfield class (///reference.foreign_name register) $Object)))))] + (method.method method.public "<init>" + #1 (anonymous_init_method env inputsTG) + (list) + {.#Some (all _.composite + (_.aload 0) + inputs! + (_.invokespecial super_class "<init>" (type.method [(list) (list#each product.left inputsTG) type.void (list)])) + store_captured! + _.return)}))) + +(def (anonymous_instance generate archive class env inputsTI) + (-> Phase Archive (Type category.Class) (Environment Synthesis) (List (Typed (Bytecode Any))) (Operation (Bytecode Any))) + (do [! //////.monad] + [captureG+ (monad.each ! (generate archive) env)] + (in (all _.composite + (_.new class) + _.dup + (|> inputsTI + (list#each product.right) + list.reversed + (list#mix _.composite (_#in []))) + (monad.all _.monad captureG+) + (_.invokespecial class "<init>" (anonymous_init_method env inputsTI)))))) + +(def (returnG returnT) + (-> (Type Return) (Bytecode Any)) + (case (type.void? returnT) + {.#Right returnT} + _.return + + {.#Left returnT} + (case (type.primitive? returnT) + {.#Left returnT} + (case (type.class? returnT) + {.#Some class_name} + (all _.composite + (_.checkcast returnT) + _.areturn) + + {.#None} + _.areturn) + + {.#Right returnT} + (template.let [(unwrap_primitive <return> <type>) + [(all _.composite + (///value.unwrap <type>) + <return>)]] + (`` (cond (,, (with_template [<return> <type>] + [(at type.equivalence = <type> returnT) + (unwrap_primitive <return> <type>)] + + [_.ireturn type.boolean] + [_.ireturn type.byte] + [_.ireturn type.short] + [_.ireturn type.int] + [_.ireturn type.char] + [_.freturn type.float] + [_.lreturn type.long])) + + ... (at type.equivalence = type.double returnT) + (unwrap_primitive _.dreturn type.double))))))) + +(def (method_dependencies archive method) + (-> Archive (/.Overriden_Method Synthesis) (Operation (Set unit.ID))) + (let [[_super _name _strict_fp? _annotations + _t_vars _this _arguments _return _exceptions + bodyS] method] + (cache/artifact.dependencies archive bodyS))) + +(def (anonymous_dependencies archive inputsTS overriden_methods) + (-> Archive (List Input) (List [(Environment Synthesis) (/.Overriden_Method Synthesis)]) + (Operation (Set unit.ID))) + (do [! //////.monad] + [all_input_dependencies (monad.each ! (|>> product.right (cache/artifact.dependencies archive)) inputsTS) + all_closure_dependencies (|> overriden_methods + (list#each product.left) + list.together + (monad.each ! (cache/artifact.dependencies archive))) + all_method_dependencies (monad.each ! (|>> product.right (method_dependencies archive)) overriden_methods)] + (in (cache/artifact.all (all list#composite + all_input_dependencies + all_closure_dependencies + all_method_dependencies))))) + +(def (prepare_argument lux_register argumentT jvm_register) + (-> Register (Type Value) Register [Register (Bytecode Any)]) + (case (type.primitive? argumentT) + {.#Left argumentT} + [(n.+ 1 jvm_register) + (if (n.= lux_register jvm_register) + (_#in []) + (all _.composite + (_.aload jvm_register) + (_.astore lux_register)))] + + {.#Right argumentT} + (template.let [(wrap_primitive <shift> <load> <type>) + [[(n.+ <shift> jvm_register) + (all _.composite + (<load> jvm_register) + (///value.wrap <type>) + (_.astore lux_register))]]] + (`` (cond (,, (with_template [<shift> <load> <type>] + [(at type.equivalence = <type> argumentT) + (wrap_primitive <shift> <load> <type>)] + + [1 _.iload type.boolean] + [1 _.iload type.byte] + [1 _.iload type.short] + [1 _.iload type.int] + [1 _.iload type.char] + [1 _.fload type.float] + [2 _.lload type.long])) + + ... (at type.equivalence = type.double argumentT) + (wrap_primitive 2 _.dload type.double)))))) + +(def .public (prepare_arguments offset types) + (-> Nat (List (Type Value)) (Bytecode Any)) + (|> types + list.enumeration + (list#mix (function (_ [lux_register type] [jvm_register before]) + (let [[jvm_register' after] (prepare_argument (n.+ offset lux_register) type jvm_register)] + [jvm_register' + (all _.composite + before + after)])) + (is [Register (Bytecode Any)] + [offset + (_#in [])])) + product.right)) + +(def (normalized_method global_mapping [environment method]) + (-> Mapping [(Environment Synthesis) (/.Overriden_Method Synthesis)] + (/.Overriden_Method Synthesis)) + (let [[ownerT name strict_fp? annotations vars self_name arguments returnT exceptionsT body] method + local_mapping (|> environment + list.enumeration + (list#each (function (_ [foreign_id capture]) + [(synthesis.variable/foreign foreign_id) + (|> global_mapping + (dictionary.value capture) + maybe.trusted)])) + (dictionary.of_list synthesis.hash))] + [ownerT name + strict_fp? annotations vars + self_name arguments returnT exceptionsT + (normalize_method_body local_mapping body)])) + +(def (total_environment overriden_methods) + (-> (List [(Environment Synthesis) (/.Overriden_Method Synthesis)]) + (List Synthesis)) + (|> overriden_methods + ... Get all the environments. + (list#each product.left) + ... Combine them. + list#conjoint + ... Remove duplicates. + (set.of_list synthesis.hash) + set.list)) + +(def (global_mapping total_environment) + (-> (List Synthesis) Mapping) + (|> total_environment + ... Give them names as "foreign" variables. + list.enumeration + (list#each (function (_ [id capture]) + [capture {//////variable.#Foreign id}])) + (dictionary.of_list synthesis.hash))) + +(def (method_definition phase archive artifact_id method) + (-> Phase Archive artifact.ID (/.Overriden_Method Synthesis) (Operation (Resource Method))) + (let [[ownerT name strict_fp? annotations vars self_name arguments returnT exceptionsT bodyS] method] + (do //////.monad + [bodyG (//////generation.with_context artifact_id + (phase archive bodyS)) + .let [argumentsT (list#each product.right arguments) + methodT (type.method [vars argumentsT returnT exceptionsT])]] + (in (method.method (all modifier#composite + method.public + method.final + (if strict_fp? + method.strict + modifier#identity)) + name + #1 methodT + (list) + {.#Some (all _.composite + (prepare_arguments 1 argumentsT) + bodyG + (returnG returnT))}))))) + +(def class::anonymous + Handler + (..custom + [(all <>.and + ..class + (<synthesis>.tuple (<>.some ..class)) + (<synthesis>.tuple (<>.some ..input)) + (<synthesis>.tuple (<>.some ..overriden_method_definition))) + (function (_ extension_name generate archive [super_class + super_interfaces + inputsTS + overriden_methods]) + (do [! //////.monad] + [all_dependencies (anonymous_dependencies archive inputsTS overriden_methods) + [context _] (//////generation.with_new_context archive all_dependencies (in [])) + .let [[module_id artifact_id] context + anonymous_class_name (///runtime.class_name context) + class (type.class anonymous_class_name (list)) + total_environment (..total_environment overriden_methods) + global_mapping (..global_mapping total_environment)] + inputsTI (monad.each ! (generate_input generate archive) inputsTS) + methods! (|> overriden_methods + (list#each (normalized_method global_mapping)) + (monad.each ! (method_definition generate archive artifact_id))) + bytecode (<| (at ! each (\\format.result class.format)) + //////.lifted + (class.class version.v6_0 (all modifier#composite class.public class.final) + (name.internal anonymous_class_name) + {.#None} + (name.internal (..reflection super_class)) + (list#each (|>> ..reflection name.internal) super_interfaces) + (foreign.variables total_environment) + (list.partial (..with_anonymous_init class total_environment super_class inputsTI) + methods!) + (sequence.sequence))) + .let [artifact [anonymous_class_name bytecode]] + _ (//////generation.execute! artifact) + _ (//////generation.save! artifact_id {.#None} artifact)] + (anonymous_instance generate archive class total_environment inputsTI)))])) + +(def bundle::class + Bundle + (<| (/////bundle.prefix "class") + (|> (is Bundle /////bundle.empty) + (/////bundle.install "anonymous" class::anonymous) + ))) + +(def .public bundle + Bundle + (<| (/////bundle.prefix "jvm") + (|> ..bundle::conversion + (dictionary.composite ..bundle::int) + (dictionary.composite ..bundle::long) + (dictionary.composite ..bundle::float) + (dictionary.composite ..bundle::double) + (dictionary.composite ..bundle::char) + (dictionary.composite ..bundle::array) + (dictionary.composite ..bundle::object) + (dictionary.composite ..bundle::member) + (dictionary.composite ..bundle::class) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/lua.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/lua.lux new file mode 100644 index 000000000..35d3f07b8 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/lua.lux @@ -0,0 +1,18 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + ["[0]" / + ["[1][0]" common] + ["[1][0]" host] + [//// + [generation + [lua + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (dictionary.composite /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/lua/common.lux new file mode 100644 index 000000000..8fdfccda4 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/lua/common.lux @@ -0,0 +1,239 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function] + ["[0]" try]] + [data + ["[0]" product] + ["[0]" text + ["%" \\format (.only format)]] + [collection + ["[0]" dictionary] + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["f" frac]]] + [meta + [macro + ["^" pattern]] + ["@" target (.only) + ["_" lua (.only Expression Statement)]]]]] + ["[0]" //// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" lua + ["[1][0]" runtime (.only Operation Phase Phase! Handler Bundle Generator)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["[1][0]" function]]] + [// + ["[0]" generation] + ["[0]" synthesis (.only %synthesis) + ["<s>" \\parser (.only Parser)]] + [/// + ["[1]" phase (.use "[1]#[0]" monad)]]]]]) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.result parser input) + {try.#Success input'} + (handler extension_name phase archive input') + + {try.#Failure error} + (/////.except extension.invalid_syntax [extension_name %synthesis input])))) + +(def !unary + (template (_ function) + [(|>> list _.apply (|> (_.var function)))])) + +(def .public (statement expression archive synthesis) + Phase! + (case synthesis + ... TODO: Get rid of this ASAP + {synthesis.#Extension "lux syntax char case!" parameters} + (do /////.monad + [body (expression archive synthesis)] + (in (as Statement body))) + + (^.with_template [<tag>] + [(<tag> value) + (/////#each _.return (expression archive synthesis))]) + ([synthesis.bit] + [synthesis.i64] + [synthesis.f64] + [synthesis.text] + [synthesis.variant] + [synthesis.tuple] + [synthesis.branch/get] + [synthesis.function/apply]) + + (^.with_template [<tag>] + [{<tag> value} + (/////#each _.return (expression archive synthesis))]) + ([synthesis.#Reference] + [synthesis.#Extension]) + + (synthesis.branch/case case) + (//case.case! statement expression archive case) + + (synthesis.branch/exec it) + (//case.exec! statement expression archive it) + + (synthesis.branch/let let) + (//case.let! statement expression archive let) + + (synthesis.branch/if if) + (//case.if! statement expression archive if) + + (synthesis.loop/scope scope) + (do /////.monad + [[inits scope!] (//loop.scope! statement expression archive false scope)] + (in scope!)) + + (synthesis.loop/again updates) + (//loop.again! statement expression archive updates) + + (synthesis.function/abstraction abstraction) + (/////#each _.return (//function.function statement expression archive abstraction)) + )) + +... TODO: Get rid of this ASAP +(def lux::syntax_char_case! + (..custom [(all <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple (all <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (|> conditionals + (list#each (function (_ [chars branch]) + {synthesis.#Seq (case chars + {.#End} + {synthesis.#Pop} + + {.#Item head tail} + {synthesis.#I64_Fork + [head {synthesis.#Pop}] + (list#each (function (_ char) + [char {synthesis.#Pop}]) + tail)}) + {synthesis.#Then branch}})) + list.reversed + (list#mix (function (_ pre post) + {synthesis.#Alt pre post}) + {synthesis.#Then else}) + [input] + (//case.case! statement phase archive) + (at /////.monad each (|>> (as Expression)))))])) + +(def lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurried _.=))) + (/.install "try" (unary //runtime.lux//try)))) + +(def i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurried _.bit_and))) + (/.install "or" (binary (product.uncurried _.bit_or))) + (/.install "xor" (binary (product.uncurried _.bit_xor))) + (/.install "left-shift" (binary (product.uncurried //runtime.i64//left_shifted))) + (/.install "right-shift" (binary (product.uncurried //runtime.i64//right_shifted))) + (/.install "=" (binary (product.uncurried _.=))) + (/.install "+" (binary (product.uncurried _.+))) + (/.install "-" (binary (product.uncurried _.-))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "*" (binary (product.uncurried _.*))) + (/.install "/" (binary (product.uncurried //runtime.i64//division))) + (/.install "%" (binary (product.uncurried //runtime.i64//remainder))) + (/.install "f64" (unary (_./ (_.float +1.0)))) + (/.install "char" (unary (function (_ it) (_.apply (list it) (_.var "utf8.char"))))) + ))) + +(def f64//decode + (Unary Expression) + (|>> list _.apply (|> (_.var "tonumber")) _.return (_.closure (list)) //runtime.lux//try)) + +(def f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "+" (binary (product.uncurried _.+))) + (/.install "-" (binary (product.uncurried _.-))) + (/.install "*" (binary (product.uncurried _.*))) + (/.install "/" (binary (product.uncurried _./))) + (/.install "%" (binary (product.uncurried (function (_ parameter subject) (_.apply (list subject parameter) (_.var "math.fmod")))))) + (/.install "=" (binary (product.uncurried _.=))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "i64" (unary (!unary "math.floor"))) + (/.install "encode" (unary (function (_ it) (_.apply (list (_.string "%.17g") it) (_.var "string.format"))))) + (/.install "decode" (unary ..f64//decode))))) + +(def (text//char [paramO subjectO]) + (Binary Expression) + (//runtime.text//char (_.+ (_.int +1) paramO) subjectO)) + +(def (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip subjectO paramO extraO)) + +(def (text//index [startO partO textO]) + (Trinary Expression) + (//runtime.text//index textO partO startO)) + +(def text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurried _.=))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "concat" (binary (product.uncurried (function.flipped _.concat)))) + (/.install "index" (trinary ..text//index)) + (/.install "size" (unary //runtime.text//size)) + ... TODO: Use version below once the Lua compiler becomes self-hosted. + ... (/.install "size" (unary (for @.lua (!unary "utf8.len") + ... (!unary "string.len")))) + (/.install "char" (binary ..text//char)) + (/.install "clip" (trinary ..text//clip)) + ))) + +(def (io//log! messageO) + (Unary Expression) + (|> (_.apply (list messageO) (_.var "print")) + (_.or //runtime.unit))) + +(def io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary (!unary "error")))))) + +(def .public bundle + Bundle + (<| (/.prefix "lux") + (|> lux_procs + (dictionary.composite i64_procs) + (dictionary.composite f64_procs) + (dictionary.composite text_procs) + (dictionary.composite io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/lua/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/lua/host.lux new file mode 100644 index 000000000..603d2efb2 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/lua/host.lux @@ -0,0 +1,202 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + [collection + ["[0]" dictionary] + ["[0]" list]] + [text + ["%" \\format (.only format)]]] + [meta + [target + ["_" lua (.only Var Expression)]]]]] + ["[0]" // + ["[1][0]" common (.only custom)] + ["//[1]" /// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["[0]" reference] + ["//" lua + ["[1][0]" runtime (.only Operation Phase Handler Bundle + with_vars)]]] + ["/[1]" // + ["[0]" generation] + [synthesis + ["<s>" \\parser (.only Parser)]] + ["//[1]" /// + ["[1][0]" phase]]]]]]) + +(def array::new + (Unary Expression) + (|>> ["n"] list _.table)) + +(def array::length + (Unary Expression) + (_.the "n")) + +(def (array::read [indexG arrayG]) + (Binary Expression) + (_.item (_.+ (_.int +1) indexG) arrayG)) + +(def (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//write indexG _.nil arrayG)) + +(def array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def object::get + Handler + (custom + [(all <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (in (_.the fieldS objectG))))])) + +(def object::do + Handler + (custom + [(all <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do [! ////////phase.monad] + [objectG (phase archive objectS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.do methodS inputsG objectG))))])) + +(with_template [<!> <?> <unit>] + [(def <!> (Nullary Expression) (function.constant <unit>)) + (def <?> (Unary Expression) (_.= <unit>))] + + [object::nil object::nil? _.nil] + ) + +(def object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "nil" (nullary object::nil)) + (/.install "nil?" (unary object::nil?)) + ))) + +(def $input + (_.var "input")) + +(def utf8::encode + (custom + [<s>.any + (function (_ extension phase archive inputS) + (do [! ////////phase.monad] + [inputG (phase archive inputS)] + (in (<| (_.apply (list inputG)) + (_.closure (list $input)) + (_.return (_.apply (list (_.apply (list $input (_.int +1) (_.length $input)) + (_.var "string.byte"))) + (_.var "table.pack")))))))])) + +(def utf8::decode + (custom + [<s>.any + (function (_ extension phase archive inputS) + (do [! ////////phase.monad] + [inputG (phase archive inputS)] + (in (_.apply (list (_.apply (list inputG) + (_.var "table.unpack"))) + (_.var "string.char")))))])) + +(def utf8 + Bundle + (<| (/.prefix "utf8") + (|> /.empty + (/.install "encode" utf8::encode) + (/.install "decode" utf8::decode) + ))) + +(def lua::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (at ////////phase.monad in (_.var name)))])) + +(def lua::apply + (custom + [(all <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do [! ////////phase.monad] + [abstractionG (phase archive abstractionS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.apply inputsG abstractionG))))])) + +(def lua::power + (custom + [(all <>.and <s>.any <s>.any) + (function (_ extension phase archive [powerS baseS]) + (do [! ////////phase.monad] + [powerG (phase archive powerS) + baseG (phase archive baseS)] + (in (_.^ powerG baseG))))])) + +(def lua::import + (custom + [<s>.text + (function (_ extension phase archive module) + (at ////////phase.monad in + (_.require/1 (_.string module))))])) + +(def lua::function + (custom + [(all <>.and <s>.i64 <s>.any) + (function (_ extension phase archive [arity abstractionS]) + (do [! ////////phase.monad] + [abstractionG (phase archive abstractionS) + .let [variable (is (-> Text (Operation Var)) + (|>> generation.symbol + (at ! each _.var)))] + g!inputs (monad.each ! (function (_ _) + (variable "input")) + (list.repeated (.nat arity) []))] + (in (<| (_.closure g!inputs) + _.return + (case (.nat arity) + 0 (_.apply (list //runtime.unit) abstractionG) + 1 (_.apply g!inputs abstractionG) + _ (_.apply (list (_.array g!inputs)) abstractionG))))))])) + +(def .public bundle + Bundle + (<| (/.prefix "lua") + (|> /.empty + (dictionary.composite ..array) + (dictionary.composite ..object) + (dictionary.composite ..utf8) + + (/.install "constant" lua::constant) + (/.install "apply" lua::apply) + (/.install "power" lua::power) + (/.install "import" lua::import) + (/.install "function" lua::function) + (/.install "script universe" (nullary (function.constant (_.boolean reference.universe)))) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/php.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/php.lux new file mode 100644 index 000000000..2a76ad856 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/php.lux @@ -0,0 +1,18 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + ["[0]" / + ["[1][0]" common] + ["[1][0]" host] + [//// + [generation + [php + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (dictionary.composite /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/php/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/php/common.lux new file mode 100644 index 000000000..8fcabe6e4 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/php/common.lux @@ -0,0 +1,194 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function] + ["[0]" try]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" dictionary] + ["[0]" set] + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["f" frac]]] + [meta + ["@" target (.only) + ["_" php (.only Expression)]]]]] + ["[0]" //// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["[0]" reference] + ["//" php + ["[1][0]" runtime (.only Operation Phase Handler Bundle Generator)] + ["[1][0]" case]]] + [// + ["[0]" synthesis (.only %synthesis) + ["<s>" \\parser (.only Parser)]] + ["[0]" generation] + [/// + ["[1]" phase]]]]]) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.result parser input) + {try.#Success input'} + (handler extension_name phase archive input') + + {try.#Failure error} + (/////.except extension.invalid_syntax [extension_name %synthesis input])))) + +(def !unary + (template (_ function) + (|>> list _.apply (|> (_.constant function))))) + +... TODO: Get rid of this ASAP +(def lux::syntax_char_case! + (..custom [(all <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple (all <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do [! /////.monad] + [inputG (phase archive input) + [[context_module context_artifact] elseG] (generation.with_new_context archive + (phase archive else)) + @input (at ! each _.var (generation.symbol "input")) + conditionalsG (is (Operation (List [Expression Expression])) + (monad.each ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch)] + (in [(|> chars + (list#each (|>> .int _.int (_.=== @input))) + (list#mix (function (_ clause total) + (if (same? _.null total) + clause + (_.or clause total))) + _.null)) + branchG]))) + conditionals)) + .let [foreigns (|> conditionals + (list#each (|>> product.right synthesis.path/then //case.dependencies)) + (list.partial (//case.dependencies (synthesis.path/then else))) + list.together + (set.of_list _.hash) + set.list) + @expression (_.constant (reference.artifact [context_module context_artifact])) + declaration (_.define_function @expression (list.partial (_.parameter @input) (list#each _.reference foreigns)) + (list#mix (function (_ [test then] else) + (_.if test (_.return then) else)) + (_.return elseG) + conditionalsG))] + _ (generation.execute! declaration) + _ (generation.save! context_artifact declaration)] + (in (_.apply (list.partial inputG foreigns) @expression))))])) + +(def lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurried _.===))) + (/.install "try" (unary //runtime.lux//try)) + )) + +(def (left_shifted [parameter subject]) + (Binary Expression) + (_.bit_shl (_.% (_.int +64) parameter) subject)) + +(def i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurried _.bit_and))) + (/.install "or" (binary (product.uncurried _.bit_or))) + (/.install "xor" (binary (product.uncurried _.bit_xor))) + (/.install "left-shift" (binary ..left_shifted)) + (/.install "right-shift" (binary (product.uncurried //runtime.i64//right_shifted))) + (/.install "=" (binary (product.uncurried _.==))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "+" (binary (product.uncurried //runtime.i64//+))) + (/.install "-" (binary (product.uncurried //runtime.i64//-))) + (/.install "*" (binary (product.uncurried //runtime.i64//*))) + (/.install "/" (binary (function (_ [parameter subject]) + (_.intdiv/2 [subject parameter])))) + (/.install "%" (binary (product.uncurried _.%))) + (/.install "f64" (unary (_./ (_.float +1.0)))) + (/.install "char" (unary //runtime.i64//char)) + ))) + +(def (f64//% [parameter subject]) + (Binary Expression) + (_.fmod/2 [subject parameter])) + +(def (f64//encode subject) + (Unary Expression) + (_.number_format/2 [subject (_.int +17)])) + +(def f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "=" (binary (product.uncurried _.==))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "+" (binary (product.uncurried _.+))) + (/.install "-" (binary (product.uncurried _.-))) + (/.install "*" (binary (product.uncurried _.*))) + (/.install "/" (binary (product.uncurried _./))) + (/.install "%" (binary ..f64//%)) + (/.install "i64" (unary _.intval/1)) + (/.install "encode" (unary ..f64//encode)) + (/.install "decode" (unary //runtime.f64//decode))))) + +(def (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip paramO extraO subjectO)) + +(def (text//index [startO partO textO]) + (Trinary Expression) + (//runtime.text//index textO partO startO)) + +(def text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurried _.==))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "concat" (binary (product.uncurried (function.flipped _.concat)))) + (/.install "index" (trinary ..text//index)) + (/.install "size" (unary //runtime.text//size)) + (/.install "char" (binary (product.uncurried //runtime.text//char))) + (/.install "clip" (trinary ..text//clip)) + ))) + +(def io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary //runtime.io//log!)) + (/.install "error" (unary //runtime.io//throw!))))) + +(def .public bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + (dictionary.composite lux_procs) + (dictionary.composite i64_procs) + (dictionary.composite f64_procs) + (dictionary.composite text_procs) + (dictionary.composite io_procs)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/php/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/php/host.lux new file mode 100644 index 000000000..855f5754d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/php/host.lux @@ -0,0 +1,145 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + [collection + ["[0]" dictionary] + ["[0]" list]] + [text + ["%" \\format (.only format)]]] + [meta + [target + ["_" php (.only Var Expression)]]]]] + ["[0]" // + ["[1][0]" common (.only custom)] + ["//[1]" /// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["[0]" reference] + ["//" php + ["[1][0]" runtime (.only Operation Phase Handler Bundle + with_vars)]]] + ["/[1]" // + ["[0]" generation] + [synthesis + ["<s>" \\parser (.only Parser)]] + ["//[1]" /// + ["[1][0]" phase]]]]]]) + +(def (array::new size) + (Unary Expression) + (//runtime.tuple//make size (_.array_fill/3 [(_.int +0) size _.null]))) + +(def (array::read [indexG arrayG]) + (Binary Expression) + (_.item indexG arrayG)) + +(def (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//write indexG _.null arrayG)) + +(def array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary //runtime.array//length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def object::new + (custom + [(all <>.and <s>.text (<>.some <s>.any)) + (function (_ extension phase archive [constructor inputsS]) + (do [! ////////phase.monad] + [inputsG (monad.each ! (phase archive) inputsS)] + (in (_.new (_.constant constructor) inputsG))))])) + +(def object::get + Handler + (custom + [(all <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (in (_.the fieldS objectG))))])) + +(def object::do + Handler + (custom + [(all <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do [! ////////phase.monad] + [objectG (phase archive objectS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.do methodS inputsG objectG))))])) + +(with_template [<!> <?> <unit>] + [(def <!> (Nullary Expression) (function.constant <unit>)) + (def <?> (Unary Expression) (_.=== <unit>))] + + [object::null object::null? _.null] + ) + +(def object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "new" object::new) + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "null" (nullary object::null)) + (/.install "null?" (unary object::null?)) + ))) + +(def php::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (at ////////phase.monad in (_.constant name)))])) + +(def php::apply + (custom + [(all <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do [! ////////phase.monad] + [abstractionG (phase archive abstractionS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.apply inputsG abstractionG))))])) + +(def php::pack + (custom + [(all <>.and <s>.any <s>.any) + (function (_ extension phase archive [formatS dataS]) + (do [! ////////phase.monad] + [formatG (phase archive formatS) + dataG (phase archive dataS)] + (in (_.pack/2 [formatG (_.splat dataG)]))))])) + +(def .public bundle + Bundle + (<| (/.prefix "php") + (|> /.empty + (dictionary.composite ..array) + (dictionary.composite ..object) + + (/.install "constant" php::constant) + (/.install "apply" php::apply) + (/.install "pack" php::pack) + (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/python.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/python.lux new file mode 100644 index 000000000..8adf1ec86 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/python.lux @@ -0,0 +1,18 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + ["[0]" / + ["[1][0]" common] + ["[1][0]" host] + [//// + [generation + [python + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (dictionary.composite /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/python/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/python/common.lux new file mode 100644 index 000000000..b4a6a8f0c --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/python/common.lux @@ -0,0 +1,246 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function] + ["[0]" try]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" dictionary] + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["f" frac]]] + [meta + [macro + ["^" pattern]] + [target + ["_" python (.only Expression Statement)]]]]] + ["[0]" //// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + ["[0]" reference] + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" python + ["[1][0]" runtime (.only Operation Phase Phase! Handler Bundle Generator)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" function] + ["[1][0]" case] + ["[1][0]" loop]]] + [// + [analysis (.only)] + ["[0]" generation] + ["[0]" synthesis (.only %synthesis) + ["<[1]>" \\parser (.only Parser)]] + [/// + ["[1]" phase (.use "[1]#[0]" monad)]]]]]) + +(def .public (statement expression archive synthesis) + Phase! + (case synthesis + ... TODO: Get rid of this ASAP + {synthesis.#Extension "lux syntax char case!" parameters} + (do /////.monad + [body (expression archive synthesis)] + (in (as (Statement Any) body))) + + (^.with_template [<tag>] + [(<tag> value) + (/////#each _.return (expression archive synthesis))]) + ([synthesis.bit] + [synthesis.i64] + [synthesis.f64] + [synthesis.text] + [synthesis.variant] + [synthesis.tuple] + [synthesis.branch/get] + [synthesis.function/apply]) + + (^.with_template [<tag>] + [{<tag> value} + (/////#each _.return (expression archive synthesis))]) + ([synthesis.#Reference] + [synthesis.#Extension]) + + (synthesis.branch/case case) + (//case.case! false statement expression archive case) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> statement expression archive value)]) + ([synthesis.branch/exec //case.exec!] + [synthesis.branch/let //case.let!] + [synthesis.branch/if //case.if!] + [synthesis.loop/scope //loop.scope!] + [synthesis.loop/again //loop.again!]) + + (synthesis.function/abstraction abstraction) + (/////#each _.return (//function.function statement expression archive abstraction)) + )) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<synthesis>.result parser input) + {try.#Success input'} + (handler extension_name phase archive input') + + {try.#Failure error} + (/////.except extension.invalid_syntax [extension_name %synthesis input])))) + +... TODO: Get rid of this ASAP +(def lux::syntax_char_case! + (..custom [(all <>.and + <synthesis>.any + <synthesis>.any + (<>.some (<synthesis>.tuple (all <>.and + (<synthesis>.tuple (<>.many <synthesis>.i64)) + <synthesis>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do [! /////.monad] + [inputG (phase archive input) + else! (..statement phase archive else) + @input (at ! each _.var (generation.symbol "input")) + conditionals! (is (Operation (List [(Expression Any) + (Statement Any)])) + (monad.each ! (function (_ [chars branch]) + (do ! + [branch! (..statement phase archive branch)] + (in [(|> chars + (list#each (|>> .int _.int (_.= @input))) + (list#mix (function (_ clause total) + (if (same? _.none total) + clause + (_.or clause total))) + _.none)) + branch!]))) + conditionals)) + ... .let [dependencies (//case.dependencies (list#mix (function (_ right left) + ... (synthesis.path/seq left right)) + ... (synthesis.path/then input) + ... {.#Item (synthesis.path/then else) + ... (list#each (|>> product.right + ... synthesis.path/then) + ... conditionals)})) + ... @closure (_.var (reference.artifact artifact_id)) + ... closure (_.def @closure dependencies + ... (all _.then + ... (_.set (list @input) inputG) + ... (list#mix (function (_ [test then!] else!) + ... (_.if test then! else!)) + ... else! + ... conditionals!)))] + ... _ (generation.execute! closure) + ... _ (generation.save! (product.right artifact_id) {.#None} closure) + ] + ... (in (_.apply @closure dependencies)) + (in (<| (as (Expression Any)) + (is (Statement Any)) + (all _.then + (_.set (list @input) inputG) + (list#mix (function (_ [test then!] else!) + (_.if test then! else!)) + else! + conditionals!))))))])) + +(def lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurried _.is))) + (/.install "try" (unary //runtime.lux::try)))) + +(def (capped operation parameter subject) + (-> (-> (Expression Any) (Expression Any) (Expression Any)) + (-> (Expression Any) (Expression Any) (Expression Any))) + (//runtime.i64::64 (operation parameter subject))) + +(def i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurried //runtime.i64::and))) + (/.install "or" (binary (product.uncurried //runtime.i64::or))) + (/.install "xor" (binary (product.uncurried //runtime.i64::xor))) + (/.install "left-shift" (binary (product.uncurried //runtime.i64::left_shifted))) + (/.install "right-shift" (binary (product.uncurried //runtime.i64::right_shifted))) + + (/.install "<" (binary (product.uncurried _.<))) + (/.install "=" (binary (product.uncurried _.=))) + (/.install "+" (binary (product.uncurried (..capped _.+)))) + (/.install "-" (binary (product.uncurried (..capped _.-)))) + (/.install "*" (binary (product.uncurried (..capped _.*)))) + (/.install "/" (binary (product.uncurried //runtime.i64#/))) + (/.install "%" (binary (product.uncurried //runtime.i64::remainder))) + (/.install "f64" (unary _.float/1)) + (/.install "char" (unary //runtime.i64::char)) + ))) + +(def f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "+" (binary (product.uncurried _.+))) + (/.install "-" (binary (product.uncurried _.-))) + (/.install "*" (binary (product.uncurried _.*))) + (/.install "/" (binary (product.uncurried //runtime.f64::/))) + (/.install "%" (binary (function (_ [parameter subject]) + (|> (_.__import__/1 (_.unicode "math")) + (_.do "fmod" (list subject parameter)))))) + (/.install "=" (binary (product.uncurried _.=))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "i64" (unary _.int/1)) + (/.install "encode" (unary _.repr/1)) + (/.install "decode" (unary //runtime.f64::decode))))) + +(def (text::clip [paramO extraO subjectO]) + (Trinary (Expression Any)) + (//runtime.text::clip paramO extraO subjectO)) + +(def (text::index [startO partO textO]) + (Trinary (Expression Any)) + (//runtime.text::index startO partO textO)) + +(def text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurried _.=))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "concat" (binary (product.uncurried (function.flipped _.+)))) + (/.install "index" (trinary ..text::index)) + (/.install "size" (unary _.len/1)) + (/.install "char" (binary (product.uncurried //runtime.text::char))) + (/.install "clip" (trinary ..text::clip)) + ))) + +(def io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary //runtime.io::log!)) + (/.install "error" (unary //runtime.io::throw!))))) + +(def .public bundle + Bundle + (<| (/.prefix "lux") + (|> lux_procs + (dictionary.composite i64_procs) + (dictionary.composite f64_procs) + (dictionary.composite text_procs) + (dictionary.composite io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/python/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/python/host.lux new file mode 100644 index 000000000..3354e69db --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/python/host.lux @@ -0,0 +1,169 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + ["[0]" text (.only) + ["%" \\format]] + [collection + ["[0]" dictionary] + ["[0]" list]]] + [meta + [target + ["_" python (.only Expression SVar)]]]]] + ["[0]" // + ["[1][0]" common (.only custom)] + ["//[1]" /// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" python + ["[1][0]" runtime (.only Operation Phase Handler Bundle + with_vars)]]] + ["/[1]" // + ["[0]" generation] + [synthesis + ["<s>" \\parser (.only Parser)]] + ["//[1]" /// + ["[1][0]" phase]]]]]]) + +(def (array::new size) + (Unary (Expression Any)) + (|> (list _.none) + _.list + (_.* size))) + +(def array::length + (Unary (Expression Any)) + (|>> _.len/1 //runtime.i64::64)) + +(def (array::read [indexG arrayG]) + (Binary (Expression Any)) + (_.item indexG arrayG)) + +(def (array::write [indexG valueG arrayG]) + (Trinary (Expression Any)) + (//runtime.array::write indexG valueG arrayG)) + +(def (array::delete [indexG arrayG]) + (Binary (Expression Any)) + (//runtime.array::write indexG _.none arrayG)) + +(def array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def object::get + Handler + (custom + [(all <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (in (_.the fieldS objectG))))])) + +(def object::do + Handler + (custom + [(all <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do [! ////////phase.monad] + [objectG (phase archive objectS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.do methodS inputsG objectG))))])) + +(with_template [<!> <?> <unit>] + [(def <!> (Nullary (Expression Any)) (function.constant <unit>)) + (def <?> (Unary (Expression Any)) (_.= <unit>))] + + [object::none object::none? _.none] + ) + +(def object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "none" (nullary object::none)) + (/.install "none?" (unary object::none?)) + ))) + +(def python::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (do ////////phase.monad + [] + (in (_.var name))))])) + +(def python::import + (custom + [<s>.text + (function (_ extension phase archive module) + (do ////////phase.monad + [] + (in (_.apply (list (_.string module)) (_.var "__import__")))))])) + +(def python::apply + (custom + [(all <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do [! ////////phase.monad] + [abstractionG (phase archive abstractionS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.apply inputsG abstractionG))))])) + +(def python::function + (custom + [(all <>.and <s>.i64 <s>.any) + (function (_ extension phase archive [arity abstractionS]) + (do [! ////////phase.monad] + [abstractionG (phase archive abstractionS) + .let [variable (is (-> Text (Operation SVar)) + (|>> generation.symbol + (at ! each _.var)))] + g!inputs (monad.each ! (function (_ _) (variable "input")) + (list.repeated (.nat arity) []))] + (in (_.lambda g!inputs + (case (.nat arity) + 0 (_.apply (list //runtime.unit) abstractionG) + 1 (_.apply g!inputs abstractionG) + _ (_.apply (list (_.list g!inputs)) abstractionG))))))])) + +(def python::exec + (custom + [(all <>.and <s>.any <s>.any) + (function (_ extension phase archive [codeS globalsS]) + (do [! ////////phase.monad] + [codeG (phase archive codeS) + globalsG (phase archive globalsS)] + (in (//runtime.lux::exec codeG globalsG))))])) + +(def .public bundle + Bundle + (<| (/.prefix "python") + (|> /.empty + (dictionary.composite ..array) + (dictionary.composite ..object) + + (/.install "constant" python::constant) + (/.install "import" python::import) + (/.install "apply" python::apply) + (/.install "function" python::function) + (/.install "exec" python::exec) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/r.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/r.lux new file mode 100644 index 000000000..1a9b58970 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/r.lux @@ -0,0 +1,18 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + ["[0]" / + ["[1][0]" common] + ["[1][0]" host] + [//// + [generation + [r + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (dictionary.composite /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/r/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/r/common.lux new file mode 100644 index 000000000..b2dbae1f3 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/r/common.lux @@ -0,0 +1,181 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function] + ["[0]" try]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" dictionary] + ["[0]" set] + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["f" frac]]] + [meta + ["@" target (.only) + ["_" r (.only Expression)]]]]] + ["[0]" //// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["[0]" reference] + ["//" r + ["[1][0]" runtime (.only Operation Phase Handler Bundle Generator)] + ["[1][0]" case]]] + [// + ["[0]" synthesis (.only %synthesis) + ["<s>" \\parser (.only Parser)]] + ["[0]" generation] + [/// + ["[1]" phase]]]]]) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.result parser input) + {try.#Success input'} + (handler extension_name phase archive input') + + {try.#Failure error} + (/////.except extension.invalid_syntax [extension_name %synthesis input])))) + +... (def !unary +... (template (_ function) +... (|>> list _.apply (|> (_.constant function))))) + +... ... ... TODO: Get rid of this ASAP +... ... (def lux::syntax_char_case! +... ... (..custom [(all <>.and +... ... <s>.any +... ... <s>.any +... ... (<>.some (<s>.tuple (all <>.and +... ... (<s>.tuple (<>.many <s>.i64)) +... ... <s>.any)))) +... ... (function (_ extension_name phase archive [input else conditionals]) +... ... (do [! /////.monad] +... ... [@input (at ! each _.var (generation.symbol "input")) +... ... inputG (phase archive input) +... ... elseG (phase archive else) +... ... conditionalsG (is (Operation (List [Expression Expression])) +... ... (monad.each ! (function (_ [chars branch]) +... ... (do ! +... ... [branchG (phase archive branch)] +... ... (in [(|> chars (list#each (|>> .int _.int (_.=/2 @input))) _.or) +... ... branchG]))) +... ... conditionals))] +... ... (in (_.let (list [@input inputG]) +... ... (list (list#mix (function (_ [test then] else) +... ... (_.if test then else)) +... ... elseG +... ... conditionalsG))))))])) + +... (def lux_procs +... Bundle +... (|> /.empty +... ... (/.install "syntax char case!" lux::syntax_char_case!) +... (/.install "is" (binary _.eq/2)) +... ... (/.install "try" (unary //runtime.lux//try)) +... )) + +... ... (def (capped operation parameter subject) +... ... (-> (-> Expression Expression Expression) +... ... (-> Expression Expression Expression)) +... ... (//runtime.i64//64 (operation parameter subject))) + +(def i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + ... (/.install "and" (binary _.logand/2)) + ... (/.install "or" (binary _.logior/2)) + ... (/.install "xor" (binary _.logxor/2)) + ... (/.install "left-shift" (binary _.ash/2)) + ... (/.install "right-shift" (binary (product.uncurried //runtime.i64//right_shift))) + ... (/.install "=" (binary _.=/2)) + ... (/.install "<" (binary _.</2)) + ... (/.install "+" (binary _.+/2)) + ... (/.install "-" (binary _.-/2)) + ... (/.install "*" (binary _.*/2)) + ... (/.install "/" (binary _.floor/2)) + ... (/.install "%" (binary _.rem/2)) + ... (/.install "f64" (unary (_.//2 (_.float +1.0)))) + (/.install "char" (unary (|>> //runtime.i64_low _.intToUtf8/1))) + ))) + +... (def f64_procs +... Bundle +... (<| (/.prefix "f64") +... (|> /.empty +... ... (/.install "=" (binary (product.uncurried _.=/2))) +... ... (/.install "<" (binary (product.uncurried _.</2))) +... ... (/.install "+" (binary (product.uncurried _.+/2))) +... ... (/.install "-" (binary (product.uncurried _.-/2))) +... ... (/.install "*" (binary (product.uncurried _.*/2))) +... ... (/.install "/" (binary (product.uncurried _.//2))) +... ... (/.install "%" (binary (product.uncurried _.rem/2))) +... ... (/.install "i64" (unary _.truncate/1)) +... (/.install "encode" (unary _.write_to_string/1)) +... ... (/.install "decode" (unary //runtime.f64//decode)) +... ))) + +... (def (text//index [offset sub text]) +... (Trinary (Expression Any)) +... (//runtime.text//index offset sub text)) + +... (def (text//clip [offset length text]) +... (Trinary (Expression Any)) +... (//runtime.text//clip offset length text)) + +... (def (text//char [index text]) +... (Binary (Expression Any)) +... (_.char_code/1 (_.char/2 [text index]))) + +(def text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + ... (/.install "=" (binary _.string=/2)) + ... (/.install "<" (binary (product.uncurried _.string<?/2))) + (/.install "concat" (binary _.paste/2)) + ... (/.install "index" (trinary ..text//index)) + ... (/.install "size" (unary _.length/1)) + ... (/.install "char" (binary ..text//char)) + ... (/.install "clip" (trinary ..text//clip)) + ))) + +... (def (io//log! message) +... (Unary (Expression Any)) +... (_.progn (list (_.write_line/1 message) +... //runtime.unit))) + +... (def io_procs +... Bundle +... (<| (/.prefix "io") +... (|> /.empty +... (/.install "log" (unary ..io//log!)) +... (/.install "error" (unary _.error/1)) +... ))) + +(def .public bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + ... (dictionary.composite lux_procs) + (dictionary.composite i64_procs) + ... (dictionary.composite f64_procs) + (dictionary.composite text_procs) + ... (dictionary.composite io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/r/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/r/host.lux new file mode 100644 index 000000000..31a2e612f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/r/host.lux @@ -0,0 +1,42 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + [collection + ["[0]" dictionary] + ["[0]" list]] + [text + ["%" \\format (.only format)]]] + [meta + [target + ["_" r (.only Var Expression)]]]]] + ["[0]" // + ["[1][0]" common (.only custom)] + ["//[1]" /// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["[0]" reference] + ["//" r + ["[1][0]" runtime (.only Operation Phase Handler Bundle + with_vars)]]] + ["/[1]" // + ["[0]" generation] + [synthesis + ["<s>" \\parser (.only Parser)]] + ["//[1]" /// + ["[1][0]" phase]]]]]]) + +(def .public bundle + Bundle + (<| (/.prefix "r") + (|> /.empty + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/ruby.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/ruby.lux new file mode 100644 index 000000000..3852ff8b4 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/ruby.lux @@ -0,0 +1,18 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + ["[0]" / + ["[1][0]" common] + ["[1][0]" host] + [//// + [generation + [ruby + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (dictionary.composite /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/ruby/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/ruby/common.lux new file mode 100644 index 000000000..dca8af12f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/ruby/common.lux @@ -0,0 +1,243 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function] + ["[0]" try]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" dictionary] + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["f" frac]]] + [meta + [macro + ["^" pattern]] + [target + ["_" ruby (.only Expression Statement)]]]]] + ["[0]" //// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["//" ruby + ["[1][0]" runtime (.only Operation Phase Phase! Handler Bundle Generator)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" function] + ["[1][0]" case] + ["[1][0]" loop]]] + [// + ["[0]" generation] + ["[0]" synthesis (.only %synthesis) + ["<s>" \\parser (.only Parser)]] + [/// + ["[1]" phase (.use "[1]#[0]" monad)]]]]]) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.result parser input) + {try.#Success input'} + (handler extension_name phase archive input') + + {try.#Failure error} + (/////.except extension.invalid_syntax [extension_name %synthesis input])))) + +(def .public (statement expression archive synthesis) + Phase! + (case synthesis + ... TODO: Get rid of this ASAP + {synthesis.#Extension "lux syntax char case!" parameters} + (do /////.monad + [body (expression archive synthesis)] + (in (as Statement + body))) + + (^.with_template [<tag>] + [(<tag> value) + (/////#each _.return (expression archive synthesis))]) + ([synthesis.bit] + [synthesis.i64] + [synthesis.f64] + [synthesis.text] + [synthesis.variant] + [synthesis.tuple] + [synthesis.branch/get] + [synthesis.function/apply]) + + (^.with_template [<tag>] + [{<tag> value} + (/////#each _.return (expression archive synthesis))]) + ([synthesis.#Reference] + [synthesis.#Extension]) + + (synthesis.branch/case case) + (//case.case! false statement expression archive case) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> statement expression archive value)]) + ([synthesis.branch/exec //case.exec!] + [synthesis.branch/let //case.let!] + [synthesis.branch/if //case.if!] + [synthesis.loop/scope //loop.scope!] + [synthesis.loop/again //loop.again!]) + + (synthesis.function/abstraction abstraction) + (/////#each _.return (//function.function statement expression archive abstraction)) + )) + +... TODO: Get rid of this ASAP +(def lux::syntax_char_case! + (..custom [(all <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple (all <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do [! /////.monad] + [inputG (phase archive input) + else! (statement phase archive else) + @input (at ! each _.local (generation.symbol "input")) + conditionals! (is (Operation (List [Expression Statement])) + (monad.each ! (function (_ [chars branch]) + (do ! + [branch! (statement phase archive branch)] + (in [(|> chars + (list#each (|>> .int _.int (_.= @input))) + (list#mix (function (_ clause total) + (if (same? _.nil total) + clause + (_.or clause total))) + _.nil)) + branch!]))) + conditionals)) + ... .let [closure (_.lambda {.#None} (list @input) + ... (list#mix (function (_ [test then] else) + ... (_.if test (_.return then) else)) + ... (_.return else!) + ... conditionals!))] + ] + ... (in (_.apply_lambda (list inputG) closure)) + (in (<| (as Expression) + (is Statement) + (all _.then + (_.set (list @input) inputG) + (list#mix (function (_ [test then!] else!) + (_.if test then! else!)) + else! + conditionals!))))))])) + +(def lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (function (_ [reference subject]) + (_.do "equal?" (list reference) {.#None} subject)))) + (/.install "try" (unary //runtime.lux//try)))) + +(def i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurried //runtime.i64::and))) + (/.install "or" (binary (product.uncurried //runtime.i64::or))) + (/.install "xor" (binary (product.uncurried //runtime.i64::xor))) + (/.install "left-shift" (binary (product.uncurried //runtime.i64::left_shifted))) + (/.install "right-shift" (binary (product.uncurried //runtime.i64::right_shifted))) + + (/.install "<" (binary (product.uncurried _.<))) + (/.install "=" (binary (product.uncurried _.=))) + (/.install "+" (binary (product.uncurried //runtime.i64::+))) + (/.install "-" (binary (product.uncurried //runtime.i64::-))) + (/.install "*" (binary (product.uncurried //runtime.i64::*))) + (/.install "/" (binary (product.uncurried //runtime.i64::/))) + (/.install "%" (binary (function (_ [parameter subject]) + (_.do "remainder" (list parameter) {.#None} subject)))) + + (/.install "f64" (unary (_./ (_.float +1.0)))) + (/.install "char" (unary //runtime.i64::char)) + ))) + +(def f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "+" (binary (product.uncurried _.+))) + (/.install "-" (binary (product.uncurried _.-))) + (/.install "*" (binary (product.uncurried _.*))) + (/.install "/" (binary (product.uncurried _./))) + (/.install "%" (binary (function (_ [parameter subject]) + (_.do "remainder" (list parameter) {.#None} subject)))) + (/.install "=" (binary (product.uncurried _.=))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "i64" (unary (_.do "floor" (list) {.#None}))) + (/.install "encode" (unary (_.do "to_s" (list) {.#None}))) + (/.install "decode" (unary //runtime.f64//decode))))) + +(def (text//char [subjectO paramO]) + (Binary Expression) + (//runtime.text//char subjectO paramO)) + +(def (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip paramO extraO subjectO)) + +(def (text//index [startO partO textO]) + (Trinary Expression) + (//runtime.text//index textO partO startO)) + +(def text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurried _.=))) + (/.install "<" (binary (product.uncurried _.<))) + (/.install "concat" (binary (product.uncurried (function.flipped _.+)))) + (/.install "index" (trinary text//index)) + (/.install "size" (unary (_.the "length"))) + (/.install "char" (binary (product.uncurried //runtime.text//char))) + (/.install "clip" (trinary text//clip)) + ))) + +(def (io//log! messageG) + (Unary Expression) + (|> (_.print/2 messageG (_.string text.new_line)) + (_.or //runtime.unit))) + +(def io//error! + (Unary Expression) + _.raise) + +(def io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary ..io//error!)) + ))) + +(def .public bundle + Bundle + (<| (/.prefix "lux") + (|> lux_procs + (dictionary.composite ..i64_procs) + (dictionary.composite ..f64_procs) + (dictionary.composite ..text_procs) + (dictionary.composite ..io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/ruby/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/ruby/host.lux new file mode 100644 index 000000000..bbff556ec --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/ruby/host.lux @@ -0,0 +1,138 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + [collection + ["[0]" dictionary] + ["[0]" list]] + [text + ["%" \\format (.only format)]]] + [meta + [target + ["_" ruby (.only Var Expression)]]]]] + ["[0]" // + ["[1][0]" common (.only custom)] + ["//[1]" /// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["[0]" reference] + ["//" ruby + ["[1][0]" runtime (.only Operation Phase Handler Bundle + with_vars)]]] + ["/[1]" // + ["[0]" generation] + [synthesis + ["<s>" \\parser (.only Parser)]] + ["//[1]" /// + ["[1][0]" phase]]]]]]) + +(def (array::new [size]) + (Unary Expression) + (_.do "new" (list size) {.#None} (is _.CVar (_.manual "Array")))) + +(def array::length + (Unary Expression) + (_.the "size")) + +(def (array::read [indexG arrayG]) + (Binary Expression) + (_.item indexG arrayG)) + +(def (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//write indexG _.nil arrayG)) + +(def array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(def object::get + Handler + (custom + [(all <>.and <s>.text <s>.any) + (function (_ extension phase archive [fieldS objectS]) + (do ////////phase.monad + [objectG (phase archive objectS)] + (in (_.the fieldS objectG))))])) + +(def object::do + Handler + (custom + [(all <>.and <s>.text <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [methodS objectS inputsS]) + (do [! ////////phase.monad] + [objectG (phase archive objectS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.do methodS inputsG {.#None} objectG))))])) + +(with_template [<!> <?> <unit>] + [(def <!> (Nullary Expression) (function.constant <unit>)) + (def <?> (Unary Expression) (_.= <unit>))] + + [object::nil object::nil? _.nil] + ) + +(def object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "get" object::get) + (/.install "do" object::do) + (/.install "nil" (nullary object::nil)) + (/.install "nil?" (unary object::nil?)) + ))) + +(def ruby::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (at ////////phase.monad in (is _.CVar (_.manual name))))])) + +(def ruby::apply + (custom + [(all <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do [! ////////phase.monad] + [abstractionG (phase archive abstractionS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.apply inputsG {.#None} abstractionG))))])) + +(def ruby::import + (custom + [<s>.text + (function (_ extension phase archive module) + (at ////////phase.monad in + (_.require/1 (_.string module))))])) + +(def .public bundle + Bundle + (<| (/.prefix "ruby") + (|> /.empty + (dictionary.composite ..array) + (dictionary.composite ..object) + + (/.install "constant" ruby::constant) + (/.install "apply" ruby::apply) + (/.install "import" ruby::import) + (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/scheme.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/scheme.lux new file mode 100644 index 000000000..e2a5ce49f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/scheme.lux @@ -0,0 +1,18 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + ["[0]" / + ["[1][0]" common] + ["[1][0]" host] + [//// + [generation + [scheme + [runtime (.only Bundle)]]]]]) + +(def .public bundle + Bundle + (dictionary.composite /common.bundle + /host.bundle)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/scheme/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/scheme/common.lux new file mode 100644 index 000000000..2b8bbcba8 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/scheme/common.lux @@ -0,0 +1,177 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function] + ["[0]" try]] + [data + ["[0]" product] + ["[0]" text + ["%" \\format (.only format)]] + [collection + ["[0]" dictionary] + ["[0]" set] + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["f" frac]]] + [meta + ["@" target + ["_" scheme (.only Expression)]]]]] + ["[0]" //// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["[0]" reference] + ["//" scheme + ["[1][0]" runtime (.only Operation Phase Handler Bundle Generator)] + ["[1][0]" case]]] + [// + ["[0]" generation] + ["[0]" synthesis (.only %synthesis) + ["<s>" \\parser (.only Parser)]] + [/// + ["[1]" phase]]]]]) + +(def .public (custom [parser handler]) + (All (_ s) + (-> [(Parser s) + (-> Text (Generator s))] + Handler)) + (function (_ extension_name phase archive input) + (case (<s>.result parser input) + {try.#Success input'} + (handler extension_name phase archive input') + + {try.#Failure error} + (/////.except extension.invalid_syntax [extension_name %synthesis input])))) + +(def !unary + (template (_ function) + (|>> list _.apply (|> (_.constant function))))) + +... TODO: Get rid of this ASAP +(def lux::syntax_char_case! + (..custom [(all <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple (all <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do [! /////.monad] + [@input (at ! each _.var (generation.symbol "input")) + inputG (phase archive input) + elseG (phase archive else) + conditionalsG (is (Operation (List [Expression Expression])) + (monad.each ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch)] + (in [(|> chars (list#each (|>> .int _.int (_.=/2 @input))) _.or) + branchG]))) + conditionals))] + (in (_.let (list [@input inputG]) + (list#mix (function (_ [test then] else) + (_.if test then else)) + elseG + conditionalsG)))))])) + +(def lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurried _.eq?/2))) + (/.install "try" (unary //runtime.lux//try)) + )) + +(def (capped operation parameter subject) + (-> (-> Expression Expression Expression) + (-> Expression Expression Expression)) + (//runtime.i64//64 (operation parameter subject))) + +(def i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurried //runtime.i64//and))) + (/.install "or" (binary (product.uncurried //runtime.i64//or))) + (/.install "xor" (binary (product.uncurried //runtime.i64//xor))) + (/.install "left-shift" (binary (product.uncurried //runtime.i64//left_shift))) + (/.install "right-shift" (binary (product.uncurried //runtime.i64//right_shift))) + (/.install "=" (binary (product.uncurried _.=/2))) + (/.install "<" (binary (product.uncurried _.</2))) + (/.install "+" (binary (product.uncurried (..capped _.+/2)))) + (/.install "-" (binary (product.uncurried (..capped _.-/2)))) + (/.install "*" (binary (product.uncurried (..capped _.*/2)))) + (/.install "/" (binary (product.uncurried //runtime.i64//division))) + (/.install "%" (binary (product.uncurried _.remainder/2))) + (/.install "f64" (unary (_.//2 (_.float +1.0)))) + (/.install "char" (unary (|>> _.integer->char/1 (_.make_string/2 (_.int +1))))) + ))) + +(def f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "=" (binary (product.uncurried _.=/2))) + (/.install "<" (binary (product.uncurried _.</2))) + (/.install "+" (binary (product.uncurried _.+/2))) + (/.install "-" (binary (product.uncurried _.-/2))) + (/.install "*" (binary (product.uncurried _.*/2))) + (/.install "/" (binary (product.uncurried _.//2))) + (/.install "%" (binary (product.uncurried _.remainder/2))) + (/.install "i64" (unary _.truncate/1)) + (/.install "encode" (unary _.number->string/1)) + (/.install "decode" (unary //runtime.f64//decode))))) + +(def (text//index [offset sub text]) + (Trinary Expression) + (//runtime.text//index offset sub text)) + +(def (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip paramO extraO subjectO)) + +(def text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurried _.string=?/2))) + (/.install "<" (binary (product.uncurried _.string<?/2))) + (/.install "concat" (binary (product.uncurried _.string_append/2))) + (/.install "index" (trinary ..text//index)) + (/.install "size" (unary _.string_length/1)) + (/.install "char" (binary (product.uncurried //runtime.text//char))) + (/.install "clip" (trinary ..text//clip)) + ))) + +(def (io//log! message) + (Unary Expression) + (_.begin (list (_.display/1 message) + (_.display/1 (_.string text.new_line)) + //runtime.unit))) + +(def io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary _.raise/1)) + ))) + +(def .public bundle + Bundle + (<| (/.prefix "lux") + (|> /.empty + (dictionary.composite lux_procs) + (dictionary.composite i64_procs) + (dictionary.composite f64_procs) + (dictionary.composite text_procs) + (dictionary.composite io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/scheme/host.lux new file mode 100644 index 000000000..d48dc1e11 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/generation/scheme/host.lux @@ -0,0 +1,111 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + [collection + ["[0]" dictionary] + ["[0]" list]] + [text + ["%" \\format (.only format)]]] + [meta + [target + ["_" scheme (.only Var Expression)]]]]] + ["[0]" // + ["[1][0]" common (.only custom)] + ["//[1]" /// + ["/" bundle] + ["/[1]" // + ["[0]" extension] + [generation + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + ["[0]" reference] + ["//" scheme + ["[1][0]" runtime (.only Operation Phase Handler Bundle + with_vars)]]] + ["/[1]" // + ["[0]" generation] + [synthesis + ["<s>" \\parser (.only Parser)]] + ["//[1]" /// + ["[1][0]" phase]]]]]]) + +(def (array::new size) + (Unary Expression) + (_.make_vector/2 size _.nil)) + +(def array::length + (Unary Expression) + _.vector_length/1) + +(def (array::read [indexG arrayG]) + (Binary Expression) + (_.vector_ref/2 arrayG indexG)) + +(def (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//write indexG _.nil arrayG)) + +(def array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(with_template [<!> <?> <unit>] + [(def <!> (Nullary Expression) (function.constant <unit>)) + (def <?> (Unary Expression) (_.eq?/2 <unit>))] + + [object::nil object::nil? _.nil] + ) + +(def object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "nil" (nullary object::nil)) + (/.install "nil?" (unary object::nil?)) + ))) + +(def scheme::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (do ////////phase.monad + [] + (in (_.var name))))])) + +(def scheme::apply + (custom + [(all <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do [! ////////phase.monad] + [abstractionG (phase archive abstractionS) + inputsG (monad.each ! (phase archive) inputsS)] + (in (_.apply inputsG abstractionG))))])) + +(def .public bundle + Bundle + (<| (/.prefix "scheme") + (|> /.empty + (dictionary.composite ..array) + (dictionary.composite ..object) + + (/.install "constant" scheme::constant) + (/.install "apply" scheme::apply) + (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/synthesis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/synthesis.lux new file mode 100644 index 000000000..54b8a874b --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/synthesis.lux @@ -0,0 +1,11 @@ +(.require + [library + [lux (.except)]] + [// + ["[0]" bundle] + [/// + [synthesis (.only Bundle)]]]) + +(def .public bundle + Bundle + bundle.empty) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp.lux new file mode 100644 index 000000000..1168d5b8b --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp.lux @@ -0,0 +1,60 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [meta + [macro + ["^" pattern]]]]] + ["[0]" / + [runtime (.only Phase)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["[1][0]" function] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" extension] + ["/[1]" // + [analysis (.only)] + ["[1][0]" synthesis] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference (.only) + [variable (.only)]]]]]]]) + +(def .public (generate archive synthesis) + Phase + (case synthesis + (^.with_template [<tag> <generator>] + [(<tag> value) + (//////phase#in (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + {////synthesis.#Reference value} + (//reference.reference /reference.system archive value) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/again /loop.again] + [////synthesis.function/abstraction /function.function]) + + {////synthesis.#Extension extension} + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/case.lux new file mode 100644 index 000000000..cd5ef69ad --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/case.lux @@ -0,0 +1,263 @@ +(.require + [library + [lux (.except case let if) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix monoid)] + ["[0]" set]]] + [math + [number + ["n" nat]]] + [meta + [macro + ["^" pattern]] + [target + ["_" common_lisp (.only Expression Var/1)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" reference] + ["[1][0]" primitive] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" synthesis + ["[1]/[0]" case]] + ["/[1]" // + ["[1][0]" synthesis (.only Member Synthesis Path)] + ["[1][0]" generation] + ["//[1]" /// + [reference + ["[1][0]" variable (.only Register)]] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)]]]]]]]) + +(def .public register + (-> Register Var/1) + (|>> (///reference.local //reference.system) as_expected)) + +(def .public capture + (-> Register Var/1) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def .public (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS) + bodyG (expression archive bodyS)] + (in (_.let (list [(..register register) valueG]) + (list bodyG))))) + +(def .public (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testG (expression archive testS) + thenG (expression archive thenS) + elseG (expression archive elseS)] + (in (_.if testG thenG elseG)))) + +(def .public (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS)] + (in (list#mix (function (_ side source) + (.let [method (.case side + (^.with_template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([.#Left //runtime.tuple//left] + [.#Right //runtime.tuple//right]))] + (method source))) + valueG + pathP)))) + +(def @savepoint (_.var "lux_pm_savepoint")) +(def @cursor (_.var "lux_pm_cursor")) +(def @temp (_.var "lux_pm_temp")) +(def @variant (_.var "lux_pm_variant")) + +(def (push! value) + (-> (Expression Any) (Expression Any)) + (_.setq @cursor (_.cons/2 [value @cursor]))) + +(def pop! + (Expression Any) + (_.setq @cursor (_.cdr/1 @cursor))) + +(def peek + (Expression Any) + (_.car/1 @cursor)) + +(def save! + (Expression Any) + (_.setq @savepoint (_.cons/2 [@cursor @savepoint]))) + +(def restore! + (List (Expression Any)) + (list (_.setq @cursor (_.car/1 @savepoint)) + (_.setq @savepoint (_.cdr/1 @savepoint)))) + +(def (multi_pop! pops) + (-> Nat (Expression Any)) + (_.setq @cursor (_.nthcdr/2 [(_.int (.int pops)) @cursor]))) + +(with_template [<name> <flag> <prep>] + [(def (<name> @fail simple? idx next!) + (-> _.Tag Bit Nat (Maybe (Expression Any)) (Expression Any)) + (.let [<failure_condition> (_.eq/2 [@variant @temp])] + (_.let (list [@variant ..peek]) + (list.partial (_.setq @temp (|> idx <prep> .int _.int (//runtime.sum//get @variant <flag>))) + (.if simple? + (_.when <failure_condition> + (_.go @fail)) + (_.if <failure_condition> + (_.go @fail) + (..push! @temp))) + (.case next! + {.#Some next!} + (list next!) + + {.#None} + (list))))))] + + [left_choice _.nil (<|)] + [right_choice (_.string "") ++] + ) + +(def (alternation @otherwise pre! post!) + (-> _.Tag (Expression Any) (Expression Any) (Expression Any)) + (_.tagbody (all list#composite + (list ..save! + pre! + @otherwise) + ..restore! + (list post!)))) + +(def (pattern_matching' expression archive) + (Generator [Var/1 _.Tag _.Tag Path]) + (function (again [$output @done @fail pathP]) + (.case pathP + (/////synthesis.path/then bodyS) + (at ///////phase.monad each + (function (_ outputV) + (_.progn (list (_.setq $output outputV) + (_.go @done)))) + (expression archive bodyS)) + + {/////synthesis.#Pop} + (///////phase#in ..pop!) + + {/////synthesis.#Bind register} + (///////phase#in (_.setq (..register register) ..peek)) + + {/////synthesis.#Bit_Fork when thenP elseP} + (do [! ///////phase.monad] + [then! (again [$output @done @fail thenP]) + else! (.case elseP + {.#Some elseP} + (again [$output @done @fail elseP]) + + {.#None} + (in (_.go @fail)))] + (in (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^.with_template [<tag> <format> <=>] + [{<tag> item} + (do [! ///////phase.monad] + [clauses (monad.each ! (function (_ [match then]) + (do ! + [then! (again [$output @done @fail then])] + (in [(<=> [(|> match <format>) + ..peek]) + then!]))) + {.#Item item})] + (in (list#mix (function (_ [when then] else) + (_.if when then else)) + (_.go @fail) + clauses)))]) + ([/////synthesis.#I64_Fork //primitive.i64 _.=/2] + [/////synthesis.#F64_Fork //primitive.f64 _.=/2] + [/////synthesis.#Text_Fork //primitive.text _.string=/2]) + + (^.with_template [<complex> <simple> <choice>] + [(<complex> idx) + (///////phase#in (<choice> @fail false idx {.#None})) + + (<simple> idx nextP) + (|> nextP + [$output @done @fail] again + (at ///////phase.monad each (|>> {.#Some} (<choice> @fail true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (/////synthesis.member/left 0) + (///////phase#in (..push! (_.elt/2 [..peek (_.int +0)]))) + + (^.with_template [<pm> <getter>] + [(<pm> lefts) + (///////phase#in (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (/////synthesis.!multi_pop nextP) + (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] + (do ///////phase.monad + [next! (again [$output @done @fail nextP'])] + (///////phase#in (_.progn (list (..multi_pop! (n.+ 2 extra_pops)) + next!))))) + + (/////synthesis.path/alt preP postP) + (do [! ///////phase.monad] + [@otherwise (at ! each (|>> %.nat (format "lux_case_otherwise") _.tag) /////generation.next) + pre! (again [$output @done @otherwise preP]) + post! (again [$output @done @fail postP])] + (in (..alternation @otherwise pre! post!))) + + (/////synthesis.path/seq preP postP) + (do ///////phase.monad + [pre! (again [$output @done @fail preP]) + post! (again [$output @done @fail postP])] + (in (_.progn (list pre! post!))))))) + +(def (pattern_matching $output expression archive pathP) + (-> Var/1 (Generator Path)) + (do [! ///////phase.monad] + [@done (at ! each (|>> %.nat (format "lux_case_done") _.tag) /////generation.next) + @fail (at ! each (|>> %.nat (format "lux_case_fail") _.tag) /////generation.next) + pattern_matching! (pattern_matching' expression archive [$output @done @fail pathP])] + (in (_.tagbody + (list pattern_matching! + @fail + (_.error/1 (_.string ////synthesis/case.pattern_matching_error)) + @done))))) + +(def .public (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do [! ///////phase.monad] + [initG (expression archive valueS) + $output (at ! each (|>> %.nat (format "lux_case_output") _.var) /////generation.next) + pattern_matching! (pattern_matching $output expression archive pathP) + .let [storage (|> pathP + ////synthesis/case.storage + (the ////synthesis/case.#bindings) + set.list + (list#each (function (_ register) + [(..register register) + _.nil])))]] + (in (_.let (list.partial [@cursor (_.list/* (list initG))] + [@savepoint (_.list/* (list))] + [@temp _.nil] + [$output _.nil] + storage) + (list pattern_matching! + $output))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/extension.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/extension.lux new file mode 100644 index 000000000..1d1c8473f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/extension.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + [// + [runtime (.only Bundle)]] + [/ + ["[0]" common]]) + +(def .public bundle + Bundle + common.bundle) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/extension/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/extension/common.lux new file mode 100644 index 000000000..bb57efc5b --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/extension/common.lux @@ -0,0 +1,138 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" function]] + [data + ["[0]" product] + [number + ["f" frac]] + [collection + ["[0]" dictionary]]] + [meta + [target + ["_" common_lisp (.only Expression)]]]]] + ["[0]" /// + ["[1][0]" runtime (.only Operation Phase Handler Bundle)] + ["[1][0]" primitive] + [// + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + [// + [extension + ["[0]" bundle]]]]]) + +(def lux_procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurried _.eq))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def (i64//left_shifted [paramG subjectG]) + (Binary (Expression Any)) + (_.ash (_.rem (_.int +64) paramG) subjectG)) + +(def (i64//arithmetic_right_shifted [paramG subjectG]) + (Binary (Expression Any)) + (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1))) + subjectG)) + +(def (i64//logic_right_shifted [paramG subjectG]) + (Binary (Expression Any)) + (///runtime.i64//logic_right_shifted (_.rem (_.int +64) paramG) subjectG)) + +(def i64_procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurried _.logand))) + (bundle.install "or" (binary (product.uncurried _.logior))) + (bundle.install "xor" (binary (product.uncurried _.logxor))) + (bundle.install "left-shift" (binary i64//left_shifted)) + (bundle.install "logical-right-shift" (binary i64//logic_right_shifted)) + (bundle.install "arithmetic-right-shift" (binary i64//arithmetic_right_shifted)) + (bundle.install "=" (binary (product.uncurried _.=))) + (bundle.install "<" (binary (product.uncurried _.<))) + (bundle.install "+" (binary (product.uncurried _.+))) + (bundle.install "-" (binary (product.uncurried _.-))) + (bundle.install "*" (binary (product.uncurried _.*))) + (bundle.install "/" (binary (product.uncurried _.floor))) + (bundle.install "%" (binary (product.uncurried _.rem))) + (bundle.install "f64" (unary (function (_ value) + (_.coerce/2 [value (_.symbol "double-float")])))) + (bundle.install "char" (unary (|>> _.code_char/1 _.string/1))) + ))) + +(def f64_procs + Bundle + (<| (bundle.prefix "f64") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurried _.+))) + (bundle.install "-" (binary (product.uncurried _.-))) + (bundle.install "*" (binary (product.uncurried _.*))) + (bundle.install "/" (binary (product.uncurried _./))) + (bundle.install "%" (binary (product.uncurried _.mod))) + (bundle.install "=" (binary (product.uncurried _.=))) + (bundle.install "<" (binary (product.uncurried _.<))) + (bundle.install "i64" (unary _.floor/1)) + (bundle.install "encode" (unary _.write_to_string/1)) + (bundle.install "decode" (unary (let [@temp (_.var "temp")] + (function (_ input) + (_.let (list [@temp (_.read_from_string/1 input)]) + (_.if (_.equal (_.symbol "DOUBLE-FLOAT") + (_.type_of/1 @temp)) + (///runtime.some @temp) + ///runtime.none))))))))) + +(def (text//< [paramG subjectG]) + (Binary (Expression Any)) + (|> (_.string< paramG subjectG) + _.null/1 + _.not/1)) + +(def (text//clip [paramO extraO subjectO]) + (Trinary (Expression Any)) + (///runtime.text//clip subjectO paramO extraO)) + +(def (text//index [startO partO textO]) + (Trinary (Expression Any)) + (///runtime.text//index textO partO startO)) + +(def text_procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurried _.string=))) + (bundle.install "<" (binary text//<)) + (bundle.install "concat" (binary _.concatenate/2|string)) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary _.length/1)) + (bundle.install "char" (binary (|>> _.char/2 _.char_int/1))) + (bundle.install "clip" (trinary text//clip)) + ))) + +(def (void code) + (-> (Expression Any) (Expression Any)) + (all _.progn + code + ///runtime.unit)) + +(def io_procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> _.print/1 ..void))) + (bundle.install "error" (unary _.error/1)) + ))) + +(def .public bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux_procs + (dictionary.composite i64_procs) + (dictionary.composite f64_procs) + (dictionary.composite text_procs) + (dictionary.composite io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/function.lux new file mode 100644 index 000000000..6b6fd617d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/function.lux @@ -0,0 +1,104 @@ +(.require + [library + [lux (.except function) + [abstract + ["[0]" monad (.only do)]] + [control + pipe] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [meta + [target + ["_" common_lisp (.only Expression Var/1)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" reference] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Variant Tuple Abstraction Application Analysis)] + [synthesis (.only Synthesis)] + ["[1][0]" generation (.only Context)] + ["//[1]" /// + [arity (.only Arity)] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference + [variable (.only Register Variable)]]]]]]) + +(def .public (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do [! ///////phase.monad] + [functionG (expression archive functionS) + argsG+ (monad.each ! (expression archive) argsS+)] + (in (_.funcall/+ [functionG argsG+])))) + +(def capture + (-> Register Var/1) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def (with_closure inits function_definition) + (-> (List (Expression Any)) (Expression Any) (Operation (Expression Any))) + (case inits + {.#End} + (at ///////phase.monad in function_definition) + + _ + (do [! ///////phase.monad] + [@closure (at ! each _.var (/////generation.symbol "closure"))] + (in (_.labels (list [@closure [(|> (list.enumeration inits) + (list#each (|>> product.left ..capture)) + _.args) + function_definition]]) + (_.funcall/+ [(_.function/1 @closure) inits])))))) + +(def input + (|>> ++ //case.register)) + +(def .public (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do [! ///////phase.monad] + [@scope (at ! each (|>> %.nat (format "function_scope") _.tag) /////generation.next) + @output (at ! each (|>> %.nat (format "loop_output") _.var) /////generation.next) + [function_name bodyG] (/////generation.with_new_context archive + (/////generation.with_anchor [@scope 1] + (expression archive bodyS))) + closureG+ (monad.each ! (expression archive) environment) + .let [@curried (_.var "curried") + @missing (_.var "missing") + arityG (|> arity .int _.int) + @num_args (_.var "num_args") + @self (_.var (///reference.artifact function_name)) + initialize_self! [(//case.register 0) (_.function/1 @self)] + initialize! [(|> (list.indices arity) + (list#each ..input) + _.args) + @curried]]] + (with_closure closureG+ + (_.labels (list [@self [(_.args& (list) @curried) + (_.let (list [@num_args (_.length/1 @curried)]) + (list (_.cond (list [(_.=/2 [arityG @num_args]) + (_.let (list [@output _.nil] + initialize_self!) + (list (_.destructuring-bind initialize! + (list (_.tagbody + (list @scope + (_.setq @output bodyG))) + @output))))] + + [(_.>/2 [arityG @num_args]) + (let [arity_inputs (_.subseq/3 [@curried (_.int +0) arityG]) + extra_inputs (_.subseq/3 [@curried arityG @num_args])] + (_.apply/2 [(_.apply/2 [(_.function/1 @self) + arity_inputs]) + extra_inputs]))]) + ... (|> @num_args (_.< arityG)) + (_.lambda (_.args& (list) @missing) + (_.apply/2 [(_.function/1 @self) + (_.append/2 [@curried @missing])])))))]]) + (_.function/1 @self))) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/loop.lux new file mode 100644 index 000000000..ad1f110de --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/loop.lux @@ -0,0 +1,72 @@ +(.require + [library + [lux (.except Scope) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [math + [number + ["n" nat]]] + [meta + [target + ["_" common_lisp (.only Expression)]]]]] + ["[0]" // + [runtime (.only Operation Phase Generator)] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + [synthesis + ["[0]" case]] + ["/[1]" // + ["[0]"synthesis (.only Scope Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + ["[1][0]" phase] + [meta + [archive (.only Archive)]] + [reference + [variable (.only Register)]]]]]]]) + +(def .public (scope expression archive [start initsS+ bodyS]) + (Generator (Scope Synthesis)) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [@scope (at ! each (|>> %.nat (format "loop_scope") _.tag) /////generation.next) + @output (at ! each (|>> %.nat (format "loop_output") _.var) /////generation.next) + initsG+ (monad.each ! (expression archive) initsS+) + bodyG (/////generation.with_anchor [@scope start] + (expression archive bodyS))] + ... TODO: There is a bug in the way the variables are updated. Do a _.multiple_value_setq instead. + (in (_.let (|> initsG+ + list.enumeration + (list#each (function (_ [idx init]) + [(|> idx (n.+ start) //case.register) + init])) + (list.partial [@output _.nil])) + (list (_.tagbody (list @scope + (_.setq @output bodyG))) + @output)))))) + +(def .public (again expression archive argsS+) + (Generator (List Synthesis)) + (do [! ///////phase.monad] + [[tag offset] /////generation.anchor + argsO+ (monad.each ! (expression archive) argsS+) + .let [bindings (|> argsO+ + list.enumeration + (list#each (|>> product.left (n.+ offset) //case.register)) + _.args)]] + (in (_.progn (list (_.multiple_value_setq bindings (_.values/* argsO+)) + (_.go tag)))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/primitive.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/primitive.lux new file mode 100644 index 000000000..a85bbb625 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/primitive.lux @@ -0,0 +1,22 @@ +(.require + [library + [lux (.except i64) + [meta + [target + ["_" common_lisp (.only Expression)]]]]]) + +(def .public bit + (-> Bit (Expression Any)) + _.bool) + +(def .public i64 + (-> (I64 Any) (Expression Any)) + (|>> .int _.int)) + +(def .public f64 + (-> Frac (Expression Any)) + _.double) + +(def .public text + (-> Text (Expression Any)) + _.string) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/reference.lux new file mode 100644 index 000000000..4f70ce907 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/reference.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [meta + [target + ["_" common_lisp (.only Expression)]]]]] + [/// + [reference (.only System)]]) + +(def .public system + (System (Expression Any)) + (implementation + (def constant _.var) + (def variable _.var))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/runtime.lux new file mode 100644 index 000000000..77f1e5cfd --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/runtime.lux @@ -0,0 +1,305 @@ +(.require + [library + [lux (.except Location) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)] + ["[0]" encoding]] + [collection + ["[0]" list (.use "[1]#[0]" functor monoid)] + ["[0]" sequence]]] + [math + [number (.only hex) + ["[0]" i64]]] + ["[0]" meta (.only) + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)]] + ["@" target + ["_" common_lisp (.only Expression Computation Literal)]]]]] + ["[0]" /// + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Variant)] + ["[1][0]" synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// (.only) + ["[1][0]" phase] + [reference + [variable (.only Register)]] + [meta + [archive (.only Output Archive) + ["[0]" artifact (.only Registry)]]]]]]) + +(def module_id + 0) + +(with_template [<name> <base>] + [(type .public <name> + (<base> [_.Tag Register] (Expression Any) (Expression Any)))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type .public (Generator i) + (-> Phase Archive i (Operation (Expression Any)))) + +(def .public unit + (_.string /////synthesis.unit)) + +(def (flag value) + (-> Bit Literal) + (if value + (_.string "") + _.nil)) + +(def (variant' tag last? value) + (-> (Expression Any) (Expression Any) (Expression Any) (Computation Any)) + (_.list/* (list tag last? value))) + +(def .public (variant [lefts right? value]) + (-> (Variant (Expression Any)) (Computation Any)) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def .public none + (Computation Any) + (|> ..unit [0 #0] ..variant)) + +(def .public some + (-> (Expression Any) (Computation Any)) + (|>> [1 #1] ..variant)) + +(def .public left + (-> (Expression Any) (Computation Any)) + (|>> [0 #0] ..variant)) + +(def .public right + (-> (Expression Any) (Computation Any)) + (|>> [1 #1] ..variant)) + +(def .public with_vars + (syntax (_ [vars (<code>.tuple (<>.some <code>.local)) + body <code>.any]) + (do [! meta.monad] + [ids (monad.all ! (list.repeated (list.size vars) meta.seed))] + (in (list (` (let [(,* (|> vars + (list.zipped_2 ids) + (list#each (function (_ [id var]) + (list (code.local var) + (` (_.var (, (code.text (format "v" (%.nat id))))))))) + list.together))] + (, body)))))))) + +(def runtime + (syntax (_ [declaration (<>.or <code>.local + (<code>.form (<>.and <code>.local + (<>.some <code>.local)))) + code <code>.any]) + (do meta.monad + [runtime_id meta.seed] + (macro.with_symbols [g!_] + (let [runtime (code.local (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (, (code.text (%.code runtime)))))] + (case declaration + {.#Left name} + (let [g!name (code.local name) + code_nameC (code.local (format "@" name))] + (in (list (` (def .public (, g!name) + _.Var/1 + (, runtime_name))) + + (` (def (, code_nameC) + (_.Expression Any) + (_.defparameter (, runtime_name) (, code))))))) + + {.#Right [name inputs]} + (let [g!name (code.local name) + code_nameC (code.local (format "@" name)) + + inputsC (list#each code.local inputs) + inputs_typesC (list#each (function.constant (` (_.Expression Any))) + inputs)] + (in (list (` (def .public ((, g!name) (,* inputsC)) + (-> (,* inputs_typesC) (_.Computation Any)) + (_.call/* (, runtime_name) (list (,* inputsC))))) + + (` (def (, code_nameC) + (_.Expression Any) + (..with_vars [(,* inputsC)] + (_.defun (, runtime_name) (_.args (list (,* inputsC))) + (, code)))))))))))))) + +(runtime + (lux//try op) + (with_vars [error] + (_.handler_case + (list [(_.bool true) error + (..left (_.format/3 [_.nil (_.string "~A") error]))]) + (..right (_.funcall/+ [op (list ..unit)]))))) + +... TODO: Use Common Lisp's swiss-army loop macro instead. +(runtime + (lux//program_args inputs) + (with_vars [loop input tail] + (_.labels (list [loop [(_.args (list input tail)) + (_.if (_.null/1 input) + tail + (_.funcall/+ [(_.function/1 loop) + (list (_.cdr/1 input) + (..some (_.vector/* (list (_.car/1 input) tail))))]))]]) + (_.funcall/+ [(_.function/1 loop) + (list (_.reverse/1 inputs) + ..none)])))) + +(def runtime//lux + (List (Expression Any)) + (list @lux//try + @lux//program_args)) + +(def last_index + (|>> _.length/1 [(_.int +1)] _.-/2)) + +(with_expansions [<recur> (these (all _.then + (_.; (_.set lefts (_.-/2 [last_index_right lefts]))) + (_.; (_.set tuple (_.nth last_index_right tuple)))))] + (def !recur + (template (_ <side>) + (<side> (_.-/2 [last_index_right lefts]) + (_.elt/2 [tuple last_index_right])))) + + (runtime + (tuple//left lefts tuple) + (with_vars [last_index_right] + (_.let (list [last_index_right (..last_index tuple)]) + (list (_.if (_.>/2 [lefts last_index_right]) + ... No need for recursion + (_.elt/2 [tuple lefts]) + ... Needs recursion + (!recur tuple//left)))))) + + (runtime + (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (_.let (list [last_index_right (..last_index tuple)] + [right_index (_.+/2 [(_.int +1) lefts])]) + (list (_.cond (list [(_.=/2 [last_index_right right_index]) + (_.elt/2 [tuple right_index])] + [(_.>/2 [last_index_right right_index]) + ... Needs recursion. + (!recur tuple//right)]) + (_.subseq/3 [tuple right_index (_.length/1 tuple)]))))))) + +... TODO: Find a way to extract parts of the sum without "nth", which +... does a linear search, and is thus expensive. +(runtime + (sum//get sum wantsLast wantedTag) + (with_vars [sum_tag sum_flag] + (let [no_match! (_.return sum) + sum_value (_.nth/2 [(_.int +2) sum]) + test_recursion! (_.if sum_flag + ... Must iterate. + (_.progn (list (_.setq wantedTag (_.-/2 [sum_tag wantedTag])) + (_.setq sum sum_value))) + no_match!)] + (_.while (_.bool true) + (_.let (list [sum_tag (_.nth/2 [(_.int +0) sum])] + [sum_flag (_.nth/2 [(_.int +1) sum])]) + (list (_.cond (list [(_.=/2 [sum_tag wantedTag]) + (_.if (_.equal/2 [wantsLast sum_flag]) + (_.return sum_value) + test_recursion!)] + + [(_.>/2 [sum_tag wantedTag]) + test_recursion!] + + [(_.and (_.</2 [sum_tag wantedTag]) + wantsLast) + (_.return (variant' (_.-/2 [wantedTag sum_tag]) sum_flag sum_value))]) + + no_match!))))))) + +(def runtime//adt + (List (Expression Any)) + (list @tuple//left + @tuple//right + @sum//get)) + +(runtime + (i64//right_shifted shift input) + (_.if (_.=/2 [(_.int +0) shift]) + input + (let [anti_shift (_.-/2 [shift (_.int +64)]) + mask (|> (_.int +1) + [anti_shift] _.ash/2 + [(_.int +1)] _.-/2)] + (|> input + [(_.*/2 [(_.int -1) shift])] _.ash/2 + [mask] _.logand/2)))) + +(def runtime//i64 + (List (Expression Any)) + (list @i64//right_shifted)) + +(runtime + (text//clip offset length text) + (_.subseq/3 [text offset (_.+/2 [offset length])])) + +(runtime + (text//index offset sub text) + (with_vars [index] + (_.let (list [index (_.search/3 [sub text offset])]) + (list (_.if index + (..some index) + ..none))))) + +(def runtime//text + (List (Expression Any)) + (list @text//index + @text//clip)) + +(runtime + (io//exit code) + (_.progn (list (_.conditional+ (list "sbcl") + (_.call/* (_.var "sb-ext:quit") (list code))) + (_.conditional+ (list "clisp") + (_.call/* (_.var "ext:exit") (list code))) + (_.conditional+ (list "ccl") + (_.call/* (_.var "ccl:quit") (list code))) + (_.conditional+ (list "allegro") + (_.call/* (_.var "excl:exit") (list code))) + (_.call/* (_.var "cl-user::quit") (list code))))) + +(def runtime//io + (List (Expression Any)) + (list @io//exit)) + +(def runtime + (_.progn (all list#composite + runtime//adt + runtime//lux + runtime//i64 + runtime//text + runtime//io))) + +(def .public generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! (%.nat ..module_id) ..runtime)] + (in [(|> artifact.empty + artifact.resource + product.right) + (sequence.sequence [(%.nat ..module_id) + (|> ..runtime + _.code + (at encoding.utf8 encoded))])]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/structure.lux new file mode 100644 index 000000000..af4d6023b --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/common_lisp/structure.lux @@ -0,0 +1,38 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [meta + [target + ["_" common_lisp (.only Expression)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" primitive] + ["///[1]" //// + [analysis (.only Variant Tuple)] + ["[1][0]" synthesis (.only Synthesis)] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)]]]]) + +(def .public (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + {.#End} + (///////phase#in (//primitive.text /////synthesis.unit)) + + {.#Item singletonS {.#End}} + (expression archive singletonS) + + _ + (|> elemsS+ + (monad.each ///////phase.monad (expression archive)) + (///////phase#each _.vector/*)))) + +(def .public (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (++ lefts) + lefts)] + (///////phase#each (|>> [tag right?] //runtime.variant) + (expression archive valueS)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/extension.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/extension.lux new file mode 100644 index 000000000..9d2c7e1db --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/extension.lux @@ -0,0 +1,78 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [data + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + ["[0]" meta (.only) + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only with_symbols) + [syntax (.only syntax)]]]]] + ["[0]" /// + ["[1][0]" extension] + [// + [synthesis (.only Synthesis)] + ["[0]" generation] + [/// + ["[1]" phase]]]]) + +(def Vector + (syntax (_ [size <code>.nat + elemT <code>.any]) + (in (list (` [(,* (list.repeated size elemT))]))))) + +(def Arity + (template (_ arity) + [(All (_ of) + (-> (Vector arity of) of))])) + +(def arity + (syntax (_ [arity <code>.nat]) + (with_symbols [g!_ g!extension g!name g!phase g!archive g!inputs g!anchor g!expression g!declaration] + (do [! meta.monad] + [g!input+ (monad.all ! (list.repeated arity (macro.symbol "input")))] + (in (list (` (is (All ((, g!_) (, g!anchor) (, g!expression) (, g!declaration)) + (-> ((Arity (, (code.nat arity))) (, g!expression)) + (generation.Handler (, g!anchor) (, g!expression) (, g!declaration)))) + (function ((, g!_) (, g!extension)) + (function ((, g!_) (, g!name) (, g!phase) (, g!archive) (, g!inputs)) + (case (, g!inputs) + (list (,* g!input+)) + (do ///.monad + [(,* (|> g!input+ + (list#each (function (_ g!input) + (list g!input (` ((, g!phase) (, g!archive) (, g!input)))))) + list.together))] + ((,' in) ((, g!extension) [(,* g!input+)]))) + + (, g!_) + (///.except ///extension.incorrect_arity [(, g!name) + (, (code.nat arity)) + (list.size (, g!inputs))])) + )))))))))) + +(with_template [<arity> <type> <term>] + [(type .public <type> (Arity <arity>)) + (def .public <term> (arity <arity>))] + + [0 Nullary nullary] + [1 Unary unary] + [2 Binary binary] + [3 Trinary trinary] + ) + +(type .public (Variadic of) + (-> (List of) of)) + +(def .public (variadic extension) + (All (_ anchor expression declaration) + (-> (Variadic expression) (generation.Handler anchor expression declaration))) + (function (_ extension_name) + (function (_ phase archive inputsS) + (let [! ///.monad] + (|> inputsS + (monad.each ! (phase archive)) + (at ! each extension)))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js.lux new file mode 100644 index 000000000..864edbf16 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js.lux @@ -0,0 +1,90 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" exception (.only exception)]] + [meta + [macro + ["^" pattern]] + [target + ["_" js]]]]] + ["[0]" / + [runtime (.only Phase Phase!)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["[1][0]" function] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" extension (.only) + [generation + [js + ["[1]/[0]" common]]]] + ["/[1]" // + [analysis (.only)] + ["[0]" synthesis] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference (.only) + [variable (.only)]]]]]]]) + +(exception .public cannot_recur_as_an_expression) + +(def (expression archive synthesis) + Phase + (case synthesis + (^.with_template [<tag> <generator>] + [(<tag> value) + (//////phase#in (<generator> value))]) + ([synthesis.bit /primitive.bit] + [synthesis.i64 /primitive.i64] + [synthesis.f64 /primitive.f64] + [synthesis.text /primitive.text]) + + (synthesis.variant variantS) + (/structure.variant expression archive variantS) + + (synthesis.tuple members) + (/structure.tuple expression archive members) + + {synthesis.#Reference value} + (//reference.reference /reference.system archive value) + + (synthesis.branch/case case) + (/case.case ///extension/common.statement expression archive case) + + (synthesis.branch/exec it) + (/case.exec expression archive it) + + (synthesis.branch/let let) + (/case.let expression archive let) + + (synthesis.branch/if if) + (/case.if expression archive if) + + (synthesis.branch/get get) + (/case.get expression archive get) + + (synthesis.loop/scope scope) + (/loop.scope ///extension/common.statement expression archive scope) + + (synthesis.loop/again updates) + (//////phase.except ..cannot_recur_as_an_expression []) + + (synthesis.function/abstraction abstraction) + (/function.function ///extension/common.statement expression archive abstraction) + + (synthesis.function/apply application) + (/function.apply expression archive application) + + {synthesis.#Extension extension} + (///extension.apply archive expression extension))) + +(def .public generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/case.lux new file mode 100644 index 000000000..f8b30c1f9 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/case.lux @@ -0,0 +1,346 @@ +(.require + [library + [lux (.except case exec let if) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" maybe]] + [data + ["[0]" text] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["n" nat]]] + [meta + [macro + ["^" pattern]] + [target + ["_" js (.only Expression Computation Var Statement)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Phase! Generator Generator!)] + ["[1][0]" reference] + ["[1][0]" primitive] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" synthesis + ["[1]/[0]" case]] + ["/[1]" // + ["[1][0]" synthesis (.only Synthesis Path) + [access + ["[0]" member (.only Member)]]] + ["//[1]" /// + [reference + [variable (.only Register)]] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)]]]]]]]) + +(def .public register + (-> Register Var) + (|>> (///reference.local //reference.system) as_expected)) + +(def .public (exec expression archive [this that]) + (Generator [Synthesis Synthesis]) + (do ///////phase.monad + [this (expression archive this) + that (expression archive that)] + (in (|> (_.array (list this that)) + (_.at (_.int +1)))))) + +(def .public (exec! statement expression archive [this that]) + (Generator! [Synthesis Synthesis]) + (do ///////phase.monad + [this (expression archive this) + that (statement expression archive that)] + (in (all _.then + (_.statement this) + that)))) + +(def .public (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + ... TODO: Find some way to do 'let' without paying the price of the closure. + (in (_.apply (_.closure (list (..register register)) + (_.return bodyO)) + (list valueO))))) + +(def .public (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (statement expression archive bodyS)] + (in (all _.then + (_.define (..register register) valueO) + bodyO)))) + +(def .public (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (in (_.? testO thenO elseO)))) + +(def .public (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (statement expression archive thenS) + elseO (statement expression archive elseS)] + (in (_.if testO + thenO + elseO)))) + +(def .public (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (in (list#mix (function (_ side source) + (.let [method (.if (the member.#right? side) + (//runtime.tuple//right (_.i32 (.int (the member.#lefts side)))) + (//runtime.tuple//left (_.i32 (.int (the member.#lefts side)))))] + (method source))) + valueO + (list.reversed pathP))))) + +(def @savepoint (_.var "lux_pm_cursor_savepoint")) +(def @cursor (_.var "lux_pm_cursor")) +(def @temp (_.var "lux_pm_temp")) + +(def (push_cursor! value) + (-> Expression Statement) + (_.statement (|> @cursor (_.do "push" (list value))))) + +(def peek_and_pop_cursor + Expression + (|> @cursor (_.do "pop" (list)))) + +(def pop_cursor! + Statement + (_.statement ..peek_and_pop_cursor)) + +(def length + (|>> (_.the "length"))) + +(def last_index + (|>> ..length (_.- (_.i32 +1)))) + +(def peek_cursor + Expression + (|> @cursor (_.at (last_index @cursor)))) + +(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) + +(def (multi_pop_cursor! pops) + (-> Nat Statement) + (.let [popsJS (_.i32 (.int pops))] + (_.statement (|> @cursor (_.do "splice" (list (|> @cursor ..length (_.- popsJS)) + popsJS)))))) + +(with_template [<name> <flag>] + [(def (<name> simple? idx) + (-> Bit Nat Statement) + (all _.then + (_.set @temp (//runtime.sum//get ..peek_cursor <flag> + (|> idx .int _.i32))) + (.if simple? + (_.when (_.= _.null @temp) + ..fail_pm!) + (_.if (_.= _.null @temp) + ..fail_pm! + (push_cursor! @temp)))))] + + [left_choice _.null] + [right_choice //runtime.unit] + ) + +(def (alternation pre! post!) + (-> Statement Statement Statement) + (all _.then + (_.do_while (_.boolean false) + (all _.then + ..save_cursor! + pre!)) + (all _.then + ..restore_cursor! + post!))) + +(def (optimized_pattern_matching again pathP) + (-> (-> Path (Operation Statement)) + (-> Path (Operation (Maybe Statement)))) + (.case pathP + (^.with_template [<simple> <choice>] + [(<simple> idx nextP) + (|> nextP + again + (at ///////phase.monad each (|>> (_.then (<choice> true idx)) {.#Some})))]) + ([/////synthesis.simple_left_side ..left_choice] + [/////synthesis.simple_right_side ..right_choice]) + + (/////synthesis.member/left 0) + (///////phase#in {.#Some (push_cursor! (_.at (_.i32 +0) ..peek_cursor))}) + + ... Extra optimization + (/////synthesis.path/seq + (/////synthesis.member/left 0) + (/////synthesis.!bind_top register thenP)) + (do ///////phase.monad + [then! (again thenP)] + (in {.#Some (all _.then + (_.define (..register register) (_.at (_.i32 +0) ..peek_cursor)) + then!)})) + + ... Extra optimization + (^.with_template [<pm> <getter>] + [(/////synthesis.path/seq + (<pm> lefts) + (/////synthesis.!bind_top register thenP)) + (do ///////phase.monad + [then! (again thenP)] + (in {.#Some (all _.then + (_.define (..register register) (<getter> (_.i32 (.int lefts)) ..peek_cursor)) + then!)}))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (/////synthesis.!bind_top register thenP) + (do ///////phase.monad + [then! (again thenP)] + (in {.#Some (all _.then + (_.define (..register register) ..peek_and_pop_cursor) + then!)})) + + (/////synthesis.!multi_pop nextP) + (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] + (do ///////phase.monad + [next! (again nextP')] + (in {.#Some (all _.then + (multi_pop_cursor! (n.+ 2 extra_pops)) + next!)}))) + + _ + (///////phase#in {.#None}))) + +(def (pattern_matching' statement expression archive) + (-> Phase! Phase Archive + (-> Path (Operation Statement))) + (function (again pathP) + (do ///////phase.monad + [outcome (optimized_pattern_matching again pathP)] + (.case outcome + {.#Some outcome} + (in outcome) + + {.#None} + (.case pathP + {/////synthesis.#Then bodyS} + (statement expression archive bodyS) + + {/////synthesis.#Pop} + (///////phase#in pop_cursor!) + + {/////synthesis.#Bind register} + (///////phase#in (_.define (..register register) ..peek_cursor)) + + {/////synthesis.#Bit_Fork when thenP elseP} + (do [! ///////phase.monad] + [then! (again thenP) + else! (.case elseP + {.#Some elseP} + (again elseP) + + {.#None} + (in ..fail_pm!))] + (in (.if when + (_.if ..peek_cursor + then! + else!) + (_.if ..peek_cursor + else! + then!)))) + + {/////synthesis.#I64_Fork item} + (do [! ///////phase.monad] + [clauses (monad.each ! (function (_ [match then]) + (do ! + [then! (again then)] + (in [(//runtime.i64::= (//primitive.i64 (.int match)) + ..peek_cursor) + then!]))) + {.#Item item})] + (in (list#mix (function (_ [when then] else) + (_.if when then else)) + ..fail_pm! + clauses))) + + (^.with_template [<tag> <format>] + [{<tag> item} + (do [! ///////phase.monad] + [cases (monad.each ! (function (_ [match then]) + (at ! each (|>> [(list (<format> match))]) (again then))) + {.#Item item})] + (in (_.switch ..peek_cursor + cases + {.#Some ..fail_pm!})))]) + ([/////synthesis.#F64_Fork //primitive.f64] + [/////synthesis.#Text_Fork //primitive.text]) + + (^.with_template [<complex> <choice>] + [(<complex> idx) + (///////phase#in (<choice> false idx))]) + ([/////synthesis.side/left ..left_choice] + [/////synthesis.side/right ..right_choice]) + + (^.with_template [<pm> <getter>] + [(<pm> lefts) + (///////phase#in (push_cursor! (<getter> (_.i32 (.int lefts)) ..peek_cursor)))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (^.with_template [<tag> <combinator>] + [(<tag> leftP rightP) + (do ///////phase.monad + [left! (again leftP) + right! (again rightP)] + (in (<combinator> left! right!)))]) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation])))))) + +(def (pattern_matching statement expression archive pathP) + (-> Phase! Phase Archive Path (Operation Statement)) + (do ///////phase.monad + [pattern_matching! (pattern_matching' statement expression archive pathP)] + (in (all _.then + (_.do_while (_.boolean false) + pattern_matching!) + (_.throw (_.string ////synthesis/case.pattern_matching_error)))))) + +(def .public (case! statement expression archive [valueS pathP]) + (Generator! [Synthesis Path]) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching statement expression archive pathP)] + (in (all _.then + (_.declare @temp) + (_.define @cursor (_.array (list stack_init))) + (_.define @savepoint (_.array (list))) + pattern_matching!)))) + +(def .public (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) + (do ///////phase.monad + [pattern_matching! (..case! statement expression archive [valueS pathP])] + (in (_.apply (_.closure (list) pattern_matching!) (list))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/function.lux new file mode 100644 index 000000000..5d5cf5e13 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/function.lux @@ -0,0 +1,131 @@ +(.require + [library + [lux (.except function) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [meta + [target + ["_" js (.only Expression Computation Var Statement)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Phase! Generator)] + ["[1][0]" reference] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Abstraction Reification Analysis)] + [synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + [arity (.only Arity)] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference + [variable (.only Register Variable)]] + [meta + [archive + ["[0]" unit]] + ["[0]" cache + [dependency + ["[1]" artifact]]]]]]]]) + +(def .public (apply expression archive [functionS argsS+]) + (Generator (Reification Synthesis)) + (do [! ///////phase.monad] + [functionO (expression archive functionS) + argsO+ (monad.each ! (expression archive) argsS+)] + (in (_.apply functionO argsO+)))) + +(def capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def (with_closure @self inits body!) + (-> Var (List Expression) Statement [Statement Expression]) + (case inits + {.#End} + [(_.function_definition @self (list) body!) + @self] + + _ + [(_.function_definition @self + (|> (list.enumeration inits) + (list#each (|>> product.left ..capture))) + (_.return (_.function @self (list) body!))) + (_.apply @self inits)])) + +(def @curried + (_.var "curried")) + +(def input + (|>> ++ //case.register)) + +(def @@arguments + (_.var "arguments")) + +(def (@scope function_name) + (-> unit.ID Text) + (format (///reference.artifact function_name) "_scope")) + +(def .public (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do [! ///////phase.monad] + [dependencies (cache.dependencies archive bodyS) + [function_name body!] (/////generation.with_new_context archive dependencies + (do ! + [scope (at ! each ..@scope + (/////generation.context archive))] + (/////generation.with_anchor [1 scope] + (statement expression archive bodyS)))) + .let [arityO (|> arity .int _.i32) + @num_args (_.var "num_args") + @scope (..@scope function_name) + @self (_.var (///reference.artifact function_name)) + apply_poly (.function (_ args func) + (|> func (_.do "apply" (list _.null args)))) + initialize_self! (_.define (//case.register 0) @self) + initialize! (list#mix (.function (_ post pre!) + (all _.then + pre! + (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments)))) + initialize_self! + (list.indices arity))] + environment (monad.each ! (expression archive) environment) + .let [[definition instantiation] (with_closure @self environment + (all _.then + (_.define @num_args (_.the "length" @@arguments)) + (<| (_.if (|> @num_args (_.= arityO)) + (all _.then + initialize! + (_.with_label (_.label @scope) + (_.do_while (_.boolean true) + body!)))) + (_.if (|> @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)))] + (all _.then + (_.define @curried all_inputs) + (_.return (_.closure (list) + (let [@missing all_inputs] + (_.return (apply_poly (_.do "concat" (list @missing) @curried) + @self)))))))) + ))] + _ (/////generation.execute! definition) + _ (/////generation.save! (product.right function_name) {.#None} definition)] + (in instantiation))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/loop.lux new file mode 100644 index 000000000..bac543584 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/loop.lux @@ -0,0 +1,116 @@ +(.require + [library + [lux (.except Scope) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [math + [number + ["n" nat]]] + [meta + [target + ["_" js (.only Computation Var Expression Statement)]]]]] + ["[0]" // + [runtime (.only Operation Phase Phase! Generator Generator!)] + ["[1][0]" case] + ["///[1]" //// + [synthesis (.only Scope Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + ["[1][0]" phase] + [reference + [variable (.only Register)]]]]]) + +(def @scope + (-> Nat Text) + (|>> %.nat (format "scope"))) + +(def $iteration + (-> Nat Var) + (|>> %.nat (format "iteration") _.var)) + +(def (setup $iteration initial? offset bindings body) + (-> Var Bit Register (List Expression) Statement Statement) + (case bindings + (list) + body + + (list binding) + (let [$binding (//case.register offset)] + (all _.then + (if initial? + (_.define $binding binding) + (_.set $binding binding)) + body + )) + + _ + (|> bindings + list.enumeration + (list#each (function (_ [register _]) + (let [variable (//case.register (n.+ offset register))] + (if initial? + (_.define variable (_.at (_.i32 (.int register)) $iteration)) + (_.set variable (_.at (_.i32 (.int register)) $iteration)))))) + list.reversed + (list#mix _.then body) + (_.then (_.define $iteration (_.array bindings)))))) + +(def .public (scope! statement expression archive [start initsS+ bodyS]) + (Generator! (Scope Synthesis)) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (statement expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [@scope (at ! each ..@scope /////generation.next) + initsO+ (monad.each ! (expression archive) initsS+) + body! (/////generation.with_anchor [start @scope] + (statement expression archive bodyS)) + $iteration (at ! each ..$iteration /////generation.next)] + (in (..setup $iteration + true start + initsO+ + (_.with_label (_.label @scope) + (_.do_while (_.boolean true) + body!))))))) + +(def .public (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [loop! (scope! statement expression archive [start initsS+ bodyS])] + (in (_.apply (_.closure (list) loop!) (list)))))) + +(def @temp + (_.var "lux_again_values")) + +(def .public (again! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do [! ///////phase.monad] + [[offset @scope] /////generation.anchor + argsO+ (monad.each ! (expression archive) argsS+) + $iteration (at ! each ..$iteration /////generation.next)] + (in (all _.then + (_.define @temp (_.array argsO+)) + (..setup $iteration + false offset + (|> argsO+ + list.enumeration + (list#each (function (_ [idx _]) + (_.at (_.i32 (.int idx)) @temp)))) + (_.continue_at (_.label @scope))))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/primitive.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/primitive.lux new file mode 100644 index 000000000..509108682 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/primitive.lux @@ -0,0 +1,22 @@ +(.require + [library + [lux (.except i64) + [meta + [target + ["_" js (.only Computation)]]]]] + ["[0]" // + ["[1][0]" runtime]]) + +(def .public bit + _.boolean) + +(def .public (i64 value) + (-> (I64 Any) Computation) + (//runtime.i64 (|> value //runtime.high .int _.i32) + (|> value //runtime.low .int _.i32))) + +(def .public f64 + _.number) + +(def .public text + _.string) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/reference.lux new file mode 100644 index 000000000..95393bf91 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/reference.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [meta + [target + ["_" js (.only Expression)]]]]] + [/// + [reference (.only System)]]) + +(def .public system + (System Expression) + (implementation + (def constant' _.var) + (def variable' _.var))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/runtime.lux new file mode 100644 index 000000000..270ff3256 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/runtime.lux @@ -0,0 +1,826 @@ +(.require + [library + [lux (.except i64 left right) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" sequence]]] + [math + [number (.only hex) + ["[0]" i64]]] + ["[0]" meta (.only) + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)]] + [target + ["_" js (.only Expression Var Computation Statement)]]]]] + ["[0]" /// + ["[1][0]" reference] + ["//[1]" /// + ["[1][0]" synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// (.only) + ["[1][0]" phase] + [reference + [variable (.only Register)]] + [meta + [archive (.only Output Archive) + ["[0]" registry (.only Registry)] + ["[0]" unit]]]]]]) + +(with_template [<name> <base>] + [(type .public <name> + (<base> [Register Text] Expression Statement))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type .public (Generator i) + (-> Phase Archive i (Operation Expression))) + +(type .public Phase! + (-> Phase Archive Synthesis (Operation Statement))) + +(type .public (Generator! i) + (-> Phase! Phase Archive i (Operation Statement))) + +(def .public high + (-> (I64 Any) (I64 Any)) + (i64.right_shifted 32)) + +(def .public low + (-> (I64 Any) (I64 Any)) + (let [mask (-- (i64.left_shifted 32 1))] + (|>> (i64.and mask)))) + +(def .public unit + Computation + (_.string /////synthesis.unit)) + +(def .public (flag value) + (-> Bit Computation) + (if value + (_.string "") + _.null)) + +(def (feature name definition) + (-> Var (-> Var Expression) Statement) + (_.define name (definition name))) + +(def .public with_vars + (syntax (_ [vars (<code>.tuple (<>.some <code>.local)) + body <code>.any]) + (do [! meta.monad] + [ids (monad.all ! (list.repeated (list.size vars) meta.seed))] + (in (list (` (let [(,* (|> vars + (list.zipped_2 ids) + (list#each (function (_ [id var]) + (list (code.local var) + (` (_.var (, (code.text (format "v" (%.nat id))))))))) + list.together))] + (, body)))))))) + +(def runtime + (syntax (_ [declaration (<>.or <code>.local + (<code>.form (<>.and <code>.local + (<>.some <code>.local)))) + code <code>.any]) + (macro.with_symbols [g!_ runtime] + (let [runtime_name (` (_.var (, (code.text (%.code runtime)))))] + (case declaration + {.#Left name} + (let [g!name (code.local name)] + (in (list (` (def .public (, g!name) + Var + (, runtime_name))) + + (` (def (, (code.local (format "@" name))) + Statement + (..feature (, runtime_name) + (function ((, g!_) (, g!name)) + (, code)))))))) + + {.#Right [name inputs]} + (let [g!name (code.local name) + inputsC (list#each code.local inputs) + inputs_typesC (list#each (function.constant (` _.Expression)) inputs)] + (in (list (` (def .public ((, g!name) (,* inputsC)) + (-> (,* inputs_typesC) Computation) + (_.apply (, runtime_name) (list (,* inputsC))))) + + (` (def (, (code.local (format "@" name))) + Statement + (..feature (, runtime_name) + (function ((, g!_) (, g!_)) + (..with_vars [(,* inputsC)] + (_.function (, g!_) (list (,* inputsC)) + (, code))))))))))))))) + +(def length + (-> Expression Computation) + (_.the "length")) + +(def last_index + (-> Expression Computation) + (|>> ..length (_.- (_.i32 +1)))) + +(def (last_element tuple) + (_.at (..last_index tuple) + tuple)) + +(with_expansions [<recur> (these (all _.then + (_.set lefts (_.- last_index_right lefts)) + (_.set tuple (_.at last_index_right tuple))))] + (runtime + (tuple//left lefts tuple) + (with_vars [last_index_right] + (<| (_.while (_.boolean true)) + (all _.then + (_.define last_index_right (..last_index tuple)) + (_.if (_.> lefts last_index_right) + ... No need for recursion + (_.return (_.at lefts tuple)) + ... Needs recursion + <recur>))))) + + (runtime + (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (<| (_.while (_.boolean true)) + (all _.then + (_.define last_index_right (..last_index tuple)) + (_.define right_index (_.+ (_.i32 +1) lefts)) + (<| (_.if (_.= last_index_right right_index) + (_.return (_.at right_index tuple))) + (_.if (_.> last_index_right right_index) + ... Needs recursion. + <recur>) + (_.return (_.do "slice" (list right_index) tuple))) + ))))) + +(def .public variant_tag_field "_lux_tag") +(def .public variant_flag_field "_lux_flag") +(def .public variant_value_field "_lux_value") + +(runtime + variant//new + (let [@this (_.var "this")] + (with_vars [tag is_last value] + (_.closure (list tag is_last value) + (all _.then + (_.set (_.the ..variant_tag_field @this) tag) + (_.set (_.the ..variant_flag_field @this) is_last) + (_.set (_.the ..variant_value_field @this) value) + ))))) + +(def .public (variant tag last? value) + (-> Expression Expression Expression Computation) + (_.new ..variant//new (list tag last? value))) + +(runtime + (sum//get sum expected::right? expected::lefts) + (let [mismatch! (_.return _.null) + actual::lefts (|> sum (_.the ..variant_tag_field)) + actual::right? (|> sum (_.the ..variant_flag_field)) + actual::value (|> sum (_.the ..variant_value_field)) + is_last? (_.= ..unit actual::right?) + recur! (all _.then + (_.set expected::lefts (|> expected::lefts + (_.- actual::lefts) + (_.- (_.i32 +1)))) + (_.set sum actual::value))] + (<| (_.while (_.boolean true)) + (_.if (_.= expected::lefts actual::lefts) + (_.if (_.= expected::right? actual::right?) + (_.return actual::value) + mismatch!)) + (_.if (_.< expected::lefts actual::lefts) + (_.if (_.= ..unit actual::right?) + recur! + mismatch!)) + (_.if (_.= ..unit expected::right?) + (_.return (..variant (|> actual::lefts + (_.- expected::lefts) + (_.- (_.i32 +1))) + actual::right? + actual::value))) + mismatch!))) + +(def left + (-> Expression Computation) + (..variant (_.i32 +0) (flag #0))) + +(def right + (-> Expression Computation) + (..variant (_.i32 +0) (flag #1))) + +(def none + Computation + (..left ..unit)) + +(def some + (-> Expression Computation) + ..right) + +(def runtime//structure + Statement + (all _.then + @tuple//left + @tuple//right + @variant//new + @sum//get + )) + +(runtime + (lux//try op) + (with_vars [ex] + (_.try (_.return (..right (_.apply_1 op ..unit))) + [ex (_.return (..left (|> ex (_.do "toString" (list)))))]))) + +(runtime + (lux//program_args inputs) + (with_vars [output idx] + (all _.then + (_.define output ..none) + (_.for idx + (..last_index inputs) + (_.>= (_.i32 +0) idx) + (_.-- idx) + (_.set output (..some (_.array (list (_.at idx inputs) + output))))) + (_.return output)))) + +(def runtime//lux + Statement + (all _.then + @lux//try + @lux//program_args + )) + +(def .public i64_low_field Text "_lux_low") +(def .public i64_high_field Text "_lux_high") + +(runtime + i64::new + (let [@this (_.var "this")] + (with_vars [high low] + (_.closure (list high low) + (all _.then + (_.set (_.the ..i64_high_field @this) high) + (_.set (_.the ..i64_low_field @this) low) + ))))) + +(def .public (i64 high low) + (-> Expression Expression Computation) + (_.new ..i64::new (list high low))) + +(with_template [<name> <op>] + [(runtime + (<name> subject parameter) + (_.return (..i64 (<op> (_.the ..i64_high_field subject) + (_.the ..i64_high_field parameter)) + (<op> (_.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 (_.bit_not (_.the ..i64_high_field value)) + (_.bit_not (_.the ..i64_low_field value))))) + +(def (cap_shift! shift) + (-> Var Statement) + (_.set shift (|> shift (_.bit_and (_.i32 +63))))) + +(def (no_shift! shift input) + (-> Var Var (-> Expression Expression)) + (_.? (|> shift (_.= (_.i32 +0))) + input)) + +(def small_shift? + (-> Var Expression) + (|>> (_.< (_.i32 +32)))) + +(runtime + (i64::left_shifted input shift) + (all _.then + (..cap_shift! shift) + (_.return (<| (..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))] + (..i64 high low))) + (let [high (|> input (_.the ..i64_low_field) (_.left_shift (_.- (_.i32 +32) shift)))] + (..i64 high (_.i32 +0))))) + )) + +(runtime + (i64::arithmetic_right_shifted input shift) + (all _.then + (..cap_shift! shift) + (_.return (<| (..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))))))] + (..i64 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)))] + (..i64 high low)))))) + +(runtime + (i64::right_shifted input shift) + (all _.then + (..cap_shift! shift) + (_.return (<| (..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))))))] + (..i64 high low))) + (_.? (|> shift (_.= (_.i32 +32))) + (..i64 (_.i32 +0) (|> input (_.the ..i64_high_field)))) + (..i64 (_.i32 +0) + (|> input (_.the ..i64_high_field) (_.logic_right_shift (_.- (_.i32 +32) shift)))))))) + +(def runtime//bit + Statement + (all _.then + @i64::and + @i64::or + @i64::xor + @i64::not + @i64::left_shifted + @i64::arithmetic_right_shifted + @i64::right_shifted + )) + +(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::number i64) + (_.return (|> i64 + (_.the ..i64_high_field) + (_.* i64::2^32) + (_.+ (i64::unsigned_low i64))))) + +(runtime + i64::zero + (..i64 (_.i32 +0) (_.i32 +0))) + +(runtime + i64::min + (..i64 (_.i32 (.int (hex "80,00,00,00"))) + (_.i32 +0))) + +(runtime + i64::max + (..i64 (_.i32 (.int (hex "7F,FF,FF,FF"))) + (_.i32 (.int (hex "FF,FF,FF,FF"))))) + +(runtime + i64::one + (..i64 (_.i32 +0) (_.i32 +1))) + +(runtime + (i64::= reference sample) + (_.return (_.and (_.= (_.the ..i64_high_field reference) + (_.the ..i64_high_field sample)) + (_.= (_.the ..i64_low_field reference) + (_.the ..i64_low_field sample))))) + +(runtime + (i64::+ parameter subject) + (let [up_16 (_.left_shift (_.i32 +16)) + high_16 (_.logic_right_shift (_.i32 +16)) + low_16 (_.bit_and (_.i32 (.int (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] + (all _.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) + (_.+ l16) + (_.+ r16))) + (_.set x00 (low_16 x00)) + + (_.define x32 (|> (high_16 x16) + (_.+ l32) + (_.+ r32))) + (_.set x16 (low_16 x16)) + + (_.define x48 (|> (high_16 x32) + (_.+ l48) + (_.+ r48) + low_16)) + (_.set x32 (low_16 x32)) + + (_.return (..i64 (_.bit_or (up_16 x48) x32) + (_.bit_or (up_16 x16) x00))) + )))) + +(runtime + (i64::opposite value) + (_.return (_.? (i64::= i64::min value) + i64::min + (i64::+ i64::one (i64::not value))))) + +(runtime + i64::-one + (i64::opposite i64::one)) + +(runtime + (i64::of_number value) + (_.return (<| (_.? (_.not_a_number? value) + i64::zero) + (_.? (_.<= (_.opposite i64::2^63) value) + i64::min) + (_.? (|> value (_.+ (_.i32 +1)) (_.>= i64::2^63)) + i64::max) + (_.? (|> value (_.< (_.i32 +0))) + (|> value _.opposite i64::of_number i64::opposite)) + (..i64 (|> value (_./ i64::2^32) _.to_i32) + (|> value (_.% i64::2^32) _.to_i32))))) + +(runtime + (i64::- parameter subject) + (_.return (i64::+ (i64::opposite parameter) subject))) + +(runtime + (i64::* parameter subject) + (let [up_16 (_.left_shift (_.i32 +16)) + high_16 (_.logic_right_shift (_.i32 +16)) + low_16 (_.bit_and (_.i32 (.int (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] + (all _.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 (_.bit_or (up_16 x48) x32) + (_.bit_or (up_16 x16) x00))) + )))) + +(runtime + (i64::< parameter subject) + (let [negative? (|>> (_.the ..i64_high_field) (_.< (_.i32 +0)))] + (with_vars [-subject? -parameter?] + (all _.then + (_.define -subject? (negative? subject)) + (_.define -parameter? (negative? parameter)) + (_.return (<| (_.? (_.and -subject? (_.not -parameter?)) + (_.boolean true)) + (_.? (_.and (_.not -subject?) -parameter?) + (_.boolean false)) + (negative? (i64::- parameter subject)))) + )))) + +(def (i64::<= param subject) + (-> Expression Expression Expression) + (|> (i64::< param subject) + (_.or (i64::= param subject)))) + +(def negative? + (i64::< i64::zero)) + +(runtime + (i64::/ parameter subject) + (<| (_.if (i64::= i64::zero parameter) + (_.throw (_.string "Cannot divide by zero!"))) + (_.if (i64::= i64::zero subject) + (_.return i64::zero)) + (_.if (i64::= i64::min subject) + (<| (_.if (_.or (i64::= i64::one parameter) + (i64::= i64::-one parameter)) + (_.return i64::min)) + (_.if (i64::= i64::min parameter) + (_.return i64::one)) + (with_vars [approximation] + (let [subject/2 (..i64::arithmetic_right_shifted subject (_.i32 +1))] + (all _.then + (_.define approximation (i64::left_shifted (i64::/ parameter + subject/2) + (_.i32 +1))) + (_.if (i64::= i64::zero approximation) + (_.return (_.? (..negative? parameter) + i64::one + i64::-one)) + (let [remainder (i64::- (i64::* approximation + parameter) + subject)] + (_.return (i64::+ (i64::/ parameter + remainder) + approximation))))))))) + (_.if (i64::= i64::min parameter) + (_.return i64::zero)) + (_.if (..negative? subject) + (_.return (_.? (..negative? parameter) + (i64::/ (i64::opposite parameter) + (i64::opposite subject)) + (i64::opposite (i64::/ parameter + (i64::opposite subject)))))) + (_.if (..negative? parameter) + (_.return (i64::opposite (i64::/ (i64::opposite parameter) subject)))) + (with_vars [result remainder] + (all _.then + (_.define result i64::zero) + (_.define remainder subject) + (_.while (i64::<= remainder parameter) + (with_vars [approximate approximate_result approximate_remainder log2 delta] + (let [approximate_result' (i64::of_number approximate) + approx_remainder (i64::* parameter approximate_result)] + (all _.then + (_.define approximate (|> (i64::number remainder) + (_./ (i64::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) + (_.apply_2 (_.var "Math.pow") + (_.i32 +2) + (_.- (_.i32 +48) + log2)) + (_.i32 +1))) + (_.define approximate_result approximate_result') + (_.define approximate_remainder approx_remainder) + (_.while (_.or (..negative? approximate_remainder) + (i64::< approximate_remainder + remainder)) + (all _.then + (_.set approximate (_.- delta approximate)) + (_.set approximate_result approximate_result') + (_.set approximate_remainder approx_remainder))) + (_.set result (i64::+ (_.? (i64::= i64::zero approximate_result) + i64::one + approximate_result) + result)) + (_.set remainder (i64::- approximate_remainder remainder)))))) + (_.return result))))) + +(runtime + (i64::% parameter subject) + (let [flat (|> subject + (i64::/ parameter) + (i64::* parameter))] + (_.return (i64::- flat subject)))) + +(def runtime//i64 + Statement + (all _.then + ..runtime//bit + + @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::opposite + @i64::-one + @i64::number + @i64::of_number + @i64::- + @i64::* + @i64::< + @i64::/ + @i64::% + )) + +(runtime + (text//index start part text) + (with_vars [idx] + (all _.then + (_.define idx (|> text (_.do "indexOf" (list part (i64::number start))))) + (_.return (_.? (_.= (_.i32 -1) idx) + ..none + (..some (i64::of_number idx))))))) + +(runtime + (text//clip offset length text) + (_.return (|> text (_.do "substring" (list (_.the ..i64_low_field offset) + (_.+ (_.the ..i64_low_field offset) + (_.the ..i64_low_field length))))))) + +(runtime + (text//char idx text) + (with_vars [result] + (all _.then + (_.define result (|> text (_.do "charCodeAt" (list (_.the ..i64_low_field idx))))) + (_.if (_.not_a_number? result) + (_.throw (_.string "[Lux Error] Cannot get char from text.")) + (_.return (i64::of_number result)))))) + +(def runtime//text + Statement + (all _.then + @text//index + @text//clip + @text//char + )) + +(runtime + (io//log message) + (let [console (_.var "console") + print (_.var "print") + end! (_.return ..unit)] + (<| (_.if (|> console _.type_of (_.= (_.string "undefined")) _.not + (_.and (_.the "log" console))) + (all _.then + (_.statement (|> console (_.do "log" (list message)))) + end!)) + (_.if (|> print _.type_of (_.= (_.string "undefined")) _.not) + (all _.then + (_.statement (_.apply_1 print (_.? (_.= (_.string "string") + (_.type_of message)) + message + (_.apply_1 (_.var "JSON.stringify") message)))) + end!)) + end!))) + +(runtime + (io//error message) + (_.throw message)) + +(def runtime//io + Statement + (all _.then + @io//log + @io//error + )) + +(runtime + (js//get object field) + (with_vars [temp] + (all _.then + (_.define temp (_.at field object)) + (_.return (_.? (_.= _.undefined temp) + ..none + (..some temp)))))) + +(runtime + (js//set object field input) + (all _.then + (_.set (_.at field object) input) + (_.return object))) + +(runtime + (js//delete object field) + (all _.then + (_.statement (_.delete (_.at field object))) + (_.return object))) + +(def runtime//js + Statement + (all _.then + @js//get + @js//set + @js//delete + )) + +(runtime + (array//write idx value array) + (all _.then + (_.set (_.at (_.the ..i64_low_field idx) array) value) + (_.return array))) + +(runtime + (array//delete idx array) + (all _.then + (_.statement (_.delete (_.at (_.the ..i64_low_field idx) array))) + (_.return array))) + +(def runtime//array + Statement + (all _.then + @array//write + @array//delete + )) + +(def runtime + Statement + (all _.then + runtime//structure + runtime//i64 + runtime//text + runtime//io + runtime//js + runtime//array + runtime//lux + )) + +(def module_id + 0) + +(def .public generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..module_id {.#None} ..runtime)] + (in [(|> registry.empty + (registry.resource true unit.none) + product.right) + (sequence.sequence [..module_id + {.#None} + (|> ..runtime + _.code + (at utf8.codec encoded))])]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/structure.lux new file mode 100644 index 000000000..e5a492e37 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/js/structure.lux @@ -0,0 +1,37 @@ +(.require + [library + [lux (.except Variant Tuple) + [abstract + ["[0]" monad (.only do)]] + [meta + [target + ["_" js (.only Expression)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" primitive] + ["///[1]" //// + ["[1][0]" synthesis (.only Synthesis)] + [analysis + [complex (.only Variant Tuple)]] + ["//[1]" /// (.only) + ["[1][0]" phase (.use "[1]#[0]" monad)]]]]) + +(def .public (tuple generate archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + {.#End} + (///////phase#in //runtime.unit) + + {.#Item singletonS {.#End}} + (generate archive singletonS) + + _ + (do [! ///////phase.monad] + [elemsT+ (monad.each ! (generate archive) elemsS+)] + (in (_.array elemsT+))))) + +(def .public (variant generate archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (///////phase#each (//runtime.variant (_.i32 (.int lefts)) + (//runtime.flag right?)) + (generate archive valueS))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm.lux new file mode 100644 index 000000000..b1fa42f27 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm.lux @@ -0,0 +1,79 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [meta + [macro + ["^" pattern]]]]] + ["[0]" / + [runtime (.only Phase)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" function] + ["[1][0]" case] + ["[1][0]" loop] + ["//[1]" /// + ["[1][0]" extension] + [// + ["[0]" synthesis] + [/// + ["[0]" reference] + ["[1]" phase (.use "[1]#[0]" monad)]]]]]) + +(def .public (generate archive synthesis) + Phase + (case synthesis + (^.with_template [<tag> <generator>] + [(<tag> value) + (///#in (<generator> value))]) + ([synthesis.bit /primitive.bit] + [synthesis.i64 /primitive.i64] + [synthesis.f64 /primitive.f64] + [synthesis.text /primitive.text]) + + (synthesis.variant variantS) + (/structure.variant generate archive variantS) + + (synthesis.tuple members) + (/structure.tuple generate archive members) + + {synthesis.#Reference reference} + (case reference + {reference.#Variable variable} + (/reference.variable archive variable) + + {reference.#Constant constant} + (/reference.constant archive constant)) + + (synthesis.branch/case [valueS pathS]) + (/case.case generate archive [valueS pathS]) + + (synthesis.branch/exec [this that]) + (/case.exec generate archive [this that]) + + (synthesis.branch/let [inputS register bodyS]) + (/case.let generate archive [inputS register bodyS]) + + (synthesis.branch/if [conditionS thenS elseS]) + (/case.if generate archive [conditionS thenS elseS]) + + (synthesis.branch/get [path recordS]) + (/case.get generate archive [path recordS]) + + (synthesis.loop/scope scope) + (/loop.scope generate archive scope) + + (synthesis.loop/again updates) + (/loop.again generate archive updates) + + (synthesis.function/abstraction abstraction) + (/function.abstraction generate archive abstraction) + + (synthesis.function/apply application) + (/function.apply generate archive application) + + {synthesis.#Extension extension} + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/case.lux new file mode 100644 index 000000000..f5d258fbb --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/case.lux @@ -0,0 +1,327 @@ +(.require + [library + [lux (.except Type Label if let exec case int) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" function]] + [data + [collection + ["[0]" list (.use "[1]#[0]" mix)]] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]]] + [math + [number + ["n" nat] + ["[0]" i32]]] + [meta + [macro + ["^" pattern]] + [target + [jvm + ["_" bytecode (.only Label Bytecode) (.use "[1]#[0]" monad) + [environment + [limit + ["[0]" stack]]]] + ["[0]" type (.only Type) + [category (.only Method)]]]]]]] + ["[0]" // + ["[1][0]" type] + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" value] + ["[1][0]" structure] + [//// + ["[0]" generation] + ["[0]" synthesis (.only Path Fork Synthesis) + [access + ["[0]" member (.only Member)]]] + [/// + ["[0]" phase (.use "operation#[0]" monad)] + [reference + [variable (.only Register)]]]]]) + +(def (pop_alt stack_depth) + (-> Nat (Bytecode Any)) + (.case stack_depth + 0 (_#in []) + 1 _.pop + 2 _.pop2 + _ ... (n.> 2) + (all _.composite + _.pop2 + (pop_alt (n.- 2 stack_depth))))) + +(def int + (-> (I64 Any) (Bytecode Any)) + (|>> .i64 i32.i32 _.int)) + +(def long + (-> (I64 Any) (Bytecode Any)) + (|>> .int _.long)) + +(def peek + (Bytecode Any) + (all _.composite + _.dup + (//runtime.get //runtime.stack_head))) + +(def pop + (Bytecode Any) + (all _.composite + (//runtime.get //runtime.stack_tail) + (_.checkcast //type.stack))) + +(def (left_projection lefts) + (-> Nat (Bytecode Any)) + (all _.composite + (_.checkcast //type.tuple) + (..int lefts) + (.case lefts + 0 + _.aaload + + lefts + //runtime.left_projection))) + +(def (right_projection lefts) + (-> Nat (Bytecode Any)) + (all _.composite + (_.checkcast //type.tuple) + (..int lefts) + //runtime.right_projection)) + +(def equals@Object + (.let [class (type.class "java.lang.Object" (list)) + method (type.method [(list) (list //type.value) type.boolean (list)])] + (_.invokevirtual class "equals" method))) + +(def (path|bind register) + (-> Register (Operation (Bytecode Any))) + (operation#in (all _.composite + ..peek + (_.astore register)))) + +(def (path|bit_fork again @else [when thenP elseP]) + (-> (-> Path (Operation (Bytecode Any))) + Label [Bit Path (Maybe Path)] + (Operation (Bytecode Any))) + (do phase.monad + [then! (again thenP) + else! (.case elseP + {.#Some elseP} + (again elseP) + + {.#None} + (in (_.goto @else))) + .let [if! (.if when _.ifeq _.ifne)]] + (in (do _.monad + [@else _.new_label] + (all _.composite + ..peek + (//value.unwrap type.boolean) + (if! @else) + then! + (_.set_label @else) + else!))))) + +(with_template [<name> <type> <unwrap> <dup> <pop> <test> <comparison> <if>] + [(def (<name> again @else cons) + (-> (-> Path (Operation (Bytecode Any))) + Label (Fork <type> Path) + (Operation (Bytecode Any))) + (do [! phase.monad] + [fork! (monad.mix ! (function (_ [test thenP] else!) + (do ! + [then! (again thenP)] + (in (do _.monad + [@else _.new_label] + (all _.composite + <dup> + (<test> test) + <comparison> + (<if> @else) + <pop> + then! + (_.set_label @else) + else!))))) + (all _.composite + <pop> + (_.goto @else)) + {.#Item cons})] + (in (all _.composite + ..peek + <unwrap> + fork!))))] + + [path|i64_fork (I64 Any) (//value.unwrap type.long) _.dup2 _.pop2 ..long _.lcmp _.ifne] + [path|f64_fork Frac (//value.unwrap type.double) _.dup2 _.pop2 _.double _.dcmpl _.ifne] + [path|text_fork Text (at _.monad in []) _.dup _.pop _.string ..equals@Object _.ifeq] + ) + +(def (path' stack_depth @else @end phase archive) + (-> Nat Label Label (Generator Path)) + (function (again path) + (.case path + {synthesis.#Pop} + (operation#in ..pop) + + {synthesis.#Bind register} + (..path|bind register) + + (^.with_template [<tag> <path>] + [{<tag> it} + (<path> again @else it)]) + ([synthesis.#Bit_Fork ..path|bit_fork] + [synthesis.#I64_Fork ..path|i64_fork] + [synthesis.#F64_Fork ..path|f64_fork] + [synthesis.#Text_Fork ..path|text_fork]) + + {synthesis.#Then bodyS} + (do phase.monad + [body! (phase archive bodyS)] + (in (all _.composite + (..pop_alt stack_depth) + body! + (_.when_continuous (_.goto @end))))) + + (synthesis.side lefts right?) + (operation#in + (do _.monad + [@success _.new_label] + (all _.composite + ..peek + (_.checkcast //type.variant) + (//structure.lefts lefts) + (//structure.right? right?) + //runtime.case + _.dup + (_.ifnonnull @success) + _.pop + (_.goto @else) + (_.set_label @success) + //runtime.push))) + + (^.with_template [<pattern> <projection>] + [(<pattern> lefts) + (operation#in (all _.composite + ..peek + (<projection> lefts) + //runtime.push)) + + ... Extra optimization + (synthesis.path/seq + (<pattern> lefts) + (synthesis.!bind_top register thenP)) + (do phase.monad + [then! (path' stack_depth @else @end phase archive thenP)] + (in (all _.composite + ..peek + (<projection> lefts) + (_.astore register) + then!)))]) + ([synthesis.member/left ..left_projection] + [synthesis.member/right ..right_projection]) + + {synthesis.#Seq leftP rightP} + (do phase.monad + [left! (path' stack_depth @else @end phase archive leftP) + right! (path' stack_depth @else @end phase archive rightP)] + (in (all _.composite + left! + right!))) + + {synthesis.#Alt leftP rightP} + (do phase.monad + [@alt_else //runtime.forge_label + left! (path' (++ stack_depth) @alt_else @end phase archive leftP) + right! (path' stack_depth @else @end phase archive rightP)] + (in (all _.composite + _.dup + left! + (_.set_label @alt_else) + _.pop + right!))) + ))) + +(def (path @end phase archive path) + (-> Label (Generator Path)) + (do phase.monad + [@else //runtime.forge_label + path! (..path' 1 @else @end phase archive path)] + (in (all _.composite + path! + (<| (_.when_acknowledged @else) + (all _.composite + (_.set_label @else) + //runtime.pm_failure + (_.goto @end) + )) + )))) + +(def .public (if phase archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do phase.monad + [test! (phase archive testS) + then! (phase archive thenS) + else! (phase archive elseS)] + (in (do _.monad + [@else _.new_label + @end _.new_label] + (all _.composite + test! + (//value.unwrap type.boolean) + (_.ifeq @else) + then! + (_.when_continuous (_.goto @end)) + (_.set_label @else) + else! + (<| (_.when_acknowledged @end) + (_.set_label @end))))))) + +(def .public (exec phase archive [this that]) + (Generator [Synthesis Synthesis]) + (do phase.monad + [this! (phase archive this) + that! (phase archive that)] + (in (all _.composite + this! + _.pop + that!)))) + +(def .public (let phase archive [inputS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do phase.monad + [input! (phase archive inputS) + body! (phase archive bodyS)] + (in (all _.composite + input! + (_.astore register) + body!)))) + +(def .public (get phase archive [path recordS]) + (Generator [(List Member) Synthesis]) + (do phase.monad + [record! (phase archive recordS)] + (in (list#mix (function (_ step so_far!) + (.let [next! (.if (the member.#right? step) + (..right_projection (the member.#lefts step)) + (..left_projection (the member.#lefts step)))] + (all _.composite + so_far! + next!))) + record! + (list.reversed path))))) + +(def .public (case phase archive [valueS path]) + (Generator [Synthesis Path]) + (do phase.monad + [@end //runtime.forge_label + value! (phase archive valueS) + path! (..path @end phase archive path)] + (in (all _.composite + _.aconst_null + value! + //runtime.push + path! + (<| (_.when_acknowledged @end) + (_.set_label @end)))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/debug.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/debug.lux new file mode 100644 index 000000000..b983c3b7d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/debug.lux @@ -0,0 +1,31 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" io (.only IO)] + ["[0]" try (.only Try)]] + [data + [binary (.only Binary)] + [text + ["%" \\format (.only format)]]] + [world + ["[0]" file (.only File)]]]]) + +(def extension ".class") + +(def .public (write_class! name bytecode) + (-> Text Binary (IO Text)) + (let [file_path (format name ..extension)] + (do io.monad + [outcome (do (try.with @) + [file (is (IO (Try (File IO))) + (file.get_file io.monad file.default file_path))] + (at file over_write bytecode))] + (in (case outcome + {try.#Success definition} + file_path + + {try.#Failure error} + error))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function.lux new file mode 100644 index 000000000..b150e4536 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function.lux @@ -0,0 +1,193 @@ +(.require + [library + [lux (.except Type Label with) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + [binary + ["[0]" \\format]] + [collection + ["[0]" list (.use "[1]#[0]" monoid functor)] + ["[0]" sequence]]] + [math + [number + ["n" nat] + ["[0]" i32]]] + [meta + [target + [jvm + ["_" bytecode (.only Label Bytecode) (.use "[1]#[0]" monad)] + ["[0]" version] + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + ["[0]" field (.only Field)] + ["[0]" method (.only Method)] + ["[0]" class (.only Class)] + ["[0]" type (.only Type) + [category (.only Return' Value')] + ["[0]" reflection]] + ["[0]" constant (.only) + [pool (.only Resource)]] + [encoding + ["[0]" name (.only External Internal)] + ["[0]" unsigned]]]] + [compiler + [meta + ["[0]" archive (.only Archive)] + ["[0]" cache + [dependency + ["[1]/[0]" artifact]]]]]]]] + ["[0]" / + ["[1][0]" abstract] + [field + [constant + ["[1][0]" arity]] + [variable + ["[1][0]" foreign] + ["[1][0]" partial]]] + [method + ["[1][0]" init] + ["[1][0]" new] + ["[1][0]" implementation] + ["[1][0]" reset] + ["[1][0]" apply]] + ["/[1]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" reference] + [//// + [analysis (.only Environment)] + ["[0]" synthesis (.only Synthesis Abstraction Apply)] + ["[0]" generation] + [/// + ["[0]" arity (.only Arity)] + ["[0]" phase] + [meta + [archive + ["[0]" unit]]] + [reference + [variable (.only Register)]]]]]]) + +(def .public (with generate archive @begin class environment arity body) + (-> Phase Archive Label External (Environment Synthesis) Arity (Bytecode Any) + (Operation [(List (Resource Field)) + (List (Resource Method)) + (Bytecode Any)])) + (let [classT (type.class class (list)) + fields (is (List (Resource Field)) + (list#composite (/foreign.variables environment) + (/partial.variables arity))) + methods (is (List (Resource Method)) + (list.partial (/init.method classT environment arity) + (/reset.method classT environment arity) + (if (arity.multiary? arity) + (|> (n.min arity /arity.maximum) + list.indices + (list#each (|>> ++ (/apply.method classT environment arity @begin body))) + (list.partial (/implementation.method classT arity @begin body))) + (list (/implementation.method classT arity @begin body) + (/apply.method classT environment arity @begin body 1)))))] + (do phase.monad + [instance (/new.instance generate archive classT environment arity)] + (in [fields methods instance])))) + +(def modifier + (Modifier Class) + (all modifier#composite + class.public + class.final)) + +(def this_offset 1) + +(def internal + (All (_ category) + (-> (Type (<| Return' Value' category)) + Internal)) + (|>> type.reflection reflection.reflection name.internal)) + +(def .public (abstraction generate archive [environment arity bodyS]) + (Generator Abstraction) + (do phase.monad + [dependencies (cache/artifact.dependencies archive bodyS) + @begin //runtime.forge_label + [function_context bodyG] (generation.with_new_context archive dependencies + (generation.with_anchor [@begin ..this_offset] + (generate archive bodyS))) + .let [function_class (//runtime.class_name function_context)] + [fields methods instance] (..with generate archive @begin function_class environment arity bodyG) + class (phase.lifted (class.class version.v6_0 + ..modifier + (name.internal function_class) + {.#None} + (..internal /abstract.class) (list) + fields + methods + (sequence.sequence))) + .let [bytecode [function_class (\\format.result class.format class)]] + _ (generation.execute! bytecode) + _ (generation.save! (product.right function_context) {.#None} bytecode)] + (in instance))) + +(def (apply/?' generate archive [abstractionG inputsS]) + (Generator [(Bytecode Any) (List Synthesis)]) + (do [! phase.monad] + [inputsG (monad.each ! (generate archive) inputsS)] + (in (all _.composite + abstractionG + (|> inputsG + (list.sub /arity.maximum) + (monad.each _.monad + (function (_ batchG) + (all _.composite + (_.checkcast /abstract.class) + (monad.all _.monad batchG) + (_.invokevirtual /abstract.class //runtime.apply::name (//runtime.apply::type (list.size batchG))) + )))) + )))) + +(def (apply/? generate archive [abstractionS inputsS]) + (Generator Apply) + (do [! phase.monad] + [abstractionG (generate archive abstractionS)] + (apply/?' generate archive [abstractionG inputsS]))) + +(def (apply/= generate archive [$abstraction @abstraction arity inputsS]) + (Generator [Symbol unit.ID Arity (List Synthesis)]) + (do [! phase.monad] + [.let [:abstraction: (type.class (//runtime.class_name @abstraction) (list))] + abstractionG (//reference.constant archive $abstraction) + inputsG (monad.each ! (generate archive) inputsS)] + (in (all _.composite + abstractionG + (monad.all _.monad inputsG) + (/implementation.call :abstraction: arity) + )))) + +(def (apply/> generate archive [$abstraction @abstraction arity inputsS]) + (Generator [Symbol unit.ID Arity (List Synthesis)]) + (do [! phase.monad] + [=G (apply/= generate archive [$abstraction @abstraction arity (list.first arity inputsS)])] + (apply/?' generate archive [=G (list.after arity inputsS)]))) + +(def .public (apply generate archive [abstractionS inputsS]) + (Generator Apply) + (case abstractionS + (synthesis.constant $abstraction) + (do [! phase.monad] + [[@definition |abstraction|] (generation.definition archive $abstraction) + .let [actual_arity (list.size inputsS)]] + (case |abstraction| + {.#Some [_ {.#Some [expected_arity @abstraction]}]} + (cond (n.< expected_arity actual_arity) + (apply/? generate archive [abstractionS inputsS]) + + (n.= expected_arity actual_arity) + (apply/= generate archive [$abstraction @abstraction expected_arity inputsS]) + + ... (n.> expected_arity actual_arity) + (apply/> generate archive [$abstraction @abstraction expected_arity inputsS])) + + _ + (apply/? generate archive [abstractionS inputsS]))) + + _ + (apply/? generate archive [abstractionS inputsS]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/abstract.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/abstract.lux new file mode 100644 index 000000000..ea783b42a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/abstract.lux @@ -0,0 +1,26 @@ +(.require + [library + [lux (.except Type) + [data + [text + ["%" \\format]]] + [meta + [target + [jvm + ["[0]" type (.only Type) + [category (.only Method)]]]]]]] + [// + [field + [constant + ["[0]" arity]]]]) + +... (def .public artifact_id +... 1) + +(def .public class + ... (type.class (%.nat artifact_id) (list)) + (type.class "library.lux.Function" (list))) + +(def .public init + (Type Method) + (type.method [(list) (list arity.type) type.void (list)])) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/constant.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/constant.lux new file mode 100644 index 000000000..31fb77c7b --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/constant.lux @@ -0,0 +1,27 @@ +(.require + [library + [lux (.except Type) + [data + [collection + ["[0]" sequence]]] + [meta + [target + [jvm + ["[0]" field (.only Field)] + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + [type (.only Type) + [category (.only Value)]] + [constant + [pool (.only Resource)]]]]]]]) + +(def modifier + (Modifier Field) + (all modifier#composite + field.public + field.static + field.final + )) + +(def .public (constant name type) + (-> Text (Type Value) (Resource Field)) + (field.field ..modifier name #0 type (sequence.sequence))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux new file mode 100644 index 000000000..0f7856172 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux @@ -0,0 +1,17 @@ +(.require + [library + [lux (.except type) + [meta + [target + [jvm + ["[0]" type] + [constant + [pool (.only Resource)]]]]]]] + ["[0]" // + [///////// + [arity (.only Arity)]]]) + +(def .public minimum Arity 1) +(def .public maximum Arity 8) + +(def .public type type.int) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable.lux new file mode 100644 index 000000000..539f43afe --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable.lux @@ -0,0 +1,57 @@ +(.require + [library + [lux (.except Type type) + [data + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" sequence]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + ["[0]" field (.only Field)] + [type (.only Type) + [category (.only Value Class)]] + [constant + [pool (.only Resource)]]]]]]] + ["[0]" //// + ["[1][0]" type] + ["[1][0]" reference] + [////// + [reference + [variable (.only Register)]]]]) + +(def .public type ////type.value) + +(def .public (get class name) + (-> (Type Class) Text (Bytecode Any)) + (all _.composite + ////reference.this + (_.getfield class name ..type) + )) + +(def .public (put naming class register value) + (-> (-> Register Text) (Type Class) Register (Bytecode Any) (Bytecode Any)) + (all _.composite + ////reference.this + value + (_.putfield class (naming register) ..type))) + +(def modifier + (Modifier Field) + (all modifier#composite + field.private + field.final + )) + +(def .public (variable name type) + (-> Text (Type Value) (Resource Field)) + (field.field ..modifier name #0 type (sequence.sequence))) + +(def .public (variables naming amount) + (-> (-> Register Text) Nat (List (Resource Field))) + (|> amount + list.indices + (list#each (function (_ register) + (..variable (naming register) ..type))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable/count.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable/count.lux new file mode 100644 index 000000000..c58fad6cf --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable/count.lux @@ -0,0 +1,35 @@ +(.require + [library + [lux (.except type) + [control + ["[0]" try]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" type] + [encoding + [name (.only External)] + ["[0]" signed]]]]]]] + ["[0]" //// + ["[1][0]" abstract]]) + +(def .public field "partials") +(def .public type type.int) + +(def .public initial + (Bytecode Any) + (|> +0 + signed.s1 + try.trusted + _.bipush)) + +(def this + _.aload_0) + +(def .public value + (Bytecode Any) + (all _.composite + ..this + (_.getfield ////abstract.class ..field ..type) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux new file mode 100644 index 000000000..b8f01c6f1 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux @@ -0,0 +1,40 @@ +(.require + [library + [lux (.except Type) + [data + [collection + ["[0]" list]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" field (.only Field)] + [constant + [pool (.only Resource)]] + [type (.only Type) + [category (.only Value Class)]]]]]]] + ["[0]" // (.only) + ["///[1]" //// + ["[1][0]" reference] + [//// + [analysis (.only Environment)] + [synthesis (.only Synthesis)] + [/// + [reference + [variable (.only Register)]]]]]]) + +(def .public (closure environment) + (-> (Environment Synthesis) (List (Type Value))) + (list.repeated (list.size environment) //.type)) + +(def .public (get class register) + (-> (Type Class) Register (Bytecode Any)) + (//.get class (/////reference.foreign_name register))) + +(def .public (put class register value) + (-> (Type Class) Register (Bytecode Any) (Bytecode Any)) + (//.put /////reference.foreign_name class register value)) + +(def .public variables + (-> (Environment Synthesis) (List (Resource Field))) + (|>> list.size (//.variables /////reference.foreign_name))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux new file mode 100644 index 000000000..7310e30ce --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux @@ -0,0 +1,59 @@ +(.require + [library + [lux (.except Type) + [abstract + ["[0]" monad]] + [data + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [math + [number + ["n" nat]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode) (.use "[1]#[0]" monad)] + ["[0]" field (.only Field)] + [type (.only Type) + [category (.only Class)]] + [constant + [pool (.only Resource)]]]]]]] + ["[0]" // (.only) + ["[1][0]" count] + ["/[1]" // + [constant + ["[1][0]" arity]] + ["//[1]" /// + ["[1][0]" reference] + [////// + ["[0]" arity (.only Arity)] + [reference + [variable (.only Register)]]]]]]) + +(def .public (initial amount) + (-> Nat (Bytecode Any)) + (all _.composite + (|> _.aconst_null + (list.repeated amount) + (monad.all _.monad)) + (_#in []))) + +(def .public (get class register) + (-> (Type Class) Register (Bytecode Any)) + (//.get class (/////reference.partial_name register))) + +(def .public (put class register value) + (-> (Type Class) Register (Bytecode Any) (Bytecode Any)) + (//.put /////reference.partial_name class register value)) + +(def .public variables + (-> Arity (List (Resource Field))) + (|>> (n.- ///arity.minimum) (//.variables /////reference.partial_name))) + +(def .public (new arity) + (-> Arity (Bytecode Any)) + (if (arity.multiary? arity) + (all _.composite + //count.initial + (initial (n.- ///arity.minimum arity))) + (_#in []))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method.lux new file mode 100644 index 000000000..b00454753 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method.lux @@ -0,0 +1,15 @@ +(.require + [library + [lux (.except) + [meta + [target + [jvm + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + ["[0]" method (.only Method)]]]]]]) + +(def .public modifier + (Modifier Method) + (all modifier#composite + method.public + method.strict + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/apply.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/apply.lux new file mode 100644 index 000000000..10de5d326 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/apply.lux @@ -0,0 +1,159 @@ +(.require + [library + [lux (.except Type Label) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" try]] + [data + [collection + ["[0]" list (.use "[1]#[0]" monoid functor)]]] + [math + [number + ["n" nat] + ["i" int] + ["[0]" i32]]] + [meta + [target + [jvm + ["_" bytecode (.only Label Bytecode) (.use "[1]#[0]" monad)] + ["[0]" method (.only Method)] + [constant + [pool (.only Resource)]] + [encoding + ["[0]" signed]] + ["[0]" type (.only Type) + ["[0]" category (.only Class)]]]]]]] + ["[0]" // (.only) + ["[1][0]" reset] + ["[1][0]" implementation] + ["[1][0]" init] + ["/[1]" // + ["[1][0]" abstract] + [field + [constant + ["[1][0]" arity]] + [variable + ["[1][0]" partial] + ["[1][0]" count] + ["[1][0]" foreign]]] + ["/[1]" // + ["[1][0]" runtime] + ["[1][0]" value] + ["[1][0]" reference] + [//// + [analysis (.only Environment)] + [synthesis (.only Synthesis)] + [/// + [arity (.only Arity)] + [reference + [variable (.only Register)]]]]]]]) + +(def (increment by) + (-> Nat (Bytecode Any)) + (all _.composite + (<| _.int .i64 by) + _.iadd)) + +(def (inputs offset amount) + (-> Register Nat (Bytecode Any)) + (all _.composite + (|> amount + list.indices + (monad.each _.monad (|>> (n.+ offset) _.aload))) + (_#in []) + )) + +(def (apply offset amount) + (-> Register Nat (Bytecode Any)) + (let [arity (n.min amount ///arity.maximum)] + (all _.composite + (_.checkcast ///abstract.class) + (..inputs offset arity) + (_.invokevirtual ///abstract.class ////runtime.apply::name (////runtime.apply::type arity)) + (if (n.> ///arity.maximum amount) + (apply (n.+ ///arity.maximum offset) + (n.- ///arity.maximum amount)) + (_#in [])) + ))) + +(def this_offset 1) + +(def .public (method class environment function_arity @begin body apply_arity) + (-> (Type Class) (Environment Synthesis) Arity Label (Bytecode Any) Arity (Resource Method)) + (let [num_partials (-- function_arity) + over_extent (i.- (.int apply_arity) + (.int function_arity))] + (method.method //.modifier ////runtime.apply::name + #0 (////runtime.apply::type apply_arity) + (list) + {.#Some (case num_partials + 0 (all _.composite + ////reference.this + (..inputs ..this_offset apply_arity) + (//implementation.call class function_arity) + _.areturn) + _ (do _.monad + [@default _.new_label + @labelsH _.new_label + @labelsT (|> _.new_label + (list.repeated (-- num_partials)) + (monad.all _.monad)) + .let [cases (|> (list#composite {.#Item [@labelsH @labelsT]} + (list @default)) + list.enumeration + (list#each (function (_ [stage @case]) + (let [current_partials (|> (list.indices stage) + (list#each (///partial.get class)) + (monad.all _.monad)) + already_partial? (n.> 0 stage) + exact_match? (i.= over_extent (.int stage)) + has_more_than_necessary? (i.> over_extent (.int stage))] + (all _.composite + (_.set_label @case) + (cond exact_match? + (all _.composite + ////reference.this + (if already_partial? + (_.invokevirtual class //reset.name (//reset.type class)) + (_#in [])) + current_partials + (..inputs ..this_offset apply_arity) + (//implementation.call class function_arity) + _.areturn) + + has_more_than_necessary? + (let [arity_inputs (|> function_arity (n.- stage)) + additional_inputs (|> apply_arity (n.- arity_inputs))] + (all _.composite + ////reference.this + (_.invokevirtual class //reset.name (//reset.type class)) + current_partials + (..inputs ..this_offset arity_inputs) + (//implementation.call class function_arity) + (apply (n.+ ..this_offset arity_inputs) additional_inputs) + _.areturn)) + + ... (i.< over_extent (.int stage)) + (let [current_environment (|> (list.indices (list.size environment)) + (list#each (///foreign.get class)) + (monad.all _.monad)) + missing_partials (|> _.aconst_null + (list.repeated (|> num_partials (n.- apply_arity) (n.- stage))) + (monad.all _.monad))] + (all _.composite + (_.new class) + _.dup + current_environment + ///count.value + (..increment apply_arity) + current_partials + (..inputs ..this_offset apply_arity) + missing_partials + (_.invokespecial class //init.name (//init.type environment function_arity)) + _.areturn))))))) + (monad.all _.monad))]] + (all _.composite + ///count.value + (_.tableswitch (try.trusted (signed.s4 +0)) @default [@labelsH @labelsT]) + cases)))}))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux new file mode 100644 index 000000000..65f3ef2bb --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux @@ -0,0 +1,59 @@ +(.require + [library + [lux (.except Type Label type) + [data + [collection + ["[0]" list]]] + [math + [number + ["n" nat]]] + [meta + [target + [jvm + ["_" bytecode (.only Label Bytecode)] + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + ["[0]" method (.only Method)] + [constant + [pool (.only Resource)]] + ["[0]" type (.only Type) + ["[0]" category (.only Class)]]]]]]] + ["[0]" // (.only) + ["//[1]" /// + ["[0]" runtime] + ["[1][0]" type] + [////// + [arity (.only Arity)] + [meta + [archive + ["[0]" unit]]]]]]) + +(def .public name "impl") + +(def .public (type :it: arity) + (-> (Type Class) Arity (Type category.Method)) + (type.method [(list) + (list.partial :it: (list.repeated arity ////type.value)) + ////type.value + (list)])) + +(def modifier + (all modifier#composite + method.static + //.modifier + )) + +(def .public (method :it: arity @begin body) + (-> (Type Class) Arity Label (Bytecode Any) (Resource Method)) + (method.method ..modifier + ..name + #0 (..type :it: arity) + (list) + {.#Some (all _.composite + (_.set_label @begin) + body + (_.when_continuous _.areturn) + )})) + +(def .public (call :it: arity) + (-> (Type Class) Arity (Bytecode Any)) + (_.invokestatic :it: ..name (..type :it: arity))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/init.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/init.lux new file mode 100644 index 000000000..2e551f44d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/init.lux @@ -0,0 +1,105 @@ +(.require + [library + [lux (.except Type type) + [abstract + ["[0]" monad]] + [control + ["[0]" try]] + [data + [collection + ["[0]" list (.use "[1]#[0]" monoid functor)]]] + [math + [number + ["n" nat]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" method (.only Method)] + [encoding + ["[0]" signed]] + [constant + [pool (.only Resource)]] + ["[0]" type (.only Type) + ["[0]" category (.only Class Value)]]]]]]] + ["[0]" // (.only) + ["[1][0]" implementation] + ["/[1]" // + ["[1][0]" abstract] + [field + [constant + ["[1][0]" arity]] + [variable + ["[1][0]" foreign] + ["[1][0]" partial]]] + ["/[1]" // + ["[1][0]" type] + ["[1][0]" reference] + [//// + [analysis (.only Environment)] + [synthesis (.only Synthesis)] + [/// + ["[0]" arity (.only Arity)] + [reference + [variable (.only Register)]]]]]]]) + +(def .public name "<init>") + +(def (partials arity) + (-> Arity (List (Type Value))) + (list.repeated (-- arity) ////type.value)) + +(def .public (type environment arity) + (-> (Environment Synthesis) Arity (Type category.Method)) + (type.method [(list) + (list#composite (///foreign.closure environment) + (if (arity.multiary? arity) + (list.partial ///arity.type (..partials arity)) + (list))) + type.void + (list)])) + +(def no_partials + (|> +0 + signed.s1 + try.trusted + _.bipush)) + +(def .public (super environment_size arity) + (-> Nat Arity (Bytecode Any)) + (let [arity_register (++ environment_size)] + (all _.composite + (if (arity.unary? arity) + ..no_partials + (_.iload arity_register)) + (_.invokespecial ///abstract.class ..name ///abstract.init)))) + +(def (store_all amount put offset) + (-> Nat + (-> Register (Bytecode Any) (Bytecode Any)) + (-> Register Register) + (Bytecode Any)) + (|> (list.indices amount) + (list#each (function (_ register) + (put register + (_.aload (offset register))))) + (monad.all _.monad))) + +(def .public (method class environment arity) + (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) + (let [environment_size (list.size environment) + offset_foreign (is (-> Register Register) + (n.+ 1)) + offset_arity (is (-> Register Register) + (|>> offset_foreign (n.+ environment_size))) + offset_partial (is (-> Register Register) + (|>> offset_arity (n.+ 1)))] + (method.method //.modifier ..name + #0 (..type environment arity) + (list) + {.#Some (all _.composite + ////reference.this + (..super environment_size arity) + (store_all environment_size (///foreign.put class) offset_foreign) + (store_all (-- arity) (///partial.put class) offset_partial) + _.return)}))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/new.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/new.lux new file mode 100644 index 000000000..26f259dce --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/new.lux @@ -0,0 +1,82 @@ +(.require + [library + [lux (.except Type) + [abstract + ["[0]" monad (.only do)]] + [data + [collection + ["[0]" list]]] + [math + [number + ["n" nat]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" field (.only Field)] + ["[0]" method (.only Method)] + ["[0]" constant (.only) + [pool (.only Resource)]] + [type (.only Type) + ["[0]" category (.only Class Value Return)]]]] + [compiler + [meta + ["[0]" archive (.only Archive)]]]]]] + ["[0]" // (.only) + ["[1][0]" init] + ["[1][0]" implementation] + ["/[1]" // + [field + [constant + ["[1][0]" arity]] + [variable + ["[1][0]" foreign] + ["[1][0]" partial]]] + ["/[1]" // + [runtime (.only Operation Phase)] + ["[1][0]" value] + ["[1][0]" reference] + [//// + [analysis (.only Environment)] + [synthesis (.only Synthesis)] + [/// + ["[0]" arity (.only Arity)] + ["[0]" phase]]]]]]) + +(def .public (instance' foreign_setup class environment arity) + (-> (List (Bytecode Any)) (Type Class) (Environment Synthesis) Arity (Bytecode Any)) + (all _.composite + (_.new class) + _.dup + (monad.all _.monad foreign_setup) + (///partial.new arity) + (_.invokespecial class //init.name (//init.type environment arity)))) + +(def .public (instance generate archive class environment arity) + (-> Phase Archive (Type Class) (Environment Synthesis) Arity (Operation (Bytecode Any))) + (do [! phase.monad] + [foreign* (monad.each ! (generate archive) environment)] + (in (instance' foreign* class environment arity)))) + +(def .public (method class environment arity) + (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) + (let [after_this (is (-> Nat Nat) + (n.+ 1)) + environment_size (list.size environment) + after_environment (is (-> Nat Nat) + (|>> after_this (n.+ environment_size))) + after_arity (is (-> Nat Nat) + (|>> after_environment (n.+ 1)))] + (method.method //.modifier //init.name + #0 (//init.type environment arity) + (list) + {.#Some (all _.composite + ////reference.this + (//init.super environment_size arity) + (monad.each _.monad (function (_ register) + (///foreign.put class register (_.aload (after_this register)))) + (list.indices environment_size)) + (monad.each _.monad (function (_ register) + (///partial.put class register (_.aload (after_arity register)))) + (list.indices (n.- ///arity.minimum arity))) + _.areturn)}))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/reset.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/reset.lux new file mode 100644 index 000000000..bfbacf886 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/function/method/reset.lux @@ -0,0 +1,51 @@ +(.require + [library + [lux (.except Type type) + [data + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" method (.only Method)] + [constant + [pool (.only Resource)]] + ["[0]" type (.only Type) + ["[0]" category (.only Class)]]]]]]] + ["[0]" // (.only) + ["[1][0]" new] + ["/[1]" // + [field + [variable + ["[1][0]" foreign]]] + ["/[1]" // + ["[1][0]" reference] + [//// + [analysis (.only Environment)] + [synthesis (.only Synthesis)] + [/// + ["[0]" arity (.only Arity)]]]]]]) + +(def .public name "reset") + +(def .public (type class) + (-> (Type Class) (Type category.Method)) + (type.method [(list) (list) class (list)])) + +(def (current_environment class) + (-> (Type Class) (Environment Synthesis) (List (Bytecode Any))) + (|>> list.size + list.indices + (list#each (///foreign.get class)))) + +(def .public (method class environment arity) + (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) + (method.method //.modifier ..name + #0 (..type class) + (list) + {.#Some (all _.composite + (if (arity.multiary? arity) + (//new.instance' (..current_environment class environment) class environment arity) + ////reference.this) + _.areturn)})) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/host.lux new file mode 100644 index 000000000..ca870abef --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/host.lux @@ -0,0 +1,194 @@ +(.require + [library + [lux (.except Definition) + ["[0]" ffi (.only import object)] + [abstract + [monad (.only do)]] + [control + ["[0]" maybe] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)] + ["[0]" io (.only IO io)] + [concurrency + ["[0]" atom (.only Atom atom)]]] + [data + ["[0]" product] + [binary (.only Binary) + ["[0]" \\format]] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)]] + [collection + ["[0]" array] + ["[0]" dictionary (.only Dictionary)] + ["[0]" sequence]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" loader (.only Library)] + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + ["[0]" field (.only Field)] + ["[0]" method (.only Method)] + ["[0]" version] + ["[0]" class (.only Class)] + ["[0]" encoding + ["[1]/[0]" name]] + ["[0]" type (.only) + ["[0]" descriptor]]]] + [compiler + [meta + [io (.only lux_context)] + [archive + ["[0]" unit]]]]]]] + ["[0]" // + ["[1][0]" runtime (.only Definition)] + ["[1][0]" type] + ["[1][0]" value]] + ) + +(import java/lang/reflect/Field + "[1]::[0]" + (get ["?" java/lang/Object] "try" "?" java/lang/Object)) + +(import (java/lang/Class a) + "[1]::[0]" + (getField [java/lang/String] "try" java/lang/reflect/Field)) + +(import java/lang/Object + "[1]::[0]" + (getClass [] (java/lang/Class java/lang/Object))) + +(import java/lang/ClassLoader + "[1]::[0]") + +(def value::modifier (all modifier#composite field.public field.final field.static)) + +(def init::type (type.method [(list) (list) type.void (list)])) +(def init::modifier (all modifier#composite method.public method.static method.strict)) + +(exception .public (cannot_load [class Text + error Text]) + (exception.report + "Class" class + "Error" error)) + +(exception .public (invalid_field [class Text + field Text + error Text]) + (exception.report + "Class" class + "Field" field + "Error" error)) + +(exception .public (invalid_value [class Text]) + (exception.report + "Class" class)) + +(def (class_value class_name class) + (-> Text (java/lang/Class java/lang/Object) (Try Any)) + (case (java/lang/Class::getField //value.field class) + {try.#Success field} + (case (java/lang/reflect/Field::get {.#None} field) + {try.#Success ?value} + (case ?value + {.#Some value} + {try.#Success value} + + {.#None} + (exception.except ..invalid_value [class_name])) + + {try.#Failure error} + (exception.except ..cannot_load [class_name error])) + + {try.#Failure error} + (exception.except ..invalid_field [class_name //value.field error]))) + +(def class_path_separator + ".") + +(def (evaluate! library loader eval_class [@it valueG]) + (-> Library java/lang/ClassLoader Text [(Maybe unit.ID) (Bytecode Any)] (Try [Any Definition])) + (let [bytecode_name (text.replaced class_path_separator .module_separator eval_class) + :value: (case @it + {.#Some @it} + (type.class (//runtime.class_name @it) (list)) + + {.#None} + //type.value) + bytecode (class.class version.v6_0 + class.public + (encoding/name.internal bytecode_name) + {.#None} + (encoding/name.internal "java.lang.Object") (list) + (list (field.field ..value::modifier //value.field #0 :value: (sequence.sequence))) + (list (method.method ..init::modifier "<clinit>" + #0 ..init::type + (list) + {.#Some + (all _.composite + valueG + (_.putstatic (type.class bytecode_name (list)) //value.field :value:) + _.return)})) + (sequence.sequence))] + (io.run! (do [! (try.with io.monad)] + [bytecode (at ! each (\\format.result class.format) + (io.io bytecode)) + _ (loader.store eval_class bytecode library) + class (loader.load eval_class loader) + value (at io.monad in (class_value eval_class class))] + (in [value + [eval_class bytecode]]))))) + +(def (execute! library loader [class_name class_bytecode]) + (-> Library java/lang/ClassLoader Definition (Try Any)) + (io.run! (do (try.with io.monad) + [existing_class? (|> (atom.read! library) + (at io.monad each (function (_ library) + (dictionary.key? library class_name))) + (try.lifted io.monad) + (is (IO (Try Bit)))) + _ (if existing_class? + (in []) + (loader.store class_name class_bytecode library))] + (loader.load class_name loader)))) + +(def (define! library loader context custom @it,valueG) + (-> Library java/lang/ClassLoader unit.ID (Maybe Text) [(Maybe unit.ID) (Bytecode Any)] (Try [Text Any Definition])) + (let [class_name (maybe.else (//runtime.class_name context) + custom)] + (do try.monad + [[value definition] (evaluate! library loader class_name @it,valueG)] + (in [class_name value definition])))) + +(def .public host + (IO [java/lang/ClassLoader //runtime.Host]) + (io (let [library (loader.new_library []) + loader (loader.memory library)] + [loader + (is //runtime.Host + (implementation + (def (evaluate context @it,valueG) + (at try.monad each product.left + (..evaluate! library loader (format "E" (//runtime.class_name context)) @it,valueG))) + + (def execute + (..execute! library loader)) + + (def define + (..define! library loader)) + + (def (ingest context bytecode) + [(//runtime.class_name context) bytecode]) + + (def (re_learn context custom [_ bytecode]) + (io.run! (loader.store (maybe.else (//runtime.class_name context) custom) bytecode library))) + + (def (re_load context custom [declaration_name bytecode]) + (io.run! + (do (try.with io.monad) + [.let [class_name (maybe.else (//runtime.class_name context) + custom)] + _ (loader.store class_name bytecode library) + class (loader.load class_name loader)] + (at io.monad in (..class_value class_name class))))) + ))]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/loop.lux new file mode 100644 index 000000000..d7b73995e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/loop.lux @@ -0,0 +1,95 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" function]] + [data + ["[0]" product] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [math + [number + ["n" nat]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode) (.use "[1]#[0]" monad)]]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" value] + [//// + ["[0]" synthesis (.only Path Synthesis)] + ["[0]" generation] + [/// + ["[0]" phase] + [reference + [variable (.only Register)]]]]]) + +(def (invariant? register changeS) + (-> Register Synthesis Bit) + (case changeS + (synthesis.variable/local var) + (n.= register var) + + _ + false)) + +(def no_op + (_#in [])) + +(def .public (again translate archive updatesS) + (Generator (List Synthesis)) + (do [! phase.monad] + [[@begin offset] generation.anchor + updatesG (|> updatesS + list.enumeration + (list#each (function (_ [index updateS]) + [(n.+ offset index) updateS])) + (monad.each ! (function (_ [register updateS]) + (if (invariant? register updateS) + (in [..no_op + ..no_op]) + (do ! + [fetchG (translate archive updateS) + .let [storeG (_.astore register)]] + (in [fetchG storeG]))))))] + (in (all _.composite + ... It may look weird that first I fetch all the values separately, + ... and then I store them all. + ... It must be done that way in order to avoid a potential bug. + ... Let's say that you'll recur with 2 expressions: X and Y. + ... If Y depends on the value of X, and you don't perform fetches + ... and stores separately, then by the time Y is evaluated, it + ... will refer to the new value of X, instead of the old value, as + ... should be the case. + (|> updatesG + (list#each product.left) + (monad.all _.monad)) + (|> updatesG + list.reversed + (list#each product.right) + (monad.all _.monad)) + (_.goto @begin))))) + +(def .public (scope translate archive [offset initsS+ iterationS]) + (Generator [Nat (List Synthesis) Synthesis]) + (do [! phase.monad] + [@begin //runtime.forge_label + initsI+ (monad.each ! (translate archive) initsS+) + iterationG (generation.with_anchor [@begin offset] + (translate archive iterationS)) + .let [initializationG (list#each (function (_ [index initG]) + [initG (_.astore (n.+ offset index))]) + (list.enumeration initsI+))]] + (in (all _.composite + (|> initializationG + (list#each product.left) + (monad.all _.monad)) + (|> initializationG + list.reversed + (list#each product.right) + (monad.all _.monad)) + (_.set_label @begin) + iterationG)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/primitive.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/primitive.lux new file mode 100644 index 000000000..ad5a79db9 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/primitive.lux @@ -0,0 +1,134 @@ +(.require + [library + [lux (.except i64) + ["[0]" ffi (.only import)] + [abstract + [monad (.only do)]] + [control + ["[0]" try]] + [math + [number + ["i" int]]] + [meta + [macro + ["^" pattern]] + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" type] + [encoding + ["[0]" signed]]]]]]] + ["[0]" // + ["[1][0]" runtime]]) + +(def $Boolean (type.class "java.lang.Boolean" (list))) +(def $Long (type.class "java.lang.Long" (list))) +(def $Double (type.class "java.lang.Double" (list))) + +(def .public (bit value) + (-> Bit (Bytecode Any)) + (_.getstatic $Boolean (if value "TRUE" "FALSE") $Boolean)) + +(def wrap_i64 + (_.invokestatic $Long "valueOf" (type.method [(list) (list type.long) $Long (list)]))) + +(def .public (i64 value) + (-> (I64 Any) (Bytecode Any)) + (case (.int value) + (^.with_template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction>] + ..wrap_i64)]) + ([+0 _.lconst_0] + [+1 _.lconst_1]) + + (^.with_template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction> + _ _.i2l] + ..wrap_i64)]) + ([-1 _.iconst_m1] + ... [+0 _.iconst_0] + ... [+1 _.iconst_1] + [+2 _.iconst_2] + [+3 _.iconst_3] + [+4 _.iconst_4] + [+5 _.iconst_5]) + + value + (case (signed.s1 value) + {try.#Success value} + (do _.monad + [_ (_.bipush value) + _ _.i2l] + ..wrap_i64) + + {try.#Failure _} + (case (signed.s2 value) + {try.#Success value} + (do _.monad + [_ (_.sipush value) + _ _.i2l] + ..wrap_i64) + + {try.#Failure _} + (do _.monad + [_ (_.long value)] + ..wrap_i64))))) + +(def wrap_f64 + (_.invokestatic $Double "valueOf" (type.method [(list) (list type.double) $Double (list)]))) + +(import java/lang/Double + "[1]::[0]" + ("static" doubleToRawLongBits "manual" [double] int)) + +(def d0_bits + Int + (java/lang/Double::doubleToRawLongBits +0.0)) + +(def .public (f64 value) + (-> Frac (Bytecode Any)) + (case value + (^.with_template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction>] + ..wrap_f64)]) + ([+1.0 _.dconst_1]) + + (^.with_template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction> + _ _.f2d] + ..wrap_f64)]) + ([+2.0 _.fconst_2]) + + (^.with_template [<int> <instruction>] + [<int> + (do _.monad + [_ <instruction> + _ _.i2d] + ..wrap_f64)]) + ([-1.0 _.iconst_m1] + ... [+0.0 _.iconst_0] + ... [+1.0 _.iconst_1] + ... [+2.0 _.iconst_2] + [+3.0 _.iconst_3] + [+4.0 _.iconst_4] + [+5.0 _.iconst_5]) + + _ + (let [constantI (if (i.= ..d0_bits + (java/lang/Double::doubleToRawLongBits (as java/lang/Double value))) + _.dconst_0 + (_.double value))] + (do _.monad + [_ constantI] + ..wrap_f64)))) + +(def .public text + _.string) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/program.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/program.lux new file mode 100644 index 000000000..730a83b19 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/program.lux @@ -0,0 +1,168 @@ +(.require + [library + [lux (.except Definition) + [abstract + [monad (.only do)]] + [control + ["[0]" try]] + [data + [binary + ["[0]" \\format]] + [collection + ["[0]" sequence]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + ["[0]" method (.only Method)] + ["[0]" version] + ["[0]" class (.only Class)] + [encoding + ["[0]" name]] + ["[0]" type (.only) + ["[0]" reflection]]]] + [compiler + [language + [lux + [program (.only Program)]]] + [meta + [archive + ["[0]" unit]]]]]]] + ["[0]" // (.only) + ["[1][0]" runtime (.only Definition)] + ["[1][0]" function/abstract]]) + +(def ^Object + (type.class "java.lang.Object" (list))) + +(def ^String + (type.class "java.lang.String" (list))) + +(def ^Args + (type.array ^String)) + +(def main::type + (type.method [(list) (list ..^Args) type.void (list)])) + +(def main::modifier + (Modifier Method) + (all modifier#composite + method.public + method.static + method.strict + )) + +(def program::modifier + (Modifier Class) + (all modifier#composite + class.public + class.final + )) + +(def list:end + //runtime.none_injection) + +(def amount_of_inputs + (Bytecode Any) + (all _.composite + _.aload_0 + _.arraylength)) + +(def decrease + (Bytecode Any) + (all _.composite + _.iconst_1 + _.isub)) + +(def head + (Bytecode Any) + (all _.composite + _.dup + _.aload_0 + _.swap + _.aaload + _.swap + _.dup_x2 + _.pop)) + +(def pair + (Bytecode Any) + (let [empty_pair (all _.composite + _.iconst_2 + (_.anewarray ^Object) + ) + set_side! (is (-> (Bytecode Any) (Bytecode Any)) + (function (_ index) + (all _.composite + ... ?P + _.dup_x1 ... P?P + _.swap ... PP? + index ... PP?I + _.swap ... PPI? + _.aastore ... P + )))] + (all _.composite + ... RL + empty_pair ... RLP + (set_side! _.iconst_0) ... RP + (set_side! _.iconst_1) ... P + ))) + +(def list:item //runtime.right_injection) + +(def input_list + (Bytecode Any) + (do _.monad + [@loop _.new_label + @end _.new_label] + (all _.composite + ..list:end + ..amount_of_inputs + (_.set_label @loop) + ..decrease + _.dup + (_.iflt @end) + ..head + ..pair + ..list:item + _.swap + (_.goto @loop) + (_.set_label @end) + _.pop))) + +(def feed_inputs + //runtime.apply) + +(def run_io + (Bytecode Any) + (all _.composite + (_.checkcast //function/abstract.class) + //runtime.unit + //runtime.apply)) + +(def .public (program artifact_name context program) + (-> (-> unit.ID Text) (Program (Bytecode Any) Definition)) + (let [super_class (|> ..^Object type.reflection reflection.reflection name.internal) + main (method.method ..main::modifier "main" + #0 ..main::type + (list) + {.#Some (all _.composite + program + ..input_list + ..feed_inputs + ..run_io + _.return)}) + class (artifact_name context)] + [class + (<| (\\format.result class.format) + try.trusted + (class.class version.v6_0 + ..program::modifier + (name.internal class) + {.#None} + super_class + (list) + (list) + (list main) + (sequence.sequence)))])) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/reference.lux new file mode 100644 index 000000000..a6f209206 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/reference.lux @@ -0,0 +1,74 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [data + [text + ["%" \\format (.only format)]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" type] + [encoding + ["[0]" unsigned]]]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation)] + ["[1][0]" value] + ["[1][0]" type] + ["//[1]" /// + [// + ["[0]" generation] + [/// + ["[1]" phase (.use "operation#[0]" monad)] + [reference + ["[0]" variable (.only Register Variable)]] + [meta + [archive (.only Archive)]]]]]]) + +(def .public this + (Bytecode Any) + _.aload_0) + +(with_template [<name> <prefix>] + [(def .public <name> + (-> Register Text) + (|>> %.nat (format <prefix>)))] + + [foreign_name "f"] + [partial_name "p"] + ) + +(def (foreign archive variable) + (-> Archive Register (Operation (Bytecode Any))) + (do [! ////.monad] + [bytecode_name (at ! each //runtime.class_name + (generation.context archive))] + (in (all _.composite + ..this + (_.getfield (type.class bytecode_name (list)) + (..foreign_name variable) + //type.value))))) + +(def .public (variable archive variable) + (-> Archive Variable (Operation (Bytecode Any))) + (case variable + {variable.#Local variable} + (operation#in (_.aload variable)) + + {variable.#Foreign variable} + (..foreign archive variable))) + +(def .public (constant archive name) + (-> Archive Symbol (Operation (Bytecode Any))) + (do ////.monad + [[@definition |abstraction|] (generation.definition archive name) + .let [:definition: (type.class (//runtime.class_name @definition) (list))]] + (in (case |abstraction| + {.#Some [_ {.#Some [expected_arity @abstraction]}]} + (let [:abstraction: (type.class (//runtime.class_name @abstraction) (list))] + (_.getstatic :definition: //value.field :abstraction:)) + + _ + (_.getstatic :definition: //value.field //type.value))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/runtime.lux new file mode 100644 index 000000000..a728d2b2e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/runtime.lux @@ -0,0 +1,659 @@ +(.require + [library + [lux (.except Type Definition Label case false true try) + [abstract + ["[0]" monad (.only do)] + ["[0]" enum]] + [control + ["[0]" try]] + [data + ["[0]" product] + [binary (.only Binary) + ["[0]" \\format]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" sequence]] + [text + ["%" \\format (.only format)]]] + [math + [number + ["n" nat] + ["[0]" i32] + ["[0]" i64]]] + [meta + ["[0]" version] + [target + ["[0]" jvm + ["_" bytecode (.only Label Bytecode)] + ["[0]" modifier (.only Modifier) (.use "[1]#[0]" monoid)] + ["[0]" field (.only Field)] + ["[0]" method (.only Method)] + ["[1]/[0]" version] + ["[0]" class (.only Class)] + ["[0]" constant (.only) + [pool (.only Resource)]] + [encoding + ["[0]" name]] + ["[0]" type (.only Type) + ["[0]" category (.only Return' Value')] + ["[0]" reflection]]]]]]] + ["[0]" // + ["[1][0]" type] + ["[1][0]" value] + ["[1][0]" function + ["[1]" abstract] + [field + [constant + ["[1]/[0]" arity]] + [variable + ["[1]/[0]" count]]]] + ["//[1]" /// + [// + ["[0]" synthesis] + ["[0]" generation] + [/// + ["[1]" phase] + [arity (.only Arity)] + [reference + [variable (.only Register)]] + [meta + [io (.only lux_context)] + [archive (.only Output Archive) + ["[0]" artifact] + ["[0]" registry (.only Registry)] + ["[0]" unit]]]]]]]) + +(type .public Byte_Code + Binary) + +(type .public Definition + [Text Byte_Code]) + +(type .public Anchor + [Label Register]) + +(with_template [<name> <base>] + [(type .public <name> + (<base> Anchor (Bytecode Any) Definition))] + + [Operation generation.Operation] + [Phase generation.Phase] + [Handler generation.Handler] + [Bundle generation.Bundle] + [Extender generation.Extender] + ) + +(type .public (Generator i) + (-> Phase Archive i (Operation (Bytecode Any)))) + +(type .public Host + (generation.Host (Bytecode Any) Definition)) + +(def .public (class_name [module id]) + (-> unit.ID Text) + (format lux_context + "." (%.nat version.latest) + "." (%.nat module) + "." (%.nat id))) + +(def artifact_id + 0) + +(def .public class + (type.class (class_name [0 ..artifact_id]) (list))) + +(def procedure + (-> Text (Type category.Method) (Bytecode Any)) + (_.invokestatic ..class)) + +(def modifier + (Modifier Method) + (all modifier#composite + method.public + method.static + method.strict + )) + +(def this + (Bytecode Any) + _.aload_0) + +(def .public (get index) + (-> (Bytecode Any) (Bytecode Any)) + (all _.composite + index + _.aaload)) + +(def (set! index value) + (-> (Bytecode Any) (Bytecode Any) (Bytecode Any)) + (all _.composite + ... A + _.dup ... AA + index ... AAI + value ... AAIV + _.aastore ... A + )) + +(def .public unit (_.string synthesis.unit)) + +(def variant::name "variant") +(def variant::type (type.method [(list) (list //type.lefts //type.right? //type.value) //type.variant (list)])) +(def .public variant (..procedure ..variant::name ..variant::type)) + +(def variant_lefts _.iconst_0) +(def variant_right? _.iconst_1) +(def variant_value _.iconst_2) + +(def variant::method + (let [new_variant (all _.composite + _.iconst_3 + (_.anewarray //type.value)) + $lefts (all _.composite + _.iload_0 + (//value.wrap type.int)) + $right? _.aload_1 + $value _.aload_2] + (method.method ..modifier ..variant::name + #0 ..variant::type + (list) + {.#Some (all _.composite + new_variant ... A[3] + (..set! ..variant_lefts $lefts) ... A[3] + (..set! ..variant_right? $right?) ... A[3] + (..set! ..variant_value $value) ... A[3] + _.areturn)}))) + +(def .public left_right? _.aconst_null) +(def .public right_right? ..unit) + +(def .public left_injection + (Bytecode Any) + (all _.composite + _.iconst_0 + ..left_right? + _.dup2_x1 + _.pop2 + ..variant)) + +(def .public right_injection + (Bytecode Any) + (all _.composite + _.iconst_0 + ..right_right? + _.dup2_x1 + _.pop2 + ..variant)) + +(def .public some_injection ..right_injection) + +(def .public none_injection + (Bytecode Any) + (all _.composite + _.iconst_0 + ..left_right? + ..unit + ..variant)) + +(def (risky $unsafe) + (-> (Bytecode Any) (Bytecode Any)) + (do _.monad + [@try _.new_label + @handler _.new_label] + (all _.composite + (_.try @try @handler @handler //type.error) + (_.set_label @try) + $unsafe + ..some_injection + _.areturn + (_.set_label @handler) + ..none_injection + _.areturn + ))) + +(def decode_frac::name "decode_frac") +(def decode_frac::type (type.method [(list) (list //type.text) //type.variant (list)])) +(def .public decode_frac (..procedure ..decode_frac::name ..decode_frac::type)) + +(def decode_frac::method + (method.method ..modifier ..decode_frac::name + #0 ..decode_frac::type + (list) + {.#Some + (..risky + (all _.composite + _.aload_0 + (_.invokestatic //type.frac "parseDouble" (type.method [(list) (list //type.text) type.double (list)])) + (//value.wrap type.double) + ))})) + +(def .public log! + (Bytecode Any) + (let [^PrintStream (type.class "java.io.PrintStream" (list)) + ^System (type.class "java.lang.System" (list)) + out (_.getstatic ^System "out" ^PrintStream) + print_type (type.method [(list) (list //type.value) type.void (list)]) + print! (function (_ method) (_.invokevirtual ^PrintStream method print_type))] + (all _.composite + out (_.string "LUX LOG: ") (print! "print") + out _.swap (print! "println")))) + +(def exception_constructor (type.method [(list) (list //type.text) type.void (list)])) +(def (illegal_state_exception message) + (-> Text (Bytecode Any)) + (let [^IllegalStateException (type.class "java.lang.IllegalStateException" (list))] + (all _.composite + (_.new ^IllegalStateException) + _.dup + (_.string message) + (_.invokespecial ^IllegalStateException "<init>" ..exception_constructor)))) + +(def failure::type + (type.method [(list) (list) type.void (list)])) + +(def (failure name message) + (-> Text Text (Resource Method)) + (method.method ..modifier name + #0 ..failure::type + (list) + {.#Some + (all _.composite + (..illegal_state_exception message) + _.athrow)})) + +(def pm_failure::name "pm_failure") +(def .public pm_failure (..procedure ..pm_failure::name ..failure::type)) + +(def pm_failure::method + (..failure ..pm_failure::name "Invalid expression for pattern-matching.")) + +(def .public stack_head _.iconst_0) +(def .public stack_tail _.iconst_1) + +(def push::name "push") +(def push::type (type.method [(list) (list //type.stack //type.value) //type.stack (list)])) +(def .public push (..procedure ..push::name ..push::type)) + +(def push::method + (method.method ..modifier ..push::name + #0 ..push::type + (list) + {.#Some + (let [new_stack_frame! (all _.composite + _.iconst_2 + (_.anewarray //type.value)) + $head _.aload_1 + $tail _.aload_0] + (all _.composite + new_stack_frame! + (..set! ..stack_head $head) + (..set! ..stack_tail $tail) + _.areturn))})) + +(def case::name "case") +(def case::type (type.method [(list) (list //type.variant //type.lefts //type.right?) //type.value (list)])) +(def .public case (..procedure ..case::name ..case::type)) + +(def case::method + (method.method ..modifier ..case::name + #0 ..case::type + (list) + {.#Some + (do _.monad + [@loop _.new_label + @perfect_match! _.new_label + @lefts_match! _.new_label + @maybe_nested _.new_label + @mismatch! _.new_label + .let [$variant _.aload_0 + $lefts _.iload_1 + $right? _.aload_2 + + ::lefts (all _.composite + (..get ..variant_lefts) + (//value.unwrap type.int)) + ::right? (..get ..variant_right?) + ::value (..get ..variant_value) + + not_found _.aconst_null + + super_nested_lefts (all _.composite + _.swap + _.isub + (_.int (i32.i32 (.i64 +1))) + _.isub) + super_nested (all _.composite + ... lefts, sumT + super_nested_lefts ... super_lefts + $variant ::right? ... super_lefts, super_right + $variant ::value ... super_lefts, super_right, super_value + ..variant) + + update_$variant (all _.composite + $variant ::value + (_.checkcast //type.variant) + _.astore_0) + update_$lefts (all _.composite + _.isub + (_.int (i32.i32 (.i64 +1))) + _.isub) + again (is (-> Label (Bytecode Any)) + (function (_ @) + (all _.composite + ... lefts, sumT + update_$variant ... lefts, sumT + update_$lefts ... sub_lefts + (_.goto @))))]] + (all _.composite + $lefts + (_.set_label @loop) + $variant ::lefts + _.dup2 (_.if_icmpeq @lefts_match!) + _.dup2 (_.if_icmpgt @maybe_nested) + $right? (_.ifnull @mismatch!) ... lefts, sumT + super_nested ... super_variant + _.areturn + (_.set_label @lefts_match!) ... lefts, sumT + $right? ... lefts, sumT, wants_right? + $variant ::right? ... lefts, sumT, wants_right?, is_right? + (_.if_acmpeq @perfect_match!) ... lefts, sumT + (_.set_label @mismatch!) ... lefts, sumT + ... _.pop2 + not_found + _.areturn + (_.set_label @maybe_nested) ... lefts, sumT + $variant ::right? ... lefts, sumT, right? + (_.ifnull @mismatch!) ... lefts, sumT + (again @loop) + (_.set_label @perfect_match!) ... lefts, sumT + ... _.pop2 + $variant ::value + _.areturn + ))})) + +(def projection_type (type.method [(list) (list //type.tuple //type.offset) //type.value (list)])) + +(def left_projection::name "left") +(def .public left_projection (..procedure ..left_projection::name ..projection_type)) + +(def right_projection::name "right") +(def .public right_projection (..procedure ..right_projection::name ..projection_type)) + +(def projection::method2 + [(Resource Method) (Resource Method)] + (let [$tuple _.aload_0 + $tuple::size (all _.composite + $tuple + _.arraylength) + + $lefts _.iload_1 + + $last_right (all _.composite + $tuple::size + _.iconst_1 + _.isub) + + update_$lefts (all _.composite + $lefts $last_right _.isub + _.istore_1) + update_$tuple (all _.composite + $tuple $last_right _.aaload (_.checkcast //type.tuple) + _.astore_0) + recur (is (-> Label (Bytecode Any)) + (function (_ @loop) + (all _.composite + update_$lefts + update_$tuple + (_.goto @loop)))) + + left_projection::method + (method.method ..modifier ..left_projection::name + #0 ..projection_type + (list) + {.#Some + (do _.monad + [@loop _.new_label + @recursive _.new_label + .let [::left (all _.composite + $lefts + _.aaload)]] + (all _.composite + (_.set_label @loop) + $lefts $last_right (_.if_icmpge @recursive) + $tuple ::left + _.areturn + (_.set_label @recursive) + ... Recursive + (recur @loop)))}) + + right_projection::method + (method.method ..modifier ..right_projection::name + #0 ..projection_type + (list) + {.#Some + (do _.monad + [@loop _.new_label + @not_tail _.new_label + @slice _.new_label + .let [$right (all _.composite + $lefts + _.iconst_1 + _.iadd) + $::nested (all _.composite + $tuple + _.swap + _.aaload) + super_nested (all _.composite + $tuple + $right + $tuple::size + (_.invokestatic (type.class "java.util.Arrays" (list)) "copyOfRange" + (type.method [(list) (list //type.tuple //type.index //type.index) //type.tuple (list)])))]] + (all _.composite + (_.set_label @loop) + $last_right $right + _.dup2 (_.if_icmpne @not_tail) + ... _.pop + $::nested + _.areturn + (_.set_label @not_tail) + (_.if_icmpgt @slice) + ... Must recurse + (recur @loop) + (_.set_label @slice) + super_nested + _.areturn))})] + [left_projection::method + right_projection::method])) + +(def .public apply::name "apply") + +(def .public (apply::type arity) + (-> Arity (Type category.Method)) + (type.method [(list) (list.repeated arity //type.value) //type.value (list)])) + +(def .public apply + (_.invokevirtual //function.class ..apply::name (..apply::type 1))) + +(def try::name "try") +(def try::type (type.method [(list) (list //function.class) //type.variant (list)])) +(def .public try (..procedure ..try::name ..try::type)) + +(def false _.iconst_0) +(def true _.iconst_1) + +(def try::method + (method.method ..modifier ..try::name + #0 ..try::type + (list) + {.#Some + (do _.monad + [@try _.new_label + @handler _.new_label + .let [$unsafe ..this + + ^StringWriter (type.class "java.io.StringWriter" (list)) + string_writer (all _.composite + (_.new ^StringWriter) + _.dup + (_.invokespecial ^StringWriter "<init>" (type.method [(list) (list) type.void (list)]))) + + ^PrintWriter (type.class "java.io.PrintWriter" (list)) + print_writer (all _.composite + ... WTW + (_.new ^PrintWriter) ... WTWP + _.dup_x1 ... WTPWP + _.swap ... WTPPW + ..true ... WTPPWZ + (_.invokespecial ^PrintWriter "<init>" (type.method [(list) (list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)])) + ... WTP + ) + unsafe_application (all _.composite + $unsafe + ..unit + ..apply) + stack_trace (all _.composite + ... T + string_writer ... TW + _.dup_x1 ... WTW + print_writer ... WTP + (_.invokevirtual //type.error "printStackTrace" (type.method [(list) (list ^PrintWriter) type.void (list)])) ... W + (_.invokevirtual ^StringWriter "toString" (type.method [(list) (list) //type.text (list)])) ... S + )]] + (all _.composite + (_.try @try @handler @handler //type.error) + (_.set_label @try) + unsafe_application + ..right_injection + _.areturn + (_.set_label @handler) ... T + stack_trace ... S + ..left_injection + _.areturn + ))})) + +(def reflection + (All (_ category) + (-> (Type (<| Return' Value' category)) Text)) + (|>> type.reflection reflection.reflection)) + +(def ^Object (type.class "java.lang.Object" (list))) + +(def generate_runtime + (Operation [artifact.ID (Maybe Text) Binary]) + (let [class (..reflection ..class) + modifier (is (Modifier Class) + (all modifier#composite + class.public + class.final)) + bytecode (<| (\\format.result class.format) + try.trusted + (class.class jvm/version.v6_0 + modifier + (name.internal class) + {.#None} + (name.internal (..reflection ^Object)) (list) + (list) + (let [[left_projection::method right_projection::method] projection::method2] + (list ..decode_frac::method + ..variant::method + + ..pm_failure::method + + ..push::method + ..case::method + left_projection::method + right_projection::method + + ..try::method)) + sequence.empty))] + (do ////.monad + [_ (generation.execute! [class bytecode]) + _ (generation.save! ..artifact_id {.#None} [class bytecode])] + (in [..artifact_id {.#None} bytecode])))) + +(def generate_function + (Operation Any) + (let [apply::method+ (|> (enum.range n.enum + (++ //function/arity.minimum) + //function/arity.maximum) + (list#each (function (_ arity) + (method.method method.public ..apply::name + #0 (..apply::type arity) + (list) + {.#Some + (let [previous_inputs (|> arity + list.indices + (monad.each _.monad _.aload))] + (all _.composite + previous_inputs + (_.invokevirtual //function.class ..apply::name (..apply::type (-- arity))) + (_.checkcast //function.class) + (_.aload arity) + (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum)) + _.areturn))}))) + (list.partial (method.method (modifier#composite method.public method.abstract) + ..apply::name + #0 (..apply::type //function/arity.minimum) + (list) + {.#None}))) + <init>::method (method.method method.public "<init>" + #0 //function.init + (list) + {.#Some + (let [$partials _.iload_1] + (all _.composite + ..this + (_.invokespecial ^Object "<init>" (type.method [(list) (list) type.void (list)])) + ..this + $partials + (_.putfield //function.class //function/count.field //function/count.type) + _.return))}) + modifier (is (Modifier Class) + (all modifier#composite + class.public + class.abstract)) + class (..reflection //function.class) + partial_count (is (Resource Field) + (field.field (modifier#composite field.public field.final) + //function/count.field + #0 //function/count.type + sequence.empty)) + bytecode (<| (\\format.result class.format) + try.trusted + (class.class jvm/version.v6_0 + modifier + (name.internal class) + {.#None} + (name.internal (..reflection ^Object)) (list) + (list partial_count) + (list.partial <init>::method apply::method+) + sequence.empty))] + (do ////.monad + [_ (generation.execute! [class bytecode]) + ... _ (generation.save! //function.artifact_id {.#None} [class bytecode]) + ] + (in [])))) + +(def .public generate + (Operation [Registry Output]) + (do ////.monad + [runtime_payload ..generate_runtime + ... _ ..generate_function + ] + (in [(|> registry.empty + (registry.resource .true unit.none) + product.right + ... (registry.resource .true unit.none) + ... product.right + ) + (sequence.sequence runtime_payload + ... function_payload + )]))) + +(def .public forge_label + (Operation Label) + (let [shift (n./ 4 i64.width)] + ... This shift is done to avoid the possibility of forged labels + ... to be in the range of the labels that are generated automatically + ... during the evaluation of Bytecode expressions. + (at ////.monad each (|>> ++ (i64.left_shifted shift)) generation.next))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/structure.lux new file mode 100644 index 000000000..54958837b --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/structure.lux @@ -0,0 +1,97 @@ +(.require + [library + [lux (.except Variant Tuple) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" try]] + [data + [collection + ["[0]" list]]] + [math + [number + ["[0]" i32]]] + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" type] + [encoding + ["[0]" signed]]]]]]] + ["[0]" // + ["[1][0]" type] + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" primitive] + ["///[1]" //// + ["[1][0]" synthesis (.only Synthesis)] + [analysis + [complex (.only Variant Tuple)]] + [/// + ["[0]" phase]]]]) + +(def .public (tuple phase archive membersS) + (Generator (Tuple Synthesis)) + (case membersS + {.#End} + (at phase.monad in //runtime.unit) + + {.#Item singletonS {.#End}} + (phase archive singletonS) + + _ + (do [! phase.monad] + [membersI (|> membersS + list.enumeration + (monad.each ! (function (_ [idx member]) + (do ! + [memberI (phase archive member)] + (in (do _.monad + [_ _.dup + _ (_.int (.i64 idx)) + _ memberI] + _.aastore))))))] + (in (do [! _.monad] + [_ (_.int (.i64 (list.size membersS))) + _ (_.anewarray //type.value)] + (monad.all ! membersI)))))) + +(def .public (lefts lefts) + (-> Nat (Bytecode Any)) + (case lefts + 0 _.iconst_0 + 1 _.iconst_1 + 2 _.iconst_2 + 3 _.iconst_3 + 4 _.iconst_4 + 5 _.iconst_5 + _ (case (signed.s1 (.int lefts)) + {try.#Success value} + (_.bipush value) + + {try.#Failure _} + (case (signed.s2 (.int lefts)) + {try.#Success value} + (_.sipush value) + + {try.#Failure _} + (_.int (.i64 lefts)))))) + +(def .public (right? right?) + (-> Bit (Bytecode Any)) + (if right? + //runtime.right_right? + //runtime.left_right?)) + +(def .public (variant phase archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (do phase.monad + [valueI (phase archive valueS)] + (in (do _.monad + [_ (..lefts lefts) + _ (..right? right?) + _ valueI] + (_.invokestatic //runtime.class "variant" + (type.method [(list) + (list //type.lefts //type.right? //type.value) + //type.variant + (list)])))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/type.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/type.lux new file mode 100644 index 000000000..c178701b3 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/type.lux @@ -0,0 +1,24 @@ +(.require + [library + [lux (.except) + [meta + [target + [jvm + ["[0]" type]]]]]]) + +(def .public frac (type.class "java.lang.Double" (list))) +(def .public text (type.class "java.lang.String" (list))) + +(def .public value (type.class "java.lang.Object" (list))) + +(def .public lefts type.int) +(def .public right? ..value) +(def .public variant (type.array ..value)) + +(def .public offset type.int) +(def .public index ..offset) +(def .public tuple (type.array ..value)) + +(def .public stack (type.array ..value)) + +(def .public error (type.class "java.lang.Throwable" (list))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/value.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/value.lux new file mode 100644 index 000000000..3d914a0e7 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/jvm/value.lux @@ -0,0 +1,50 @@ +(.require + [library + [lux (.except Type Primitive) + [meta + [target + [jvm + ["_" bytecode (.only Bytecode)] + ["[0]" type (.only Type) (.use "[1]#[0]" equivalence) + [category (.only Primitive)] + ["[0]" box]]]]]]]) + +(def .public field "value") + +(with_template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>] + [(def (<name> type) + (-> (Type Primitive) Text) + (`` (cond (,, (with_template [<type> <output>] + [(type#= <type> type) <output>] + + [type.boolean <boolean>] + [type.byte <byte>] + [type.short <short>] + [type.int <int>] + [type.long <long>] + [type.float <float>] + [type.double <double>] + [type.char <char>])) + ... else + (undefined))))] + + [primitive_wrapper + box.boolean box.byte box.short box.int + box.long box.float box.double box.char] + [primitive_unwrap + "booleanValue" "byteValue" "shortValue" "intValue" + "longValue" "floatValue" "doubleValue" "charValue"] + ) + +(def .public (wrap type) + (-> (Type Primitive) (Bytecode Any)) + (let [wrapper (type.class (primitive_wrapper type) (list))] + (_.invokestatic wrapper "valueOf" + (type.method [(list) (list type) wrapper (list)])))) + +(def .public (unwrap type) + (-> (Type Primitive) (Bytecode Any)) + (let [wrapper (type.class (primitive_wrapper type) (list))] + (all _.composite + (_.checkcast wrapper) + (_.invokevirtual wrapper (primitive_unwrap type) (type.method [(list) (list) type (list)]))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua.lux new file mode 100644 index 000000000..2e27b6973 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua.lux @@ -0,0 +1,90 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" exception (.only exception)]] + [meta + [macro + ["^" pattern]] + [target + ["_" lua]]]]] + ["[0]" / + [runtime (.only Phase)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["[1][0]" function] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" extension (.only) + [generation + [lua + ["[1]/[0]" common]]]] + ["/[1]" // + [analysis (.only)] + ["[0]" synthesis] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference (.only) + [variable (.only)]]]]]]]) + +(exception .public cannot_recur_as_an_expression) + +(def (expression archive synthesis) + Phase + (case synthesis + (^.with_template [<tag> <generator>] + [(<tag> value) + (//////phase#in (<generator> value))]) + ([synthesis.bit /primitive.bit] + [synthesis.i64 /primitive.i64] + [synthesis.f64 /primitive.f64] + [synthesis.text /primitive.text]) + + (synthesis.variant variantS) + (/structure.variant expression archive variantS) + + (synthesis.tuple members) + (/structure.tuple expression archive members) + + {synthesis.#Reference value} + (//reference.reference /reference.system archive value) + + (synthesis.branch/case case) + (/case.case ///extension/common.statement expression archive case) + + (synthesis.branch/exec it) + (/case.exec expression archive it) + + (synthesis.branch/let let) + (/case.let expression archive let) + + (synthesis.branch/if if) + (/case.if expression archive if) + + (synthesis.branch/get get) + (/case.get expression archive get) + + (synthesis.loop/scope scope) + (/loop.scope ///extension/common.statement expression archive scope) + + (synthesis.loop/again updates) + (//////phase.except ..cannot_recur_as_an_expression []) + + (synthesis.function/abstraction abstraction) + (/function.function ///extension/common.statement expression archive abstraction) + + (synthesis.function/apply application) + (/function.apply expression archive application) + + {synthesis.#Extension extension} + (///extension.apply archive expression extension))) + +(def .public generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/case.lux new file mode 100644 index 000000000..5924848e8 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/case.lux @@ -0,0 +1,304 @@ +(.require + [library + [lux (.except case exec let if) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set]]] + [meta + [macro + ["^" pattern]] + [target + ["_" lua (.only Expression Var Statement)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Phase! Generator Generator!)] + ["[1][0]" reference] + ["[1][0]" primitive] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" synthesis + ["[1]/[0]" case]] + ["/[1]" // + ["[1][0]" synthesis (.only Synthesis Path) + [access + ["[0]" member (.only Member)]]] + ["[1][0]" generation] + ["//[1]" /// + [reference + ["[1][0]" variable (.only Register)]] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)]]]]]]]) + +(def .public register + (-> Register Var) + (|>> (///reference.local //reference.system) as_expected)) + +(def .public capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def .public (exec expression archive [this that]) + (Generator [Synthesis Synthesis]) + (do ///////phase.monad + [this (expression archive this) + that (expression archive that)] + (in (|> (_.array (list this that)) + (_.item (_.int +2)))))) + +(def .public (exec! statement expression archive [this that]) + (Generator! [Synthesis Synthesis]) + (do [! ///////phase.monad] + [this (expression archive this) + that (statement expression archive that) + $dummy (at ! each _.var (/////generation.symbol "_exec"))] + (in (all _.then + (_.set (list $dummy) this) + that)))) + +(def .public (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + ... TODO: Find some way to do 'let' without paying the price of the closure. + (in (|> bodyO + _.return + (_.closure (list (..register register))) + (_.apply (list valueO)))))) + +(def .public (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (statement expression archive bodyS)] + (in (all _.then + (_.local/1 (..register register) valueO) + bodyO)))) + +(def .public (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (in (list#mix (function (_ side source) + (.let [method (.if (the member.#right? side) + (//runtime.tuple//right (_.int (.int (the member.#lefts side)))) + (//runtime.tuple//left (_.int (.int (the member.#lefts side)))))] + (method source))) + valueO + (list.reversed pathP))))) + +(def .public (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (in (|> (_.if testO + (_.return thenO) + (_.return elseO)) + (_.closure (list)) + (_.apply (list)))))) + +(def .public (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (statement expression archive thenS) + elseO (statement expression archive elseS)] + (in (_.if testO + thenO + elseO)))) + +(def @savepoint (_.var "lux_pm_savepoint")) +(def @cursor (_.var "lux_pm_cursor")) +(def @temp (_.var "lux_pm_temp")) + +(def (push! value) + (-> Expression Statement) + (_.statement (|> (_.var "table.insert") (_.apply (list @cursor value))))) + +(def peek_and_pop + Expression + (|> (_.var "table.remove") (_.apply (list @cursor)))) + +(def pop! + Statement + (_.statement ..peek_and_pop)) + +(def peek + Expression + (_.item (_.length @cursor) @cursor)) + +(def save! + Statement + (_.statement (|> (_.var "table.insert") + (_.apply (list @savepoint + (_.apply (list @cursor + (_.int +1) + (_.length @cursor) + (_.int +1) + (_.table (list))) + (_.var "table.move"))))))) + +(def restore! + Statement + (_.set (list @cursor) (|> (_.var "table.remove") (_.apply (list @savepoint))))) + +(def fail! _.break) + +(with_template [<name> <flag>] + [(def (<name> simple? idx) + (-> Bit Nat Statement) + (all _.then + (_.set (list @temp) (//runtime.sum//get ..peek <flag> + (|> idx .int _.int))) + (.if simple? + (_.when (_.= _.nil @temp) + fail!) + (_.if (_.= _.nil @temp) + fail! + (..push! @temp)))))] + + [left_choice _.nil] + [right_choice //runtime.unit] + ) + +(def (alternation pre! post!) + (-> Statement Statement Statement) + (all _.then + (_.while (_.boolean true) + (all _.then + ..save! + pre!)) + (all _.then + ..restore! + post!))) + +(def (pattern_matching' statement expression archive) + (-> Phase! Phase Archive Path (Operation Statement)) + (function (again pathP) + (.case pathP + {/////synthesis.#Then bodyS} + (statement expression archive bodyS) + + {/////synthesis.#Pop} + (///////phase#in ..pop!) + + {/////synthesis.#Bind register} + (///////phase#in (_.local/1 (..register register) ..peek)) + + {/////synthesis.#Bit_Fork when thenP elseP} + (do [! ///////phase.monad] + [then! (again thenP) + else! (.case elseP + {.#Some elseP} + (again elseP) + + {.#None} + (in ..fail!))] + (in (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^.with_template [<tag> <format>] + [{<tag> item} + (do [! ///////phase.monad] + [clauses (monad.each ! (function (_ [match then]) + (do ! + [then! (again then)] + (in [(_.= (|> match <format>) + ..peek) + then!]))) + {.#Item item})] + (in (list#mix (function (_ [when then!] else!) + (_.if when then! else!)) + ..fail! + clauses)))]) + ([/////synthesis.#I64_Fork (<| _.int .int)] + [/////synthesis.#F64_Fork _.float] + [/////synthesis.#Text_Fork _.string]) + + (^.with_template [<complex> <simple> <choice>] + [(<complex> idx) + (///////phase#in (<choice> false idx)) + + (<simple> idx nextP) + (///////phase#each (_.then (<choice> true idx)) (again nextP))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (/////synthesis.member/left 0) + (///////phase#in (|> ..peek (_.item (_.int +1)) ..push!)) + + (^.with_template [<pm> <getter>] + [(<pm> lefts) + (///////phase#in (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (/////synthesis.!bind_top register thenP) + (do ///////phase.monad + [then! (again thenP)] + (///////phase#in (all _.then + (_.local/1 (..register register) ..peek_and_pop) + then!))) + + (^.with_template [<tag> <combinator>] + [(<tag> preP postP) + (do ///////phase.monad + [pre! (again preP) + post! (again postP)] + (in (<combinator> pre! post!)))]) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation])))) + +(def (pattern_matching statement expression archive pathP) + (-> Phase! Phase Archive Path (Operation Statement)) + (do ///////phase.monad + [pattern_matching! (pattern_matching' statement expression archive pathP)] + (in (all _.then + (_.while (_.boolean true) + pattern_matching!) + (_.statement (|> (_.var "error") (_.apply (list (_.string ////synthesis/case.pattern_matching_error))))))))) + +(def .public dependencies + (-> Path (List Var)) + (|>> ////synthesis/case.storage + (the ////synthesis/case.#dependencies) + set.list + (list#each (function (_ variable) + (.case variable + {///////variable.#Local register} + (..register register) + + {///////variable.#Foreign register} + (..capture register)))))) + +(def .public (case! statement expression archive [valueS pathP]) + (Generator! [Synthesis Path]) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching statement expression archive pathP)] + (in (all _.then + (_.local (list @temp)) + (_.local/1 @cursor (_.array (list stack_init))) + (_.local/1 @savepoint (_.array (list))) + pattern_matching!)))) + +(def .public (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) + (|> [valueS pathP] + (..case! statement expression archive) + (at ///////phase.monad each + (|>> (_.closure (list)) + (_.apply (list)))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/function.lux new file mode 100644 index 000000000..77f3d2caf --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/function.lux @@ -0,0 +1,144 @@ +(.require + [library + [lux (.except Label function) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [meta + [target + ["_" lua (.only Var Expression Label Statement)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Phase! Generator)] + ["[1][0]" reference] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Abstraction Reification Analysis)] + [synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + [arity (.only Arity)] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [meta + [archive + ["[0]" unit]] + ["[0]" cache + [dependency + ["[1]" artifact]]]] + [reference + [variable (.only Register Variable)]]]]]]) + +(def .public (apply expression archive [functionS argsS+]) + (Generator (Reification Synthesis)) + (do [! ///////phase.monad] + [functionO (expression archive functionS) + argsO+ (monad.each ! (expression archive) argsS+)] + (in (_.apply argsO+ functionO)))) + +(def capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def (with_closure inits @self @args body!) + (-> (List Expression) Var (List Var) Statement [Statement Expression]) + (case inits + {.#End} + [(_.function @self @args body!) + @self] + + _ + (let [@inits (|> (list.enumeration inits) + (list#each (|>> product.left ..capture)))] + [(_.function @self @inits + (all _.then + (_.local_function @self @args body!) + (_.return @self))) + (_.apply inits @self)]))) + +(def input + (|>> ++ //case.register)) + +(def (@scope function_name) + (-> unit.ID Label) + (_.label (format (///reference.artifact function_name) "_scope"))) + +(def .public (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do [! ///////phase.monad] + [dependencies (cache.dependencies archive bodyS) + [function_name body!] (/////generation.with_new_context archive dependencies + (do ! + [@scope (at ! each ..@scope + (/////generation.context archive))] + (/////generation.with_anchor [1 @scope] + (statement expression archive bodyS)))) + closureO+ (monad.each ! (expression archive) environment) + .let [@curried (_.var "curried") + arityO (|> arity .int _.int) + @num_args (_.var "num_args") + @scope (..@scope function_name) + @self (_.var (///reference.artifact function_name)) + initialize_self! (_.local/1 (//case.register 0) @self) + initialize! (list#mix (.function (_ post pre!) + (all _.then + pre! + (_.local/1 (..input post) (_.item (|> post ++ .int _.int) @curried)))) + initialize_self! + (list.indices arity)) + pack (|>> (list) _.array) + unpack (is (-> Expression Expression) + (.function (_ it) + (_.apply (list it) (_.var "table.unpack")))) + @var_args (_.var "...")] + .let [[definition instantiation] (with_closure closureO+ @self (list @var_args) + (all _.then + (_.local/1 @curried (pack @var_args)) + (_.local/1 @num_args (_.length @curried)) + (<| (_.if (|> @num_args (_.= arityO)) + (all _.then + initialize! + (_.set_label @scope) + body!)) + (_.if (|> @num_args (_.> arityO)) + (let [arity_inputs (_.apply (list @curried + (_.int +1) + arityO + (_.int +1) + (_.array (list))) + (_.var "table.move")) + extra_inputs (_.apply (list @curried + (_.+ (_.int +1) arityO) + @num_args + (_.int +1) + (_.array (list))) + (_.var "table.move"))] + (_.return (|> @self + (_.apply (list (unpack arity_inputs))) + (_.apply (list (unpack extra_inputs))))))) + ... (|> @num_args (_.< arityO)) + (_.return (_.closure (list @var_args) + (let [@extra_args (_.var "extra_args")] + (all _.then + (_.local/1 @extra_args (pack @var_args)) + (_.return (_.apply (list (unpack (_.apply (list @extra_args + (_.int +1) + (_.length @extra_args) + (_.+ (_.int +1) @num_args) + (_.apply (list @curried + (_.int +1) + @num_args + (_.int +1) + (_.array (list))) + (_.var "table.move"))) + (_.var "table.move")))) + @self))))))) + ))] + _ (/////generation.execute! definition) + _ (/////generation.save! (product.right function_name) {.#None} definition)] + (in instantiation))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/loop.lux new file mode 100644 index 000000000..bef9f9893 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/loop.lux @@ -0,0 +1,124 @@ +(.require + [library + [lux (.except Label Scope) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" set]]] + [math + [number + ["n" nat]]] + [meta + [target + ["_" lua (.only Var Expression Label Statement)]]]]] + ["[0]" // + [runtime (.only Operation Phase Phase! Generator Generator!)] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["//[1]" /// + ["[0]"synthesis (.only Scope Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + ["[1][0]" phase] + [meta + [archive (.only Archive)] + ["[0]" cache + [dependency + ["[1]" artifact]]]] + [reference + [variable (.only Register)]]]]]]) + +(def @scope + (-> Nat Label) + (|>> %.nat (format "scope") _.label)) + +(def (setup initial? offset bindings as_expression? body) + (-> Bit Register (List Expression) Bit Statement Statement) + (let [variables (|> bindings + list.enumeration + (list#each (|>> product.left (n.+ offset) //case.register)))] + (if as_expression? + body + (all _.then + (if initial? + (_.let variables (_.multi bindings)) + (_.set variables (_.multi bindings))) + body)))) + +(def .public (scope! statement expression archive as_expression? [start initsS+ bodyS]) + ... (Generator! (Scope Synthesis)) + (-> Phase! Phase Archive Bit (Scope Synthesis) + (Operation [(List Expression) Statement])) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (|> bodyS + (statement expression archive) + (at ///////phase.monad each (|>> [(list)]))) + + ... true loop + _ + (do [! ///////phase.monad] + [@scope (at ! each ..@scope /////generation.next) + initsO+ (monad.each ! (expression archive) initsS+) + body! (/////generation.with_anchor [start @scope] + (statement expression archive bodyS))] + (in [initsO+ + (..setup true start initsO+ as_expression? + (all _.then + (_.set_label @scope) + body!))])))) + +(def .public (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [dependencies (cache.dependencies archive bodyS) + [[artifact_module artifact_id] [initsO+ scope!]] (/////generation.with_new_context archive dependencies + (scope! statement expression archive true [start initsS+ bodyS])) + .let [@loop (_.var (///reference.artifact [artifact_module artifact_id])) + locals (|> initsO+ + list.enumeration + (list#each (|>> product.left (n.+ start) //case.register))) + [declaration instantiation] (is [Statement Expression] + (case (|> (synthesis.path/then bodyS) + //case.dependencies + (set.of_list _.hash) + (set.difference (set.of_list _.hash locals)) + set.list) + {.#End} + [(_.function @loop locals + scope!) + @loop] + + foreigns + (let [@context (_.var (format (_.code @loop) "_context"))] + [(_.function @context foreigns + (all _.then + (<| (_.local_function @loop locals) + scope!) + (_.return @loop) + )) + (_.apply foreigns @context)])))] + _ (/////generation.execute! declaration) + _ (/////generation.save! artifact_id {.#None} declaration)] + (in (_.apply initsO+ instantiation))))) + +(def .public (again! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do [! ///////phase.monad] + [[offset @scope] /////generation.anchor + argsO+ (monad.each ! (expression archive) argsS+)] + (in (..setup false offset argsO+ false (_.go_to @scope))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/primitive.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/primitive.lux new file mode 100644 index 000000000..48c05d948 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/primitive.lux @@ -0,0 +1,17 @@ +(.require + [library + [lux (.except i64) + [meta + [target + ["_" lua (.only Literal)]]]]]) + +(with_template [<name> <type> <implementation>] + [(def .public <name> + (-> <type> Literal) + <implementation>)] + + [bit Bit _.boolean] + [i64 (I64 Any) (|>> .int _.int)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/reference.lux new file mode 100644 index 000000000..f7309bb8c --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/reference.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [meta + [target + ["_" lua (.only Expression)]]]]] + [/// + [reference (.only System)]]) + +(def .public system + (System Expression) + (implementation + (def constant' _.var) + (def variable' _.var))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/runtime.lux new file mode 100644 index 000000000..8a124aadc --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/runtime.lux @@ -0,0 +1,452 @@ +(.require + [library + [lux (.except Label Location left right) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" sequence]]] + [math + [number (.only hex) + ["[0]" i64]]] + ["[0]" meta (.only) + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)]] + ["@" target (.only) + ["_" lua (.only Expression Location Var Computation Literal Label Statement)]]]]] + ["[0]" /// + ["[1][0]" reference] + ["//[1]" /// + ["[1][0]" synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// (.only) + ["[1][0]" phase] + [reference + [variable (.only Register)]] + [meta + [archive (.only Output Archive) + ["[0]" registry (.only Registry)] + ["[0]" unit]]]]]]) + +(with_template [<name> <base>] + [(type .public <name> + (<base> [Register Label] Expression Statement))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type .public (Generator i) + (-> Phase Archive i (Operation Expression))) + +(type .public Phase! + (-> Phase Archive Synthesis (Operation Statement))) + +(type .public (Generator! i) + (-> Phase! Phase Archive i (Operation Statement))) + +(def .public unit + (_.string /////synthesis.unit)) + +(def (flag value) + (-> Bit Literal) + (if value + ..unit + _.nil)) + +(def .public variant_tag_field "_lux_tag") +(def .public variant_flag_field "_lux_flag") +(def .public variant_value_field "_lux_value") + +(def (variant' tag last? value) + (-> Expression Expression Expression Literal) + (_.table (list [..variant_tag_field tag] + [..variant_flag_field last?] + [..variant_value_field value]))) + +(def .public (variant tag last? value) + (-> Nat Bit Expression Literal) + (variant' (_.int (.int tag)) + (flag last?) + value)) + +(def .public left + (-> Expression Literal) + (..variant 0 #0)) + +(def .public right + (-> Expression Literal) + (..variant 0 #1)) + +(def .public none + Literal + (..left ..unit)) + +(def .public some + (-> Expression Literal) + ..right) + +(def (feature name definition) + (-> Var (-> Var Statement) Statement) + (definition name)) + +(def .public with_vars + (syntax (_ [vars (<code>.tuple (<>.some <code>.local)) + body <code>.any]) + (do [! meta.monad] + [ids (monad.all ! (list.repeated (list.size vars) meta.seed))] + (in (list (` (let [(,* (|> vars + (list.zipped_2 ids) + (list#each (function (_ [id var]) + (list (code.local var) + (` (_.var (, (code.text (format "v" (%.nat id))))))))) + list.together))] + (, body)))))))) + +(def module_id + 0) + +(def runtime + (syntax (_ [declaration (<>.or <code>.local + (<code>.form (<>.and <code>.local + (<>.some <code>.local)))) + code <code>.any]) + (do meta.monad + [runtime_id meta.seed] + (macro.with_symbols [g!_] + (let [runtime (code.local (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (, (code.text (%.code runtime)))))] + (case declaration + {.#Left name} + (macro.with_symbols [g!_] + (let [g!name (code.local name)] + (in (list (` (def .public (, g!name) + Var + (, runtime_name))) + + (` (def (, (code.local (format "@" name))) + Statement + (..feature (, runtime_name) + (function ((, g!_) (, g!name)) + (_.set (, g!name) (, code)))))))))) + + {.#Right [name inputs]} + (macro.with_symbols [g!_] + (let [g!name (code.local name) + inputsC (list#each code.local inputs) + inputs_typesC (list#each (function.constant (` _.Expression)) + inputs)] + (in (list (` (def .public ((, g!name) (,* inputsC)) + (-> (,* inputs_typesC) Computation) + (_.apply (list (,* inputsC)) (, runtime_name)))) + + (` (def (, (code.local (format "@" name))) + Statement + (..feature (, runtime_name) + (function ((, g!_) (, g!_)) + (..with_vars [(,* inputsC)] + (_.function (, g!_) (list (,* inputsC)) + (, code))))))))))))))))) + +(def (item index table) + (-> Expression Expression Location) + (_.item (_.+ (_.int +1) index) table)) + +(def last_index + (|>> _.length (_.- (_.int +1)))) + +(with_expansions [<recur> (these (all _.then + (_.set (list lefts) (_.- last_index_right lefts)) + (_.set (list tuple) (..item last_index_right tuple))))] + (runtime + (tuple//left lefts tuple) + (with_vars [last_index_right] + (<| (_.while (_.boolean true)) + (all _.then + (_.local/1 last_index_right (..last_index tuple)) + (_.if (_.> lefts last_index_right) + ... No need for recursion + (_.return (..item lefts tuple)) + ... Needs recursion + <recur>))))) + + (runtime + (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (<| (_.while (_.boolean true)) + (all _.then + (_.local/1 last_index_right (..last_index tuple)) + (_.local/1 right_index (_.+ (_.int +1) lefts)) + (<| (_.if (_.= last_index_right right_index) + (_.return (..item right_index tuple))) + (_.if (_.> last_index_right right_index) + ... Needs recursion. + <recur>) + (_.return (_.apply (list tuple + (_.+ (_.int +1) right_index) + (_.length tuple) + (_.int +1) + (_.array (list))) + (_.var "table.move")))) + ))))) + +(runtime + (sum//get sum expected::right? expected::lefts) + (let [mismatch! (_.return _.nil) + actual::lefts (_.the ..variant_tag_field sum) + actual::right? (_.the ..variant_flag_field sum) + actual::value (_.the ..variant_value_field sum) + recur! (all _.then + (_.set (list expected::lefts) (|> expected::lefts + (_.- actual::lefts) + (_.- (_.int +1)))) + (_.set (list sum) actual::value))] + (<| (_.while (_.boolean true)) + (_.if (_.= expected::lefts actual::lefts) + (_.if (_.= expected::right? actual::right?) + (_.return actual::value) + mismatch!)) + (_.if (_.< expected::lefts actual::lefts) + (_.if (_.= ..unit actual::right?) + recur! + mismatch!)) + (_.if (_.= ..unit expected::right?) + (_.return (variant' (|> actual::lefts + (_.- expected::lefts) + (_.- (_.int +1))) + actual::right? + actual::value))) + mismatch!))) + +(def runtime//adt + Statement + (all _.then + @tuple//left + @tuple//right + @sum//get + )) + +(runtime + (lux//try risky) + (with_vars [success value] + (all _.then + (_.let (list success value) (|> risky (_.apply (list ..unit)) + _.return (_.closure (list)) + list _.apply (|> (_.var "pcall")))) + (_.if success + (_.return (..right value)) + (_.return (..left value)))))) + +(runtime + (lux//program_args raw) + (with_vars [tail head idx] + (all _.then + (_.let (list tail) ..none) + (<| (_.for_step idx (_.length raw) (_.int +1) (_.int -1)) + (_.set (list tail) (..some (_.array (list (_.item idx raw) + tail))))) + (_.return tail)))) + +(def runtime//lux + Statement + (all _.then + @lux//try + @lux//program_args + )) + +(def cap_shift + (_.% (_.int +64))) + +(runtime + (i64//left_shifted param subject) + (_.return (_.bit_shl (..cap_shift param) subject))) + +(runtime + (i64//right_shifted param subject) + (let [mask (|> (_.int +1) + (_.bit_shl (_.- param (_.int +64))) + (_.- (_.int +1)))] + (all _.then + (_.set (list param) (..cap_shift param)) + (_.return (|> subject + (_.bit_shr param) + (_.bit_and mask)))))) + +(runtime + (i64//division param subject) + (with_vars [floored] + (all _.then + (_.local/1 floored (_.// param subject)) + (let [potentially_floored? (_.< (_.int +0) floored) + inexact? (|> subject + (_.% param) + (_.= (_.int +0)) + _.not)] + (_.if (_.and potentially_floored? + inexact?) + (_.return (_.+ (_.int +1) floored)) + (_.return floored)))))) + +(runtime + (i64//remainder param subject) + (_.return (_.- (|> subject (..i64//division param) (_.* param)) + subject))) + +(def runtime//i64 + Statement + (all _.then + @i64//left_shifted + @i64//right_shifted + @i64//division + @i64//remainder + )) + +(def (find_byte_index subject param start) + (-> Expression Expression Expression Expression) + (_.apply (list subject param start (_.boolean #1)) + (_.var "string.find"))) + +(def (char_index subject byte_index) + (-> Expression Expression Expression) + (_.apply (list subject (_.int +1) byte_index) + (_.var "utf8.len"))) + +(def (byte_index subject char_index) + (-> Expression Expression Expression) + (_.apply (list subject (_.+ (_.int +1) char_index)) (_.var "utf8.offset"))) + +(def lux_index + (-> Expression Expression) + (_.- (_.int +1))) + +... TODO: Remove this once the Lua compiler becomes self-hosted. +(def on_rembulan? + (_.= (_.string "Lua 5.3") + (_.var "_VERSION"))) + +(runtime + (text//index subject param start) + (with_expansions [<rembulan> (all _.then + (_.local/1 byte_index (|> start + (_.+ (_.int +1)) + (..find_byte_index subject param))) + (_.if (_.= _.nil byte_index) + (_.return ..none) + (_.return (..some (..lux_index byte_index))))) + <normal> (all _.then + (_.local/1 byte_index (|> start + (..byte_index subject) + (..find_byte_index subject param))) + (_.if (_.= _.nil byte_index) + (_.return ..none) + (_.return (..some (|> byte_index + (..char_index subject) + ..lux_index)))))] + (with_vars [byte_index] + (for @.lua <normal> + (_.if ..on_rembulan? + <rembulan> + <normal>))))) + +(runtime + (text//clip text offset length) + (with_expansions [<rembulan> (_.return (_.apply (list text (_.+ (_.int +1) offset) (_.+ offset length)) + (_.var "string.sub"))) + <normal> (_.return (_.apply (list text + (..byte_index text offset) + (|> (_.+ offset length) + ... (_.+ (_.int +1)) + (..byte_index text) + (_.- (_.int +1)))) + (_.var "string.sub")))] + (for @.lua <normal> + (_.if ..on_rembulan? + <rembulan> + <normal>)))) + +(runtime + (text//size subject) + (with_expansions [<rembulan> (_.return (_.apply (list subject) (_.var "string.len"))) + <normal> (_.return (_.apply (list subject) (_.var "utf8.len")))] + (for @.lua <normal> + (_.if ..on_rembulan? + <rembulan> + <normal>)))) + +(runtime + (text//char idx text) + (with_expansions [<rembulan> (with_vars [char] + (all _.then + (_.local/1 char (_.apply (list text idx) + (_.var "string.byte"))) + (_.if (_.= _.nil char) + (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text."))) + (_.return char)))) + <normal> (with_vars [offset char] + (all _.then + (_.local/1 offset (_.apply (list text idx) (_.var "utf8.offset"))) + (_.if (_.= _.nil offset) + (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text."))) + (_.return (_.apply (list text offset) (_.var "utf8.codepoint"))))))] + (for @.lua <normal> + (_.if ..on_rembulan? + <rembulan> + <normal>)))) + +(def runtime//text + Statement + (all _.then + @text//index + @text//clip + @text//size + @text//char + )) + +(runtime + (array//write idx value array) + (all _.then + (_.set (list (..item idx array)) value) + (_.return array))) + +(def runtime//array + Statement + (all _.then + @array//write + )) + +(def runtime + Statement + (all _.then + ..runtime//adt + ..runtime//lux + ..runtime//i64 + ..runtime//text + ..runtime//array + )) + +(def .public generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..module_id {.#None} ..runtime)] + (in [(|> registry.empty + (registry.resource true unit.none) + product.right) + (sequence.sequence [..module_id + {.#None} + (|> ..runtime + _.code + (at utf8.codec encoded))])]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/structure.lux new file mode 100644 index 000000000..e3b0c8c66 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/lua/structure.lux @@ -0,0 +1,36 @@ +(.require + [library + [lux (.except Tuple Variant) + [abstract + ["[0]" monad (.only do)]] + [meta + [target + ["_" lua (.only Expression)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" primitive] + ["///[1]" //// + ["[1][0]" synthesis (.only Synthesis)] + [analysis + [complex (.only Variant Tuple)]] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)]]]]) + +(def .public (tuple phase archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + {.#End} + (///////phase#in (//primitive.text /////synthesis.unit)) + + {.#Item singletonS {.#End}} + (phase archive singletonS) + + _ + (|> elemsS+ + (monad.each ///////phase.monad (phase archive)) + (///////phase#each _.array)))) + +(def .public (variant phase archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (///////phase#each (//runtime.variant lefts right?) + (phase archive valueS))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php.lux new file mode 100644 index 000000000..293366280 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php.lux @@ -0,0 +1,110 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" exception (.only exception)]] + [meta + [macro + ["^" pattern]] + [target + ["_" php]]]]] + ["[0]" / + [runtime (.only Phase Phase!)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["[1][0]" function] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" extension] + ["/[1]" // + [analysis (.only)] + ["[1][0]" synthesis] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference (.only) + [variable (.only)]]]]]]]) + +(def (statement expression archive synthesis) + Phase! + (case synthesis + (^.with_template [<tag>] + [(<tag> value) + (//////phase#each _.return (expression archive synthesis))]) + ([////synthesis.bit] + [////synthesis.i64] + [////synthesis.f64] + [////synthesis.text] + [////synthesis.variant] + [////synthesis.tuple] + [////synthesis.branch/get] + [////synthesis.function/apply]) + + (^.with_template [<tag>] + [{<tag> value} + (//////phase#each _.return (expression archive synthesis))]) + ([////synthesis.#Reference] + [////synthesis.#Extension]) + + (////synthesis.branch/case case) + (/case.case! statement expression archive case) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> statement expression archive value)]) + ([////synthesis.branch/let /case.let!] + [////synthesis.branch/if /case.if!] + [////synthesis.loop/scope /loop.scope!] + [////synthesis.loop/again /loop.again!]) + + (////synthesis.function/abstraction abstraction) + (//////phase#each _.return (/function.function statement expression archive abstraction)) + )) + +(exception .public cannot_recur_as_an_expression) + +(def .public (expression archive synthesis) + Phase + (case synthesis + (^.with_template [<tag> <generator>] + [(<tag> value) + (//////phase#in (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + {////synthesis.#Reference value} + (//reference.reference /reference.system archive value) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> expression archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply]) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> statement expression archive value)]) + ([////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.function/abstraction /function.function]) + + (////synthesis.loop/again _) + (//////phase.except ..cannot_recur_as_an_expression []) + + {////synthesis.#Extension extension} + (///extension.apply archive expression extension))) + +(def .public generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/case.lux new file mode 100644 index 000000000..816b77d0f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/case.lux @@ -0,0 +1,297 @@ +(.require + [library + [lux (.except case let if) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set]]] + [math + [number + ["i" int]]] + [meta + [macro + ["^" pattern]] + [target + ["_" php (.only Expression Var Statement)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Phase! Generator Generator!)] + ["[1][0]" reference] + ["[1][0]" primitive] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" synthesis + ["[1]/[0]" case]] + ["/[1]" // + ["[1][0]" synthesis (.only Member Synthesis Path)] + ["[1][0]" generation] + ["//[1]" /// + [reference + ["[1][0]" variable (.only Register)]] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)]]]]]]]) + +(def .public register + (-> Register Var) + (|>> (///reference.local //reference.system) as_expected)) + +(def .public capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def .public (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS) + bodyG (expression archive bodyS)] + (in (|> bodyG + (list (_.set (..register register) valueG)) + _.array/* + (_.item (_.int +1)))))) + +(def .public (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + body! (statement expression archive bodyS)] + (in (all _.then + (_.set! (..register register) valueO) + body!)))) + +(def .public (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testG (expression archive testS) + thenG (expression archive thenS) + elseG (expression archive elseS)] + (in (_.? testG thenG elseG)))) + +(def .public (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [test! (expression archive testS) + then! (statement expression archive thenS) + else! (statement expression archive elseS)] + (in (_.if test! + then! + else!)))) + +(def .public (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueG (expression archive valueS)] + (in (list#mix (function (_ side source) + (.let [method (.case side + (^.with_template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([.#Left //runtime.tuple//left] + [.#Right //runtime.tuple//right]))] + (method source))) + valueG + (list.reversed pathP))))) + +(def @savepoint (_.var "lux_pm_savepoint")) +(def @cursor (_.var "lux_pm_cursor")) +(def @temp (_.var "lux_pm_temp")) + +(def (push! value) + (-> Expression Statement) + (_.; (_.array_push/2 [@cursor value]))) + +(def peek_and_pop + Expression + (_.array_pop/1 @cursor)) + +(def pop! + Statement + (_.; ..peek_and_pop)) + +(def peek + Expression + (_.item (|> @cursor _.count/1 (_.- (_.int +1))) + @cursor)) + +(def save! + Statement + (.let [cursor (_.array_slice/2 [@cursor (_.int +0)])] + (_.; (_.array_push/2 [@savepoint cursor])))) + +(def restore! + Statement + (_.set! @cursor (_.array_pop/1 @savepoint))) + +(def fail! _.break) + +(def (multi_pop! pops) + (-> Nat Statement) + (_.; (_.array_splice/3 [@cursor + (_.int +0) + (_.int (i.* -1 (.int pops)))]))) + +(with_template [<name> <flag> <prep>] + [(def (<name> simple? idx) + (-> Bit Nat Statement) + (all _.then + (_.set! @temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) + (.if simple? + (_.when (_.is_null/1 @temp) + fail!) + (_.if (_.is_null/1 @temp) + fail! + (..push! @temp)))))] + + [left_choice _.null (<|)] + [right_choice (_.string "") ++] + ) + +(def (alternation pre! post!) + (-> Statement Statement Statement) + (all _.then + (_.do_while (_.bool false) + (all _.then + ..save! + pre!)) + (all _.then + ..restore! + post!))) + +(def (pattern_matching' statement expression archive) + (Generator! Path) + (function (again pathP) + (.case pathP + {/////synthesis.#Then bodyS} + (statement expression archive bodyS) + + {/////synthesis.#Pop} + (///////phase#in ..pop!) + + {/////synthesis.#Bind register} + (///////phase#in (_.set! (..register register) ..peek)) + + {/////synthesis.#Bit_Fork when thenP elseP} + (do [! ///////phase.monad] + [then! (again thenP) + else! (.case elseP + {.#Some elseP} + (again elseP) + + {.#None} + (in ..fail!))] + (in (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^.with_template [<tag> <format>] + [{<tag> item} + (do [! ///////phase.monad] + [clauses (monad.each ! (function (_ [match then]) + (do ! + [then! (again then)] + (in [(_.=== (|> match <format>) + ..peek) + then!]))) + {.#Item item})] + (in (_.cond clauses ..fail!)))]) + ([/////synthesis.#I64_Fork //primitive.i64] + [/////synthesis.#F64_Fork //primitive.f64] + [/////synthesis.#Text_Fork //primitive.text]) + + (^.with_template [<complex> <simple> <choice>] + [(<complex> idx) + (///////phase#in (<choice> false idx)) + + (<simple> idx nextP) + (|> nextP + again + (at ///////phase.monad each (_.then (<choice> true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (/////synthesis.member/left 0) + (///////phase#in (|> ..peek (_.item (_.int +0)) ..push!)) + + (^.with_template [<pm> <getter>] + [(<pm> lefts) + (///////phase#in (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (/////synthesis.!bind_top register thenP) + (do ///////phase.monad + [then! (again thenP)] + (///////phase#in (all _.then + (_.set! (..register register) ..peek_and_pop) + then!))) + + ... (/////synthesis.!multi_pop nextP) + ... (.let [[extra_pops nextP'] (////synthesis/case.count_pops nextP)] + ... (do ///////phase.monad + ... [next! (again nextP')] + ... (///////phase#in (all _.then + ... (..multi_pop! (n.+ 2 extra_pops)) + ... next!)))) + + (^.with_template [<tag> <combinator>] + [(<tag> preP postP) + (do ///////phase.monad + [pre! (again preP) + post! (again postP)] + (in (<combinator> pre! post!)))]) + ([/////synthesis.path/seq _.then] + [/////synthesis.path/alt ..alternation])))) + +(def (pattern_matching statement expression archive pathP) + (Generator! Path) + (do ///////phase.monad + [iteration! (pattern_matching' statement expression archive pathP)] + (in (all _.then + (_.do_while (_.bool false) + iteration!) + (_.throw (_.new (_.constant "Exception") (list (_.string ////synthesis/case.pattern_matching_error)))))))) + +(def .public dependencies + (-> Path (List Var)) + (|>> ////synthesis/case.storage + (the ////synthesis/case.#dependencies) + set.list + (list#each (function (_ variable) + (.case variable + {///////variable.#Local register} + (..register register) + + {///////variable.#Foreign register} + (..capture register)))))) + +(def .public (case! statement expression archive [valueS pathP]) + (Generator! [Synthesis Path]) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching statement expression archive pathP)] + (in (all _.then + (_.set! @cursor (_.array/* (list stack_init))) + (_.set! @savepoint (_.array/* (list))) + pattern_matching!)))) + +(def .public (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) + (do [! ///////phase.monad] + [[[case_module case_artifact] case!] (/////generation.with_new_context archive + (case! statement expression archive [valueS pathP])) + .let [@case (_.constant (///reference.artifact [case_module case_artifact])) + @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS) + pathP)) + declaration (_.define_function @case (list#each _.parameter @dependencies+) case!)] + _ (/////generation.execute! declaration) + _ (/////generation.save! case_artifact declaration)] + (in (_.apply @dependencies+ @case)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/extension.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/extension.lux new file mode 100644 index 000000000..1d1c8473f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/extension.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + [// + [runtime (.only Bundle)]] + [/ + ["[0]" common]]) + +(def .public bundle + Bundle + common.bundle) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/extension/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/extension/common.lux new file mode 100644 index 000000000..26e582da3 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/extension/common.lux @@ -0,0 +1,113 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text] + [number + ["f" frac]] + [collection + ["[0]" dictionary]]] + [meta + [target + ["_" php (.only Expression)]]]]] + ["[0]" /// + ["[1][0]" runtime (.only Operation Phase Handler Bundle)] + ["[1][0]" primitive] + [// + [extension (.only Nullary Unary Binary Trinary + nullary unary binary trinary)] + [// + [extension + ["[0]" bundle]]]]]) + +(def lux_procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurried _.=))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def i64_procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurried _.bit_and))) + (bundle.install "or" (binary (product.uncurried _.bit_or))) + (bundle.install "xor" (binary (product.uncurried _.bit_xor))) + (bundle.install "left-shift" (binary (product.uncurried _.bit_shl))) + (bundle.install "logical-right-shift" (binary (product.uncurried ///runtime.i64//logic_right_shift))) + (bundle.install "arithmetic-right-shift" (binary (product.uncurried _.bit_shr))) + (bundle.install "=" (binary (product.uncurried _.=))) + (bundle.install "+" (binary (product.uncurried _.+))) + (bundle.install "-" (binary (product.uncurried _.-))) + ))) + +(def int_procs + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "<" (binary (product.uncurried _.<))) + (bundle.install "*" (binary (product.uncurried _.*))) + (bundle.install "/" (binary (product.uncurried _./))) + (bundle.install "%" (binary (product.uncurried _.%))) + (bundle.install "frac" (unary _.floatval/1)) + (bundle.install "char" (unary _.chr/1))))) + +(def frac_procs + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurried _.+))) + (bundle.install "-" (binary (product.uncurried _.-))) + (bundle.install "*" (binary (product.uncurried _.*))) + (bundle.install "/" (binary (product.uncurried _./))) + (bundle.install "%" (binary (product.uncurried _.%))) + (bundle.install "=" (binary (product.uncurried _.=))) + (bundle.install "<" (binary (product.uncurried _.<))) + (bundle.install "int" (unary _.intval/1)) + (bundle.install "encode" (unary _.strval/1)) + (bundle.install "decode" (unary (|>> _.floatval/1 ///runtime.some))) + ))) + +(def (text//index [startO partO textO]) + (Trinary (Expression Any)) + (///runtime.text//index textO partO startO)) + +(def text_procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurried _.=))) + (bundle.install "<" (binary (product.uncurried _.<))) + (bundle.install "concat" (binary (product.uncurried _.concat))) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary _.strlen/1)) + (bundle.install "char" (binary (function (text//char [text idx]) + (|> text (_.item idx) _.ord/1)))) + (bundle.install "clip" (trinary (function (text//clip [from to text]) + (_.substr/3 [text from (_.- from to)])))) + ))) + +(def io_procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> (_.concat (_.string text.new_line)) _.print/1))) + (bundle.install "error" (unary ///runtime.io//throw!)) + (bundle.install "exit" (unary _.exit/1)) + (bundle.install "current-time" (nullary (|>> _.time/0 (_.* (_.int +1,000)))))))) + +(def .public bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux_procs + (dictionary.composite i64_procs) + (dictionary.composite int_procs) + (dictionary.composite frac_procs) + (dictionary.composite text_procs) + (dictionary.composite io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/function.lux new file mode 100644 index 000000000..b2ca21671 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/function.lux @@ -0,0 +1,117 @@ +(.require + [library + [lux (.except Global function) + [abstract + ["[0]" monad (.only do)]] + [control + pipe] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [meta + [target + ["_" php (.only Var Global Expression Argument Label Statement)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Phase! Generator)] + ["[1][0]" reference] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Variant Tuple Abstraction Application Analysis)] + [synthesis (.only Synthesis)] + ["[1][0]" generation (.only Context)] + ["//[1]" /// + [arity (.only Arity)] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference + [variable (.only Register Variable)]]]]]]) + +(def .public (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do [! ///////phase.monad] + [functionG (expression archive functionS) + argsG+ (monad.each ! (expression archive) argsS+)] + (in (_.apply' argsG+ functionG)))) + +(def capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def input + (|>> ++ //case.register)) + +(def (@scope function_name) + (-> Context Label) + (_.label (format (///reference.artifact function_name) "_scope"))) + +(def (with_closure inits @selfG @selfL body!) + (-> (List Expression) Global Var Statement [Statement Expression]) + (case inits + {.#End} + [(all _.then + (_.set! @selfL (_.closure (list (_.reference @selfL)) (list) body!)) + (_.set! @selfG @selfL)) + @selfG] + + _ + (let [@inits (|> (list.enumeration inits) + (list#each (|>> product.left ..capture)))] + [(_.set! @selfG (_.closure (list) (list#each _.parameter @inits) + (all _.then + (_.set! @selfL (_.closure (list.partial (_.reference @selfL) (list#each _.reference @inits)) + (list) + body!)) + (_.return @selfL)))) + (_.apply inits @selfG)]))) + +(def .public (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do [! ///////phase.monad] + [[function_name body!] (/////generation.with_new_context archive + (do ! + [@scope (at ! each ..@scope + (/////generation.context archive))] + (/////generation.with_anchor [1 @scope] + (statement expression archive bodyS)))) + closureG+ (monad.each ! (expression archive) environment) + .let [@curried (_.var "curried") + arityG (|> arity .int _.int) + @num_args (_.var "num_args") + @scope (..@scope function_name) + @selfG (_.global (///reference.artifact function_name)) + @selfL (_.var (///reference.artifact function_name)) + initialize_self! (_.set! (//case.register 0) @selfL) + initialize! (list#mix (.function (_ post pre!) + (all _.then + pre! + (_.set! (..input post) (_.item (|> post .int _.int) @curried)))) + initialize_self! + (list.indices arity))] + .let [[definition instantiation] (..with_closure closureG+ @selfG @selfL + (all _.then + (_.set! @num_args (_.func_num_args/0 [])) + (_.set! @curried (_.func_get_args/0 [])) + (_.cond (list [(|> @num_args (_.=== arityG)) + (all _.then + initialize! + (_.set_label @scope) + body!)] + [(|> @num_args (_.> arityG)) + (let [arity_inputs (_.array_slice/3 [@curried (_.int +0) arityG]) + extra_inputs (_.array_slice/2 [@curried arityG]) + next (_.call_user_func_array/2 [@selfL arity_inputs])] + (_.return (_.call_user_func_array/2 [next extra_inputs])))]) + ... (|> @num_args (_.< arityG)) + (let [@missing (_.var "missing")] + (_.return (<| (_.closure (list (_.reference @selfL) (_.reference @curried)) (list)) + (all _.then + (_.set! @missing (_.func_get_args/0 [])) + (_.return (_.call_user_func_array/2 [@selfL (_.array_merge/+ @curried (list @missing))]))))))) + ))] + _ (/////generation.execute! definition) + _ (/////generation.save! (product.right function_name) definition)] + (in instantiation))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/loop.lux new file mode 100644 index 000000000..5c3682738 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/loop.lux @@ -0,0 +1,125 @@ +(.require + [library + [lux (.except Scope) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set (.only Set)]]] + [math + [number + ["n" nat]]] + [meta + [target + ["_" php (.only Var Expression Label Statement)]]]]] + ["[0]" // + [runtime (.only Operation Phase Phase! Generator Generator!)] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + [synthesis + ["[0]" case]] + ["/[1]" // + ["[0]" synthesis (.only Scope Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + ["[1][0]" phase] + [meta + [archive (.only Archive)]] + [reference + [variable (.only Register)]]]]]]]) + +(def @scope + (-> Nat Label) + (|>> %.nat (format "scope") _.label)) + +(def (setup offset bindings body) + (-> Register (List Expression) Statement Statement) + ... TODO: There is a bug in the way the variables are updated. Do it like it's done in either JS or Lua. + (|> bindings + list.enumeration + (list#each (function (_ [register value]) + (let [variable (//case.register (n.+ offset register))] + (_.set! variable value)))) + list.reversed + (list#mix _.then body))) + +(def .public (scope! statement expression archive [start initsS+ bodyS]) + (Generator! (Scope Synthesis)) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (statement expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [@scope (at ! each ..@scope /////generation.next) + initsO+ (monad.each ! (expression archive) initsS+) + body! (/////generation.with_anchor [start @scope] + (statement expression archive bodyS))] + (in (..setup start initsO+ + (all _.then + (_.set_label @scope) + body!)))))) + +(def .public (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [[[loop_module loop_artifact] scope!] (/////generation.with_new_context archive + (..scope! statement expression archive [start initsS+ bodyS])) + .let [locals (|> initsS+ + list.enumeration + (list#each (|>> product.left (n.+ start) //case.register _.parameter))) + @loop (_.constant (///reference.artifact [loop_module loop_artifact])) + loop_variables (set.of_list _.hash (list#each product.right locals)) + referenced_variables (is (-> Synthesis (Set Var)) + (|>> synthesis.path/then + //case.dependencies + (set.of_list _.hash))) + [declaration instantiation] (is [Statement Expression] + (case (|> (list#each referenced_variables initsS+) + (list#mix set.union (referenced_variables bodyS)) + (set.difference loop_variables) + set.list) + {.#End} + [(_.define_function @loop (list) scope!) + @loop] + + foreigns + [(<| (_.define_function @loop (list#each _.parameter foreigns)) + (_.return (_.closure (list#each _.parameter foreigns) (list) scope!))) + (_.apply foreigns @loop)]))] + _ (/////generation.execute! declaration) + _ (/////generation.save! loop_artifact declaration)] + (in (_.apply (list) instantiation))))) + +... TODO: Stop using a constant hard-coded variable. Generate a new one each time. +(def @temp + (_.var "lux_again_values")) + +(def .public (again! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do [! ///////phase.monad] + [[offset @scope] /////generation.anchor + argsO+ (monad.each ! (expression archive) argsS+)] + (in (all _.then + (_.set! @temp (_.array/* argsO+)) + (..setup offset + (|> argsO+ + list.enumeration + (list#each (function (_ [idx _]) + (_.item (_.int (.int idx)) @temp)))) + (_.go_to @scope)))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/primitive.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/primitive.lux new file mode 100644 index 000000000..eaf53dada --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/primitive.lux @@ -0,0 +1,31 @@ +(.require + [library + [lux (.except i64) + [math + [number + ["[0]" frac]]] + [meta + [target + ["_" php (.only Literal Expression)]]]]] + ["[0]" // + ["[1][0]" runtime]]) + +(def .public bit + (-> Bit Literal) + _.bool) + +(def .public (i64 value) + (-> (I64 Any) Expression) + (let [h32 (|> value //runtime.high .int _.int) + l32 (|> value //runtime.low .int _.int)] + (|> h32 + (_.bit_shl (_.int +32)) + (_.bit_or l32)))) + +(def .public f64 + (-> Frac Literal) + _.float) + +(def .public text + (-> Text Literal) + _.string) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/reference.lux new file mode 100644 index 000000000..2dbdfad8a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/reference.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [meta + [target + ["_" php (.only Expression)]]]]] + [/// + [reference (.only System)]]) + +(def .public system + (System Expression) + (implementation + (def constant _.global) + (def variable _.var))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/runtime.lux new file mode 100644 index 000000000..bff0a6cf0 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/runtime.lux @@ -0,0 +1,635 @@ +(.require + [library + [lux (.except Location) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" sequence]]] + [math + [number (.only hex) + ["[0]" i64]]] + ["[0]" meta (.only) + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)]] + ["@" target (.only) + ["_" php (.only Expression Label Constant Var Computation Literal Statement)]]]]] + ["[0]" /// + ["[1][0]" reference] + ["//[1]" /// + ["[1][0]" synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// (.only) + ["[1][0]" phase] + [reference + [variable (.only Register)]] + [meta + [archive (.only Output Archive) + ["[0]" artifact (.only Registry)]]]]]]) + +(with_template [<name> <base>] + [(type .public <name> + (<base> [Nat Label] Expression Statement))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type .public (Generator i) + (-> Phase Archive i (Operation Expression))) + +(type .public Phase! + (-> Phase Archive Synthesis (Operation Statement))) + +(type .public (Generator! i) + (-> Phase! Phase Archive i (Operation Statement))) + +(def .public unit + (_.string /////synthesis.unit)) + +(def (flag value) + (-> Bit Literal) + (if value + ..unit + _.null)) + +(def (feature name definition) + (-> Constant (-> Constant Statement) Statement) + (definition name)) + +(def .public with_vars + (syntax (_ [vars (<code>.tuple (<>.some <code>.local)) + body <code>.any]) + (do [! meta.monad] + [ids (monad.all ! (list.repeated (list.size vars) meta.seed))] + (in (list (` (let [(,* (|> vars + (list.zipped_2 ids) + (list#each (function (_ [id var]) + (list (code.local var) + (` (_.var (, (code.text (format "v" (%.nat id))))))))) + list.together))] + (, body)))))))) + +(def module_id + 0) + +(def runtime + (syntax (_ [declaration (<>.or <code>.local + (<code>.form (<>.and <code>.local + (<>.some <code>.local)))) + code <code>.any]) + (do meta.monad + [runtime_id meta.seed] + (macro.with_symbols [g!_] + (let [runtime (code.local (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.constant (, (code.text (%.code runtime)))))] + (case declaration + {.#Left name} + (macro.with_symbols [g!_] + (let [g!name (code.local name)] + (in (list (` (def .public (, g!name) + Var + (, runtime_name))) + + (` (def (, (code.local (format "@" name))) + Statement + (..feature (, runtime_name) + (function ((, g!_) (, g!name)) + (_.define (, g!name) (, code)))))))))) + + {.#Right [name inputs]} + (macro.with_symbols [g!_] + (let [g!name (code.local name) + inputsC (list#each code.local inputs) + inputs_typesC (list#each (function.constant (` _.Expression)) + inputs)] + (in (list (` (def .public ((, g!name) (,* inputsC)) + (-> (,* inputs_typesC) Computation) + (_.apply (list (,* inputsC)) (, runtime_name)))) + + (` (def (, (code.local (format "@" name))) + Statement + (..feature (, runtime_name) + (function ((, g!_) (, g!_)) + (..with_vars [(,* inputsC)] + (_.define_function (, g!_) + (list (,* (list#each (|>> (,) [false] (`)) inputsC))) + (, code))))))))))))))))) + +(runtime + (io//log! message) + (all _.then + (_.echo message) + (_.echo (_.string text.new_line)) + (_.return ..unit))) + +(runtime + (io//throw! message) + (all _.then + (_.throw (_.new (_.constant "Exception") (list message))) + (_.return ..unit))) + +(def runtime//io + Statement + (all _.then + @io//log! + @io//throw! + )) + +(def .public tuple_size_field + "_lux_size") + +(def tuple_size + (_.item (_.string ..tuple_size_field))) + +(def jphp? + (_.=== (_.string "5.6.99") (_.phpversion/0 []))) + +(runtime + (array//length array) + ... TODO: Get rid of this as soon as JPHP is no longer necessary. + (_.if ..jphp? + (_.return (..tuple_size array)) + (_.return (_.count/1 array)))) + +(runtime + (array//write idx value array) + (all _.then + (_.set! (_.item idx array) value) + (_.return array))) + +(def runtime//array + Statement + (all _.then + @array//length + @array//write + )) + +(def jphp_last_index + (|>> ..tuple_size (_.- (_.int +1)))) + +(def normal_last_index + (|>> _.count/1 (_.- (_.int +1)))) + +(with_expansions [<recur> (these (all _.then + (_.set! lefts (_.- last_index_right lefts)) + (_.set! tuple (_.item last_index_right tuple))))] + (runtime + (tuple//make size values) + (_.if ..jphp? + (all _.then + (_.set! (..tuple_size values) size) + (_.return values)) + ... https://www.php.net/manual/en/language.operators.assignment.php + ... https://www.php.net/manual/en/language.references.php + ... https://www.php.net/manual/en/functions.arguments.php + ... https://www.php.net/manual/en/language.oop5.references.php + ... https://www.php.net/manual/en/class.arrayobject.php + (_.return (_.new (_.constant "ArrayObject") (list values))))) + + (runtime + (tuple//left lefts tuple) + (with_vars [last_index_right] + (<| (_.while (_.bool true)) + (all _.then + (_.if ..jphp? + (_.set! last_index_right (..jphp_last_index tuple)) + (_.set! last_index_right (..normal_last_index tuple))) + (_.if (_.> lefts last_index_right) + ... No need for recursion + (_.return (_.item lefts tuple)) + ... Needs recursion + <recur>))))) + + ... TODO: Get rid of this as soon as JPHP is no longer necessary. + (runtime + (tuple//slice offset input) + (with_vars [size index output] + (all _.then + (_.set! size (..array//length input)) + (_.set! index (_.int +0)) + (_.set! output (_.array/* (list))) + (<| (_.while (|> index (_.+ offset) (_.< size))) + (all _.then + (_.set! (_.item index output) (_.item (_.+ offset index) input)) + (_.set! index (_.+ (_.int +1) index)) + )) + (_.return (..tuple//make (_.- offset size) output)) + ))) + + (runtime + (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (<| (_.while (_.bool true)) + (all _.then + (_.if ..jphp? + (_.set! last_index_right (..jphp_last_index tuple)) + (_.set! last_index_right (..normal_last_index tuple))) + (_.set! right_index (_.+ (_.int +1) lefts)) + (_.cond (list [(_.=== last_index_right right_index) + (_.return (_.item right_index tuple))] + [(_.> last_index_right right_index) + ... Needs recursion. + <recur>]) + (_.if ..jphp? + (_.return (..tuple//make (_.- right_index (..tuple_size tuple)) + (..tuple//slice right_index tuple))) + (_.return (..tuple//make (_.- right_index (_.count/1 tuple)) + (_.array_slice/2 [(_.do "getArrayCopy" (list) tuple) right_index]))))) + ))))) + +(def .public variant_tag_field "_lux_tag") +(def .public variant_flag_field "_lux_flag") +(def .public variant_value_field "_lux_value") + +(runtime + (sum//make tag last? value) + (_.return (_.array/** (list [(_.string ..variant_tag_field) tag] + [(_.string ..variant_flag_field) last?] + [(_.string ..variant_value_field) value])))) + +(def .public (variant tag last? value) + (-> Nat Bit Expression Computation) + (sum//make (_.int (.int tag)) + (..flag last?) + value)) + +(def .public none + Computation + (..variant 0 #0 ..unit)) + +(def .public some + (-> Expression Computation) + (..variant 1 #1)) + +(def .public left + (-> Expression Computation) + (..variant 0 #0)) + +(def .public right + (-> Expression Computation) + (..variant 1 #1)) + +(runtime + (sum//get sum wantsLast wantedTag) + (let [no_match! (_.return _.null) + sum_tag (_.item (_.string ..variant_tag_field) sum) + ... sum_tag (_.item (_.int +0) sum) + sum_flag (_.item (_.string ..variant_flag_field) sum) + ... sum_flag (_.item (_.int +1) sum) + sum_value (_.item (_.string ..variant_value_field) sum) + ... sum_value (_.item (_.int +2) sum) + is_last? (_.=== ..unit sum_flag) + test_recursion! (_.if is_last? + ... Must recurse. + (all _.then + (_.set! wantedTag (_.- sum_tag wantedTag)) + (_.set! sum sum_value)) + no_match!)] + (<| (_.while (_.bool true)) + (_.cond (list [(_.=== sum_tag wantedTag) + (_.if (_.=== wantsLast sum_flag) + (_.return sum_value) + test_recursion!)] + + [(_.< wantedTag sum_tag) + test_recursion!] + + [(_.=== ..unit wantsLast) + (_.return (sum//make (_.- wantedTag sum_tag) sum_flag sum_value))]) + no_match!)))) + +(def runtime//adt + Statement + (all _.then + @tuple//make + @tuple//left + @tuple//slice + @tuple//right + @sum//make + @sum//get + )) + +(runtime + (lux//try op) + (with_vars [value] + (_.try (all _.then + (_.set! value (_.apply/1 op [..unit])) + (_.return (..right value))) + (list (with_vars [error] + [_.#class (_.constant "Exception") + _.#exception error + _.#handler (_.return (..left (_.do "getMessage" (list) error)))]))))) + +(runtime + (lux//program_args inputs) + (with_vars [head tail] + (all _.then + (_.set! tail ..none) + (<| (_.for_each (_.array_reverse/1 inputs) head) + (_.set! tail (..some (_.array/* (list head tail))))) + (_.return tail)))) + +(def runtime//lux + Statement + (all _.then + @lux//try + @lux//program_args + )) + +(def .public high + (-> (I64 Any) (I64 Any)) + (i64.right_shifted 32)) + +(def .public low + (-> (I64 Any) (I64 Any)) + (let [mask (-- (i64.left_shifted 32 1))] + (|>> (i64.and mask)))) + +(runtime + (i64//right_shifted param subject) + (let [... The mask has to be calculated this way instead of in a more straightforward way + ... because in some languages, 1<<63 = max_negative_value + ... and max_negative_value-1 = max_positive_value. + ... And bitwise, max_positive_value works out to the mask that is desired when param = 0. + ... However, in PHP, max_negative_value-1 underflows and gets cast into a float. + ... And this messes up the computation. + ... This slightly more convoluted calculation avoids that problem. + mask (|> (_.int +1) + (_.bit_shl (_.- param (_.int +63))) + (_.- (_.int +1)) + (_.bit_shl (_.int +1)) + (_.+ (_.int +1)))] + (all _.then + (_.set! param (_.% (_.int +64) param)) + (_.if (_.=== (_.int +0) param) + (_.return subject) + (_.return (|> subject + (_.bit_shr param) + (_.bit_and mask))))))) + +(runtime + (i64//char code) + (_.if ..jphp? + (_.return (_.chr/1 [code])) + (_.return (|> code + [(_.string "V")] + _.pack/2 + [(_.string "UTF-32LE") (_.string "UTF-8")] + _.iconv/3)))) + +(runtime + (i64//+ parameter subject) + (let [high_16 (..i64//right_shifted (_.int +16)) + low_16 (_.bit_and (_.int (.int (hex "FFFF")))) + + cap_16 low_16 + hh (..i64//right_shifted (_.int +48)) + hl (|>> (..i64//right_shifted (_.int +32)) cap_16) + lh (|>> (..i64//right_shifted (_.int +16)) cap_16) + ll cap_16 + + up_16 (_.bit_shl (_.int +16))] + (with_vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + (all _.then + (_.set! l48 (hh subject)) + (_.set! l32 (hl subject)) + (_.set! l16 (lh subject)) + (_.set! l00 (ll subject)) + + (_.set! r48 (hh parameter)) + (_.set! r32 (hl parameter)) + (_.set! r16 (lh parameter)) + (_.set! r00 (ll parameter)) + + (_.set! x00 (_.+ l00 r00)) + + (_.set! x16 (|> (high_16 x00) + (_.+ l16) + (_.+ r16))) + (_.set! x00 (low_16 x00)) + + (_.set! x32 (|> (high_16 x16) + (_.+ l32) + (_.+ r32))) + (_.set! x16 (low_16 x16)) + + (_.set! x48 (|> (high_16 x32) + (_.+ l48) + (_.+ r48) + low_16)) + (_.set! x32 (low_16 x32)) + + (let [high32 (_.bit_or (up_16 x48) x32) + low32 (_.bit_or (up_16 x16) x00)] + (_.return (|> high32 + (_.bit_shl (_.int +32)) + (_.bit_or low32)))) + )))) + +(runtime + (i64//negate value) + (let [i64//min (_.int (.int (hex "80,00,00,00,00,00,00,00")))] + (_.if (_.=== i64//min value) + (_.return i64//min) + (_.return (..i64//+ (_.int +1) (_.bit_not value)))))) + +(runtime + (i64//- parameter subject) + (_.return (..i64//+ (..i64//negate parameter) subject))) + +(runtime + (i64//* parameter subject) + (let [high_16 (..i64//right_shifted (_.int +16)) + low_16 (_.bit_and (_.int (.int (hex "FFFF")))) + + cap_16 low_16 + hh (..i64//right_shifted (_.int +48)) + hl (|>> (..i64//right_shifted (_.int +32)) cap_16) + lh (|>> (..i64//right_shifted (_.int +16)) cap_16) + ll cap_16 + + up_16 (_.bit_shl (_.int +16))] + (with_vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + (all _.then + (_.set! l48 (hh subject)) + (_.set! l32 (hl subject)) + (_.set! l16 (lh subject)) + (_.set! l00 (ll subject)) + + (_.set! r48 (hh parameter)) + (_.set! r32 (hl parameter)) + (_.set! r16 (lh parameter)) + (_.set! r00 (ll parameter)) + + (_.set! x00 (_.* l00 r00)) + (_.set! x16 (high_16 x00)) + (_.set! x00 (low_16 x00)) + + (_.set! x16 (|> x16 (_.+ (_.* l16 r00)))) + (_.set! 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)))) + (_.set! 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)) + + (let [high32 (_.bit_or (up_16 x48) x32) + low32 (_.bit_or (up_16 x16) x00)] + (_.return (|> high32 + (_.bit_shl (_.int +32)) + (_.bit_or low32)))) + )))) + +(def runtime//i64 + Statement + (all _.then + @i64//right_shifted + @i64//char + @i64//+ + @i64//negate + @i64//- + @i64//* + )) + +(runtime + (text//size value) + (_.if ..jphp? + (_.return (_.strlen/1 [value])) + (_.return (_.iconv_strlen/1 [value])))) + +(runtime + (text//index subject param start) + (_.if (_.=== (_.string "") param) + (_.return (..some (_.int +0))) + (with_vars [idx] + (_.if ..jphp? + (all _.then + (_.set! idx (_.strpos/3 [subject param start])) + (_.if (_.=== (_.bool false) idx) + (_.return ..none) + (_.return (..some idx)))) + (all _.then + (_.set! idx (_.iconv_strpos/3 [subject param start])) + (_.if (_.=== (_.bool false) idx) + (_.return ..none) + (_.return (..some idx)))))))) + +(def (within? top value) + (-> Expression Expression Computation) + (_.and (|> value (_.>= (_.int +0))) + (|> value (_.< top)))) + +(runtime + (text//clip offset length text) + (_.if ..jphp? + (_.return (_.substr/3 [text offset length])) + (_.return (_.iconv_substr/3 [text offset length])))) + +(runtime + (text//char idx text) + (_.if (|> idx (within? (text//size text))) + (_.if ..jphp? + (_.return (_.ord/1 (_.substr/3 [text idx (_.int +1)]))) + (_.return (|> (_.iconv_substr/3 [text idx (_.int +1)]) + [(_.string "UTF-8") (_.string "UTF-32LE")] + _.iconv/3 + [(_.string "V")] + _.unpack/2 + (_.item (_.int +1))))) + (_.throw (_.new (_.constant "Exception") (list (_.string "[Lux Error] Cannot get char from text.")))))) + +(def runtime//text + Statement + (all _.then + @text//size + @text//index + @text//clip + @text//char + )) + +(runtime + (f64//decode value) + (with_vars [output] + (all _.then + (_.set! output (_.floatval/1 value)) + (_.if (_.=== (_.float +0.0) output) + (_.if (all _.or + (_.=== (_.string "0.0") output) + (_.=== (_.string "+0.0") output) + (_.=== (_.string "-0.0") output) + (_.=== (_.string "0") output) + (_.=== (_.string "+0") output) + (_.=== (_.string "-0") output)) + (_.return (..some output)) + (_.return ..none)) + (_.return (..some output))) + ))) + +(def runtime//f64 + Statement + (all _.then + @f64//decode + )) + +(def check_necessary_conditions! + Statement + (let [i64_support? (_.=== (_.int +8) (_.constant "PHP_INT_SIZE")) + i64_error (_.string (format "Cannot run program!" text.new_line + "Lux/PHP programs require 64-bit PHP builds!"))] + (_.when (_.not i64_support?) + (_.throw (_.new (_.constant "Exception") (list i64_error)))))) + +(def runtime + Statement + (all _.then + check_necessary_conditions! + runtime//array + runtime//adt + runtime//lux + runtime//i64 + runtime//f64 + runtime//text + runtime//io + )) + +(def .public generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..module_id ..runtime)] + (in [(|> artifact.empty + artifact.resource + product.right) + (sequence.sequence [..module_id + (|> ..runtime + _.code + (at utf8.codec encoded))])]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/structure.lux new file mode 100644 index 000000000..749ba0f5d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/php/structure.lux @@ -0,0 +1,42 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [data + [collection + ["[0]" list]]] + [target + ["_" php (.only Expression)]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" primitive] + ["///[1]" //// + [analysis (.only Variant Tuple)] + ["[1][0]" synthesis (.only Synthesis)] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)]]]]) + +(def .public (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + {.#End} + (///////phase#in (//primitive.text /////synthesis.unit)) + + {.#Item singletonS {.#End}} + (expression archive singletonS) + + _ + (let [size (_.int (.int (list.size elemsS+)))] + (|> elemsS+ + (monad.each ///////phase.monad (expression archive)) + (///////phase#each (|>> _.array/* + (//runtime.tuple//make size))))))) + +(def .public (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (++ lefts) + lefts)] + (///////phase#each (//runtime.variant tag right?) + (expression archive valueS)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python.lux new file mode 100644 index 000000000..cd48b763b --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python.lux @@ -0,0 +1,80 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" exception (.only exception)]] + [meta + [macro + ["^" pattern]] + [target + ["_" python]]]]] + ["[0]" / + [runtime (.only Phase)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" function] + ["[1][0]" case] + ["[1][0]" loop] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" extension (.only) + [generation + [python + ["[1]/[0]" common]]]] + ["/[1]" // + [analysis (.only)] + ["[1][0]" synthesis] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference (.only) + [variable (.only)]]]]]]]) + +(exception .public cannot_recur_as_an_expression) + +(def .public (expression archive synthesis) + Phase + (case synthesis + (^.with_template [<tag> <generator>] + [(<tag> value) + (//////phase#in (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> expression archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + + [////synthesis.branch/exec /case.exec] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + + [////synthesis.function/apply /function.apply]) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> ///extension/common.statement expression archive value)]) + ([////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.function/abstraction /function.function]) + + (////synthesis.loop/again updates) + (//////phase.except ..cannot_recur_as_an_expression []) + + {////synthesis.#Reference value} + (//reference.reference /reference.system archive value) + + {////synthesis.#Extension extension} + (///extension.apply archive expression extension))) + +(def .public generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/case.lux new file mode 100644 index 000000000..090c2587e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/case.lux @@ -0,0 +1,362 @@ +(.require + [library + [lux (.except case exec let if symbol) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set]]] + [math + [number + ["n" nat] + ["i" int]]] + [meta + [macro + ["^" pattern]] + [target + ["_" python (.only Expression SVar Statement)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator Phase! Generator!)] + ["[1][0]" reference] + ["[1][0]" primitive] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + [synthesis + ["[0]" case]] + ["/[1]" // + ["[1][0]" generation] + ["[1][0]" synthesis (.only Synthesis Path) + [access + ["[0]" member (.only Member)]]] + ["//[1]" /// + [reference + ["[1][0]" variable (.only Register)]] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)] + ["[0]" cache + [dependency + ["[1]" artifact]]]]]]]]]) + +(def .public (symbol prefix) + (-> Text (Operation SVar)) + (///////phase#each (|>> %.nat (format prefix) _.var) + /////generation.next)) + +(def .public register + (-> Register SVar) + (|>> (///reference.local //reference.system) as_expected)) + +(def .public capture + (-> Register SVar) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def .public (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + ... TODO: Find some way to do 'let' without paying the price of the closure. + (in (_.apply (list valueO) + (_.lambda (list (..register register)) + bodyO))))) + +(def .public (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (statement expression archive bodyS)] + (in (all _.then + (_.set (list (..register register)) valueO) + bodyO)))) + +(def .public (exec expression archive [pre post]) + (Generator [Synthesis Synthesis]) + (do ///////phase.monad + [pre (expression archive pre) + post (expression archive post)] + (in (_.item (_.int +1) (_.tuple (list pre post)))))) + +(def .public (exec! statement expression archive [pre post]) + (Generator! [Synthesis Synthesis]) + (do ///////phase.monad + [pre (expression archive pre) + post (statement expression archive post)] + (in (all _.then + (_.statement pre) + post)))) + +(def .public (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (in (_.? testO thenO elseO)))) + +(def .public (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [test! (expression archive testS) + then! (statement expression archive thenS) + else! (statement expression archive elseS)] + (in (_.if test! + then! + else!)))) + +(def .public (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (in (list#mix (function (_ side source) + (.let [method (.if (the member.#right? side) + //runtime.tuple::right + //runtime.tuple::left)] + (method (_.int (.int (the member.#lefts side))) + source))) + valueO + (list.reversed pathP))))) + +(def @savepoint (_.var "lux_pm_savepoint")) +(def @cursor (_.var "lux_pm_cursor")) +(def @temp (_.var "lux_pm_temp")) + +(def (push! value) + (-> (Expression Any) (Statement Any)) + (_.statement (|> @cursor (_.do "append" (list value))))) + +(def peek_and_pop + (Expression Any) + (|> @cursor (_.do "pop" (list)))) + +(def pop! + (Statement Any) + (_.statement ..peek_and_pop)) + +(def peek + (Expression Any) + (_.item (_.int -1) @cursor)) + +(def save! + (Statement Any) + (.let [cursor (_.slice_from (_.int +0) @cursor)] + (_.statement (|> @savepoint (_.do "append" (list cursor)))))) + +(def restore! + (Statement Any) + (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) + +(def fail_pm! _.break) + +(def (multi_pop! pops) + (-> Nat (Statement Any)) + (_.delete (_.slice_from (_.int (i.* -1 (.int pops))) @cursor))) + +(with_template [<name> <flag>] + [(def (<name> simple? idx) + (-> Bit Nat (Statement Any)) + (all _.then + (_.set (list @temp) (//runtime.sum::get ..peek <flag> + (|> idx .int _.int))) + (.if simple? + (_.when (_.= _.none @temp) + fail_pm!) + (_.if (_.= _.none @temp) + fail_pm! + (..push! @temp)) + )))] + + [left_choice _.none] + [right_choice //runtime.unit] + ) + +(def (with_looping in_closure? g!once body!) + (-> Bit SVar (Statement Any) (Statement Any)) + (.if in_closure? + (_.while (_.bool true) + body! + {.#None}) + (all _.then + (_.set (list g!once) (_.bool true)) + (_.while g!once + (all _.then + (_.set (list g!once) (_.bool false)) + body!) + {.#Some _.continue})))) + +(def (alternation in_closure? g!once pre! post!) + (-> Bit SVar (Statement Any) (Statement Any) (Statement Any)) + (all _.then + (..with_looping in_closure? g!once + (all _.then + ..save! + pre!)) + ..restore! + post!)) + +(def (primitive_pattern_matching again pathP) + (-> (-> Path (Operation (Statement Any))) + (-> Path (Operation (Maybe (Statement Any))))) + (.case pathP + {/////synthesis.#Bit_Fork when thenP elseP} + (do [! ///////phase.monad] + [then! (again thenP) + else! (.case elseP + {.#Some elseP} + (again elseP) + + {.#None} + (in ..fail_pm!))] + (in {.#Some (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!))})) + + (^.with_template [<tag> <format>] + [{<tag> item} + (do [! ///////phase.monad] + [clauses (monad.each ! (function (_ [match then]) + (at ! each + (|>> [(_.= (|> match <format>) + ..peek)]) + (again then))) + {.#Item item})] + (in {.#Some (list#mix (function (_ [when then] else) + (_.if when then else)) + ..fail_pm! + clauses)}))]) + ([/////synthesis.#I64_Fork (<| //primitive.i64 .int)] + [/////synthesis.#F64_Fork (<| //primitive.f64)] + [/////synthesis.#Text_Fork (<| //primitive.text)]) + + _ + (at ///////phase.monad in {.#None}))) + +(def (pattern_matching' in_closure? statement expression archive) + (-> Bit Phase! Phase Archive Path (Operation (Statement Any))) + (function (again pathP) + (do [! ///////phase.monad] + [?output (primitive_pattern_matching again pathP)] + (.case ?output + {.#Some output} + (in output) + + {.#None} + (.case pathP + {/////synthesis.#Then bodyS} + (statement expression archive bodyS) + + {/////synthesis.#Pop} + (///////phase#in ..pop!) + + {/////synthesis.#Bind register} + (///////phase#in (_.set (list (..register register)) ..peek)) + + (^.with_template [<complex> <simple> <choice>] + [(<complex> idx) + (///////phase#in (<choice> false idx)) + + (<simple> idx nextP) + (|> nextP + again + (///////phase#each (_.then (<choice> true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (/////synthesis.member/left 0) + (///////phase#in (|> ..peek (_.item (_.int +0)) ..push!)) + + (^.with_template [<pm> <getter>] + [(<pm> lefts) + (///////phase#in (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple::left] + [/////synthesis.member/right //runtime.tuple::right]) + + (/////synthesis.!bind_top register thenP) + (do ! + [then! (again thenP)] + (///////phase#in (all _.then + (_.set (list (..register register)) ..peek_and_pop) + then!))) + + (/////synthesis.!multi_pop nextP) + (.let [[extra_pops nextP'] (case.count_pops nextP)] + (do ! + [next! (again nextP')] + (///////phase#in (all _.then + (..multi_pop! (n.+ 2 extra_pops)) + next!)))) + + (/////synthesis.path/seq preP postP) + (do ! + [pre! (again preP) + post! (again postP)] + (in (_.then pre! post!))) + + (/////synthesis.path/alt preP postP) + (do ! + [pre! (again preP) + post! (again postP) + g!once (..symbol "once")] + (in (..alternation in_closure? g!once pre! post!))) + + _ + (undefined)))))) + +(def (pattern_matching in_closure? statement expression archive pathP) + (-> Bit Phase! Phase Archive Path (Operation (Statement Any))) + (do ///////phase.monad + [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP) + g!once (..symbol "once")] + (in (all _.then + (..with_looping in_closure? g!once + pattern_matching!) + (_.raise (_.Exception/1 (_.string case.pattern_matching_error))))))) + +(def .public dependencies + (-> Path (List SVar)) + (|>> case.storage + (the case.#dependencies) + set.list + (list#each (function (_ variable) + (.case variable + {///////variable.#Local register} + (..register register) + + {///////variable.#Foreign register} + (..capture register)))))) + +(def .public (case! in_closure? statement expression archive [valueS pathP]) + (-> Bit (Generator! [Synthesis Path])) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching in_closure? statement expression archive pathP)] + (in (all _.then + (_.set (list @cursor) (_.list (list stack_init))) + (_.set (list @savepoint) (_.list (list))) + pattern_matching! + )))) + +(def .public (case statement expression archive [valueS pathP]) + (-> Phase! (Generator [Synthesis Path])) + (do ///////phase.monad + [dependencies (cache.path_dependencies archive pathP) + [[case_module case_artifact] pattern_matching!] (/////generation.with_new_context + archive + dependencies + (case! true statement expression archive [valueS pathP])) + .let [@case (_.var (///reference.artifact [case_module case_artifact])) + @dependencies+ (..dependencies (/////synthesis.path/seq (/////synthesis.path/then valueS) + pathP)) + declaration (_.def @case @dependencies+ + pattern_matching!)] + _ (/////generation.execute! declaration) + _ (/////generation.save! case_artifact {.#None} declaration)] + (in (_.apply @dependencies+ @case)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/function.lux new file mode 100644 index 000000000..1d1021d11 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/function.lux @@ -0,0 +1,117 @@ +(.require + [library + [lux (.except function) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [meta + [target + ["_" python (.only SVar Expression Statement)]]]]] + ["[0]" // + [runtime (.only Operation Phase Generator Phase! Generator!)] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["/[1]" // + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Environment Abstraction Reification Analysis)] + [synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + [arity (.only Arity)] + ["[1][0]" phase] + [reference + [variable (.only Register Variable)]] + [meta + [archive (.only Archive) + ["[0]" artifact]] + ["[0]" cache + [dependency + ["[1]" artifact]]]]]]]]) + +(def .public (apply expression archive [functionS argsS+]) + (Generator (Reification Synthesis)) + (do [! ///////phase.monad] + [functionO (expression archive functionS) + argsO+ (monad.each ! (expression archive) argsS+)] + (in (_.apply argsO+ functionO)))) + +(def .public capture + (-> Register SVar) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def (with_closure function_id @function inits function_definition) + (-> artifact.ID SVar (List (Expression Any)) (Statement Any) (Operation (Expression Any))) + (case inits + {.#End} + (do ///////phase.monad + [_ (/////generation.execute! function_definition) + _ (/////generation.save! function_id {.#None} function_definition)] + (in @function)) + + _ + (do [! ///////phase.monad] + [.let [declaration (_.def @function + (|> (list.enumeration inits) + (list#each (|>> product.left ..capture))) + (all _.then + function_definition + (_.return @function)))] + _ (/////generation.execute! declaration) + _ (/////generation.save! function_id {.#None} declaration)] + (in (_.apply inits @function))))) + +(def input + (|>> ++ //case.register)) + +(def .public (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do [! ///////phase.monad] + [dependencies (cache.dependencies archive bodyS) + [[function_module function_artifact] body!] (/////generation.with_new_context archive dependencies + (/////generation.with_anchor 1 + (statement expression archive bodyS))) + environment (monad.each ! (expression archive) environment) + .let [@curried (_.var "curried") + arityO (|> arity .int _.int) + @num_args (_.var "num_args") + @self (_.var (///reference.artifact [function_module function_artifact])) + apply_poly (.function (_ args func) + (_.apply (list (_.splat_poly args)) func)) + initialize_self! (_.set (list (//case.register 0)) @self) + initialize! (list#mix (.function (_ post pre!) + (all _.then + pre! + (_.set (list (..input post)) (_.item (|> post .int _.int) @curried)))) + initialize_self! + (list.indices arity))]] + (with_closure function_artifact @self environment + (_.def @self (list (_.poly @curried)) + (all _.then + (_.set (list @num_args) (_.len/1 @curried)) + (<| (_.if (|> @num_args (_.= arityO)) + (<| (_.then initialize!) + //loop.set_scope + body!)) + (_.if (|> @num_args (_.> arityO)) + (let [arity_inputs (_.slice (_.int +0) arityO @curried) + extra_inputs (_.slice arityO @num_args @curried)] + (_.return (|> @self + (apply_poly arity_inputs) + (apply_poly extra_inputs))))) + ... (|> @num_args (_.< arityO)) + (let [@next (_.var "next") + @missing (_.var "missing")] + (all _.then + (_.def @next (list (_.poly @missing)) + (_.return (|> @self (apply_poly (|> @curried (_.+ @missing)))))) + (_.return @next) + ))) + ))) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/loop.lux new file mode 100644 index 000000000..d767eeeeb --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/loop.lux @@ -0,0 +1,127 @@ +(.require + [library + [lux (.except Scope) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set]]] + [math + [number + ["n" nat]]] + [meta + [target + ["_" python (.only Expression SVar Statement)]]]]] + ["[0]" // + [runtime (.only Operation Phase Generator Phase! Generator!)] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + [synthesis + ["[0]" case]] + ["/[1]" // + ["[0]" synthesis (.only Scope Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + ["[1][0]" phase] + [meta + ["[0]" cache + [dependency + ["[1]" artifact]]]] + [reference + ["[1][0]" variable (.only Register)]]]]]]]) + +(def (setup offset bindings body) + (-> Register (List (Expression Any)) (Statement Any) (Statement Any)) + (let [variables (|> bindings + list.enumeration + (list#each (|>> product.left (n.+ offset) //case.register)))] + (all _.then + (_.set variables (_.multi bindings)) + body))) + +(def .public (set_scope body!) + (-> (Statement Any) (Statement Any)) + (_.while (_.bool true) + body! + {.#None})) + +(def .public (scope! statement expression archive [start initsS+ bodyS]) + (Generator! (Scope Synthesis)) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (statement expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [initsO+ (monad.each ! (expression archive) initsS+) + body! (/////generation.with_anchor start + (statement expression archive bodyS))] + (in (<| (..setup start initsO+) + ..set_scope + body!))))) + +(def .public (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [dependencies (cache.dependencies archive bodyS) + initsO+ (monad.each ! (expression archive) initsS+) + [[loop_module loop_artifact] body!] (/////generation.with_new_context archive dependencies + (/////generation.with_anchor start + (statement expression archive bodyS))) + .let [@loop (_.var (///reference.artifact [loop_module loop_artifact])) + locals (|> initsS+ + list.enumeration + (list#each (|>> product.left (n.+ start) //case.register))) + actual_loop (<| (_.def @loop locals) + ..set_scope + body!) + [declaration instantiation] (is [(Statement Any) (Expression Any)] + (case (|> (synthesis.path/then bodyS) + //case.dependencies + (set.of_list _.hash) + (set.difference (set.of_list _.hash locals)) + set.list) + {.#End} + [actual_loop + @loop] + + foreigns + [(_.def @loop foreigns + (all _.then + actual_loop + (_.return @loop) + )) + (_.apply foreigns @loop)]))] + _ (/////generation.execute! declaration) + _ (/////generation.save! loop_artifact {.#None} declaration)] + (in (_.apply initsO+ instantiation))))) + +(def .public (again! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do [! ///////phase.monad] + [offset /////generation.anchor + @temp (//case.symbol "lux_again_values") + argsO+ (monad.each ! (expression archive) argsS+) + .let [re_binds (|> argsO+ + list.enumeration + (list#each (function (_ [idx _]) + (_.item (_.int (.int idx)) @temp))))]] + (in (all _.then + (_.set (list @temp) (_.list argsO+)) + (..setup offset re_binds + _.continue))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/primitive.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/primitive.lux new file mode 100644 index 000000000..b50c2c965 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/primitive.lux @@ -0,0 +1,19 @@ +(.require + [library + [lux (.except i64) + [meta + [target + ["_" python (.only Expression)]]]]] + ["[0]" // + ["[1][0]" runtime]]) + +(with_template [<type> <name> <implementation>] + [(def .public <name> + (-> <type> (Expression Any)) + <implementation>)] + + [Bit bit _.bool] + [(I64 Any) i64 (|>> .int _.int //runtime.i64::64)] + [Frac f64 _.float] + [Text text _.unicode] + ) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/reference.lux new file mode 100644 index 000000000..9b105605e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/reference.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [meta + [target + ["_" python (.only Expression)]]]]] + [/// + [reference (.only System)]]) + +(def .public system + (System (Expression Any)) + (implementation + (def constant' _.var) + (def variable' _.var))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/runtime.lux new file mode 100644 index 000000000..d045b7d8e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/runtime.lux @@ -0,0 +1,486 @@ +(.require + [library + [lux (.except ++ left right) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" sequence]]] + [math + [number (.only hex) + ["f" frac] + ["[0]" i64]]] + ["[0]" meta (.only) + ["[0]" version] + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)]] + ["@" target (.only) + ["_" python (.only Expression SVar Computation Literal Statement)]]]]] + ["[0]" /// + ["[1][0]" reference] + ["//[1]" /// + ["[1][0]" synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// (.only) + ["[1][0]" phase] + [reference + [variable (.only Register)]] + [meta + [archive (.only Output Archive) + ["[0]" registry (.only Registry)] + ["[0]" unit]]]]]]) + +(with_template [<name> <base>] + [(type .public <name> + (<base> Register (Expression Any) (Statement Any)))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type .public Phase! + (-> Phase Archive Synthesis (Operation (Statement Any)))) + +(type .public (Generator! i) + (-> Phase! Phase Archive i (Operation (Statement Any)))) + +(type .public (Generator i) + (-> Phase Archive i (Operation (Expression Any)))) + +(def prefix + "LuxRuntime") + +(def .public unit + (_.unicode /////synthesis.unit)) + +(def (flag value) + (-> Bit Literal) + (if value + ..unit + _.none)) + +(def (variant' tag last? value) + (-> (Expression Any) (Expression Any) (Expression Any) Literal) + (_.tuple (list tag last? value))) + +(def .public (variant tag last? value) + (-> Nat Bit (Expression Any) Literal) + (variant' (_.int (.int tag)) + (flag last?) + value)) + +(def .public left + (-> (Expression Any) Literal) + (..variant 0 #0)) + +(def .public right + (-> (Expression Any) Literal) + (..variant 0 #1)) + +(def .public none + Literal + (..left ..unit)) + +(def .public some + (-> (Expression Any) Literal) + ..right) + +(def (runtime_name name) + (-> Text SVar) + (let [symbol (format ..prefix + "_" (%.nat version.latest) + "_" (%.nat (text#hash name)))] + (_.var symbol))) + +(def (feature name definition) + (-> SVar (-> SVar (Statement Any)) (Statement Any)) + (definition name)) + +(def .public with_vars + (syntax (_ [vars (<code>.tuple (<>.some <code>.local)) + body <code>.any]) + (do [! meta.monad] + [ids (monad.all ! (list.repeated (list.size vars) meta.seed))] + (in (list (` (let [(,* (|> vars + (list.zipped_2 ids) + (list#each (function (_ [id var]) + (list (code.local var) + (` (_.var (, (code.text (format "v" (%.nat id))))))))) + list.together))] + (, body)))))))) + +(def runtime + (syntax (_ [declaration (<>.or <code>.local + (<code>.form (<>.and <code>.local + (<>.some <code>.local)))) + code <code>.any]) + (case declaration + {.#Left name} + (macro.with_symbols [g!_] + (let [nameC (code.local name) + code_nameC (code.local (format "@" name)) + runtime_nameC (` (runtime_name (, (code.text name))))] + (in (list (` (def .public (, nameC) SVar (, runtime_nameC))) + (` (def (, code_nameC) + (Statement Any) + (..feature (, runtime_nameC) + (function ((, g!_) (, g!_)) + (_.set (list (, g!_)) (, code)))))))))) + + {.#Right [name inputs]} + (macro.with_symbols [g!_] + (let [nameC (code.local name) + code_nameC (code.local (format "@" name)) + runtime_nameC (` (runtime_name (, (code.text name)))) + inputsC (list#each code.local inputs) + inputs_typesC (list#each (function.constant (` (_.Expression Any))) + inputs)] + (in (list (` (def .public ((, nameC) (,* inputsC)) + (-> (,* inputs_typesC) (Computation Any)) + (_.apply (list (,* inputsC)) (, runtime_nameC)))) + (` (def (, code_nameC) + (Statement Any) + (..feature (, runtime_nameC) + (function ((, g!_) (, g!_)) + (..with_vars [(,* inputsC)] + (_.def (, g!_) (list (,* inputsC)) + (, code)))))))))))))) + +(runtime + (lux::try op) + (with_vars [exception] + (_.try (_.return (..right (_.apply (list ..unit) op))) + (list [(list "Exception") exception + (_.return (..left (_.str/1 exception)))])))) + +(runtime + (lux::program_args program_args) + (with_vars [inputs value] + (all _.then + (_.set (list inputs) ..none) + (<| (_.for_in value (_.apply (list program_args) (_.var "reversed"))) + (_.set (list inputs) + (..some (_.list (list value inputs))))) + (_.return inputs)))) + +(runtime + (lux::exec code globals) + (all _.then + (_.exec {.#Some globals} code) + (_.return ..unit))) + +(def runtime//lux + (Statement Any) + (all _.then + @lux::try + @lux::program_args + @lux::exec + )) + +(runtime + (io::log! message) + (all _.then + (_.print message) + (|> (_.__import__/1 (_.unicode "sys")) + (_.the "stdout") + (_.do "flush" (list)) + _.statement) + (_.return ..unit))) + +(runtime + (io::throw! message) + (_.raise (_.Exception/1 message))) + +(def runtime//io + (Statement Any) + (all _.then + @io::log! + @io::throw! + )) + +(def last_index + (|>> _.len/1 (_.- (_.int +1)))) + +(with_expansions [<recur> (these (all _.then + (_.set (list lefts) (_.- last_index_right lefts)) + (_.set (list tuple) (_.item last_index_right tuple))))] + (runtime + (tuple::left lefts tuple) + (with_vars [last_index_right] + (_.while (_.bool true) + (all _.then + (_.set (list last_index_right) (..last_index tuple)) + (_.if (_.> lefts last_index_right) + ... No need for recursion + (_.return (_.item lefts tuple)) + ... Needs recursion + <recur>)) + {.#None}))) + + (runtime + (tuple::right lefts tuple) + (with_vars [last_index_right right_index] + (_.while (_.bool true) + (all _.then + (_.set (list last_index_right) (..last_index tuple)) + (_.set (list right_index) (_.+ (_.int +1) lefts)) + (<| (_.if (_.= last_index_right right_index) + (_.return (_.item right_index tuple))) + (_.if (_.> last_index_right right_index) + ... Needs recursion. + <recur>) + (_.return (_.slice_from right_index tuple)))) + {.#None})))) + +(runtime + (sum::get sum expected::right? expected::lefts) + (let [mismatch! (_.return _.none) + actual::lefts (_.item (_.int +0) sum) + actual::right? (_.item (_.int +1) sum) + actual::value (_.item (_.int +2) sum) + recur! (all _.then + (_.set (list expected::lefts) (|> expected::lefts + (_.- actual::lefts) + (_.- (_.int +1)))) + (_.set (list sum) actual::value))] + (_.while (_.bool true) + (<| (_.if (_.= expected::lefts actual::lefts) + (_.if (_.= expected::right? actual::right?) + (_.return actual::value) + mismatch!)) + (_.if (_.< expected::lefts actual::lefts) + (_.if (_.= ..unit actual::right?) + recur! + mismatch!)) + (_.if (_.= ..unit expected::right?) + (_.return (variant' (|> actual::lefts + (_.- expected::lefts) + (_.- (_.int +1))) + actual::right? + actual::value))) + mismatch!) + {.#None}))) + +(def runtime//adt + (Statement Any) + (all _.then + @tuple::left + @tuple::right + @sum::get + )) + +(def i64::+limit (_.manual "+0x7FFFFFFFFFFFFFFF")) +(def i64::-limit (_.manual "-0x8000000000000000")) +(def i64::+iteration (_.manual "+0x10000000000000000")) +(def i64::-iteration (_.manual "-0x10000000000000000")) +(def i64::+cap (_.manual "+0x8000000000000000")) +(def i64::-cap (_.manual "-0x8000000000000001")) + +(runtime + (i64::64 input) + (with_vars [temp] + (`` (<| (,, (with_template [<scenario> <iteration> <cap> <entrance>] + [(_.if (|> input <scenario>) + (all _.then + (_.set (list temp) (_.% <iteration> input)) + (_.return (_.? (|> temp <scenario>) + (|> temp (_.- <cap>) (_.+ <entrance>)) + temp))))] + + [(_.> ..i64::+limit) ..i64::+iteration ..i64::+cap ..i64::-limit] + [(_.< ..i64::-limit) ..i64::-iteration ..i64::-cap ..i64::+limit] + )) + (_.return (for @.python input + ... This +- is only necessary to guarantee that values within the limits are always longs in Python 2 + (|> input (_.+ ..i64::+limit) (_.- ..i64::+limit)))))))) + +(def as_nat + (_.% ..i64::+iteration)) + +(runtime + (i64::left_shifted param subject) + (_.return (|> subject + (_.bit_shl (_.% (_.int +64) param)) + ..i64::64))) + +(runtime + (i64::right_shifted param subject) + (all _.then + (_.set (list param) (_.% (_.int +64) param)) + (_.return (_.? (_.= (_.int +0) param) + subject + (|> subject + ..as_nat + (_.bit_shr param)))))) + +(runtime + (i64#/ param subject) + (with_vars [floored] + (all _.then + (_.set (list floored) (_.// param subject)) + (_.return (let [potentially_floored? (_.< (_.int +0) floored) + inexact? (|> subject + (_.% param) + (_.= (_.int +0)) + _.not)] + (<| (_.? (_.and potentially_floored? + inexact?) + (_.+ (_.int +1) floored)) + (_.? (_.= (_.manual "+9223372036854775808") + floored) + (_.manual "-9223372036854775808")) + floored)))))) + +(runtime + (i64::remainder param subject) + (_.return (_.- (|> subject (..i64#/ param) (_.* param)) + subject))) + +(with_template [<runtime> <host>] + [(runtime + (<runtime> left right) + (_.return (..i64::64 (<host> (..as_nat left) (..as_nat right)))))] + + [i64::and _.bit_and] + [i64::or _.bit_or] + [i64::xor _.bit_xor] + ) + +(def python_version + (Expression Any) + (|> (_.__import__/1 (_.unicode "sys")) + (_.the "version_info") + (_.the "major"))) + +(runtime + (i64::char value) + (_.return (_.? (_.= (_.int +3) ..python_version) + (_.chr/1 value) + (_.unichr/1 value)))) + +(def runtime//i64 + (Statement Any) + (all _.then + @i64::64 + @i64::left_shifted + @i64::right_shifted + @i64#/ + @i64::remainder + @i64::and + @i64::or + @i64::xor + @i64::char + )) + +(runtime + (f64::/ parameter subject) + (_.return (_.? (_.= (_.float +0.0) parameter) + (<| (_.? (_.> (_.float +0.0) subject) + (_.float f.positive_infinity)) + (_.? (_.< (_.float +0.0) subject) + (_.float f.negative_infinity)) + (_.float f.not_a_number)) + (_./ parameter subject)))) + +(runtime + (f64::decode input) + (with_vars [ex] + (_.try (_.return (..some (_.float/1 input))) + (list [(list "Exception") ex + (_.return ..none)])))) + +(def runtime//f64 + (Statement Any) + (all _.then + @f64::/ + @f64::decode + )) + +(runtime + (text::index start param subject) + (with_vars [idx] + (all _.then + (_.set (list idx) (|> subject (_.do "find" (list param start)))) + (_.return (_.? (_.= (_.int -1) idx) + ..none + (..some (..i64::64 idx))))))) + +(def ++ + (|>> (_.+ (_.int +1)))) + +(def (within? top value) + (-> (Expression Any) (Expression Any) (Computation Any)) + (_.and (|> value (_.>= (_.int +0))) + (|> value (_.< top)))) + +(runtime + (text::clip @offset @length @text) + (_.return (|> @text (_.slice @offset (_.+ @offset @length))))) + +(runtime + (text::char idx text) + (_.if (|> idx (within? (_.len/1 text))) + (_.return (|> text (_.slice idx (..++ idx)) _.ord/1 ..i64::64)) + (_.raise (_.Exception/1 (_.unicode "[Lux Error] Cannot get char from text."))))) + +(def runtime//text + (Statement Any) + (all _.then + @text::index + @text::clip + @text::char + )) + +(runtime + (array::write idx value array) + (all _.then + (_.set (list (_.item idx array)) value) + (_.return array))) + +(def runtime//array + (Statement Any) + (all _.then + @array::write + )) + +(def full_runtime + (Statement Any) + (all _.then + runtime//lux + runtime//io + runtime//adt + runtime//i64 + runtime//f64 + runtime//text + runtime//array + )) + +(def module_id + 0) + +(def .public generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..full_runtime) + _ (/////generation.save! ..module_id {.#None} ..full_runtime)] + (in [(|> registry.empty + (registry.resource true unit.none) + product.right) + (sequence.sequence [..module_id + {.#None} + (|> ..full_runtime + _.code + (at utf8.codec encoded))])]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/structure.lux new file mode 100644 index 000000000..428320d23 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/python/structure.lux @@ -0,0 +1,36 @@ +(.require + [library + [lux (.except Variant Tuple) + [abstract + ["[0]" monad (.only do)]] + [meta + [target + ["_" python (.only Expression)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" primitive] + ["///[1]" //// + [analysis + [complex (.only Variant Tuple)]] + ["[1][0]" synthesis (.only Synthesis)] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)]]]]) + +(def .public (tuple generate archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + {.#End} + (///////phase#in (//primitive.text /////synthesis.unit)) + + {.#Item singletonS {.#End}} + (generate archive singletonS) + + _ + (|> elemsS+ + (monad.each ///////phase.monad (generate archive)) + (///////phase#each _.list)))) + +(def .public (variant generate archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (///////phase#each (//runtime.variant lefts right?) + (generate archive valueS))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r.lux new file mode 100644 index 000000000..7741ccce0 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r.lux @@ -0,0 +1,62 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [meta + [macro + ["^" pattern]] + [target + ["_" r]]]]] + ["[0]" / + [runtime (.only Phase)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["[1][0]" function] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" extension] + ["/[1]" // + [analysis (.only)] + ["[1][0]" synthesis] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference (.only) + [variable (.only)]]]]]]]) + +(def .public (generate archive synthesis) + Phase + (case synthesis + (^.with_template [<tag> <generator>] + [(<tag> value) + (//////phase#in (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + {////synthesis.#Reference value} + (//reference.reference /reference.system archive value) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/again /loop.again] + [////synthesis.function/abstraction /function.function]) + + {////synthesis.#Extension extension} + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/case.lux new file mode 100644 index 000000000..cc47ed212 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/case.lux @@ -0,0 +1,242 @@ +(.require + [library + [lux (.except case let if) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set]]] + [math + [number + ["i" int]]] + [meta + [macro + ["^" pattern] + ["[0]" template]] + [target + ["_" r (.only Expression SVar)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" reference] + ["[1][0]" primitive] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" synthesis + ["[1]/[0]" case]] + ["/[1]" // + ["[1][0]" synthesis (.only Member Synthesis Path)] + ["[1][0]" generation] + ["//[1]" /// + [reference + ["[1][0]" variable (.only Register)]] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)]]]]]]]) + +(def .public register + (-> Register SVar) + (|>> (///reference.local //reference.system) as_expected)) + +(def .public capture + (-> Register SVar) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def .public (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + (in (_.block + (all _.then + (_.set! (..register register) valueO) + bodyO))))) + +(def .public (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (in (_.if testO thenO elseO)))) + +(def .public (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (in (list#mix (function (_ side source) + (.let [method (.case side + (^.with_template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([.#Left //runtime.tuple::left] + [.#Right //runtime.tuple::right]))] + (method source))) + valueO + (list.reversed pathP))))) + +(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 top + _.length) + +(def next + (|>> _.length (_.+ (_.int +1)))) + +(def (push! value var) + (-> Expression SVar Expression) + (_.set_item! (next var) value var)) + +(def (pop! var) + (-> SVar Expression) + (_.set_item! (top var) _.null var)) + +(def (push_cursor! value) + (-> Expression Expression) + (push! value $cursor)) + +(def save_cursor! + Expression + (push! (_.slice (_.float +1.0) (_.length $cursor) $cursor) + $savepoint)) + +(def restore_cursor! + Expression + (_.set! $cursor (_.item (top $savepoint) $savepoint))) + +(def peek + Expression + (|> $cursor (_.item (top $cursor)))) + +(def pop_cursor! + Expression + (pop! $cursor)) + +(def error + (_.string (template.with_locals [error] + (template.text [error])))) + +(def fail! + (_.stop ..error)) + +(def (catch handler) + (-> Expression Expression) + (_.function (list $alt_error) + (_.if (|> $alt_error (_.= ..error)) + handler + (_.stop $alt_error)))) + +(def (pattern_matching' expression archive) + (Generator Path) + (function (again pathP) + (.case pathP + {/////synthesis.#Then bodyS} + (expression archive bodyS) + + {/////synthesis.#Pop} + (///////phase#in ..pop_cursor!) + + {/////synthesis.#Bind register} + (///////phase#in (_.set! (..register register) ..peek)) + + {/////synthesis.#Bit_Fork when thenP elseP} + (do [! ///////phase.monad] + [then! (again thenP) + else! (.case elseP + {.#Some elseP} + (again elseP) + + {.#None} + (in ..fail!))] + (in (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^.with_template [<tag> <format> <=>] + [{<tag> item} + (do [! ///////phase.monad] + [clauses (monad.each ! (function (_ [match then]) + (do ! + [then! (again then)] + (in [(<=> (|> match <format>) + ..peek) + then!]))) + {.#Item item})] + (in (list#mix (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)))]) + ([/////synthesis.#I64_Fork //primitive.i64 //runtime.i64::=] + [/////synthesis.#F64_Fork //primitive.f64 _.=] + [/////synthesis.#Text_Fork //primitive.text _.=]) + + (^.with_template [<pm> <flag> <prep>] + [(<pm> idx) + (///////phase#in (all _.then + (_.set! $temp (|> idx <prep> .int _.int (//runtime.sum::get ..peek (//runtime.flag <flag>)))) + (_.if (_.= _.null $temp) + ..fail! + (..push_cursor! $temp))))]) + ([/////synthesis.side/left false (<|)] + [/////synthesis.side/right true ++]) + + (/////synthesis.member/left 0) + (///////phase#in (_.item (_.int +1) ..peek)) + + (^.with_template [<pm> <getter>] + [(<pm> lefts) + (///////phase#in (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))]) + ([/////synthesis.member/left //runtime.tuple::left] + [/////synthesis.member/right //runtime.tuple::right]) + + (/////synthesis.path/seq leftP rightP) + (do ///////phase.monad + [leftO (again leftP) + rightO (again rightP)] + (in (all _.then + leftO + rightO))) + + (/////synthesis.path/alt leftP rightP) + (do [! ///////phase.monad] + [leftO (again leftP) + rightO (again rightP)] + (in (_.try (all _.then + ..save_cursor! + leftO) + {.#None} + {.#Some (..catch (all _.then + ..restore_cursor! + rightO))} + {.#None}))) + ))) + +(def (pattern_matching expression archive pathP) + (Generator Path) + (do ///////phase.monad + [pattern_matching! (pattern_matching' expression archive pathP)] + (in (_.try pattern_matching! + {.#None} + {.#Some (..catch (_.stop (_.string "Invalid expression for pattern-matching.")))} + {.#None})))) + +(def .public (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do [! ///////phase.monad] + [valueO (expression archive valueS)] + (<| (at ! each (|>> (all _.then + (_.set! $cursor (_.list (list valueO))) + (_.set! $savepoint (_.list (list)))) + _.block)) + (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/function.lux new file mode 100644 index 000000000..80f8ac48c --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/function.lux @@ -0,0 +1,118 @@ +(.require + [library + [lux (.except function) + [abstract + ["[0]" monad (.only do)]] + [control + pipe] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [meta + [target + ["_" r (.only Expression SVar)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" reference] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Variant Tuple Abstraction Application Analysis)] + [synthesis (.only Synthesis)] + ["[1][0]" generation (.only Context)] + ["//[1]" /// + [arity (.only Arity)] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference + [variable (.only Register Variable)]] + [meta + [archive + ["[0]" artifact]]]]]]]) + +(def .public (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do [! ///////phase.monad] + [functionO (expression archive functionS) + argsO+ (monad.each ! (expression archive) argsS+)] + (in (_.apply argsO+ functionO)))) + +(def (with_closure function_id $function inits function_definition) + (-> artifact.ID SVar (List Expression) Expression (Operation Expression)) + (case inits + {.#End} + (do ///////phase.monad + [_ (/////generation.execute! function_definition) + _ (/////generation.save! (%.nat function_id) + function_definition)] + (in $function)) + + _ + (do ///////phase.monad + [.let [closure_definition (_.set! $function + (_.function (|> inits + list.size + list.indices + (list#each //case.capture)) + (all _.then + function_definition + $function)))] + _ (/////generation.execute! closure_definition) + _ (/////generation.save! (%.nat function_id) closure_definition)] + (in (_.apply inits $function))))) + +(def $curried (_.var "curried")) +(def $missing (_.var "missing")) + +(def (input_declaration register) + (-> Register Expression) + (_.set! (|> register ++ //case.register) + (|> $curried (_.item (|> register ++ .int _.int))))) + +(def .public (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do [! ///////phase.monad] + [[[function_module function_artifact] bodyO] (/////generation.with_new_context archive + (do ! + [$self (at ! each (|>> ///reference.artifact _.var) + (/////generation.context archive))] + (/////generation.with_anchor $self + (expression archive bodyS)))) + closureO+ (monad.each ! (expression archive) environment) + .let [arityO (|> arity .int _.int) + $num_args (_.var "num_args") + $self (_.var (///reference.artifact [function_module function_artifact])) + apply_poly (.function (_ args func) + (_.apply (list func args) (_.var "do.call")))]] + (with_closure function_artifact $self closureO+ + (_.set! $self (_.function (list _.var_args) + (all _.then + (_.set! $curried (_.list (list _.var_args))) + (_.set! $num_args (_.length $curried)) + (_.cond (list [(|> $num_args (_.= arityO)) + (all _.then + (_.set! (//case.register 0) $self) + (|> arity + list.indices + (list#each input_declaration) + (list#mix _.then bodyO)))] + [(|> $num_args (_.> arityO)) + (let [arity_args (_.slice (_.int +1) arityO $curried) + output_func_args (_.slice (|> arityO (_.+ (_.int +1))) + $num_args + $curried)] + (|> $self + (apply_poly arity_args) + (apply_poly output_func_args)))]) + ... (|> $num_args (_.< arityO)) + (let [$missing (_.var "missing")] + (_.function (list _.var_args) + (all _.then + (_.set! $missing (_.list (list _.var_args))) + (|> $self + (apply_poly (_.apply (list $curried $missing) + (_.var "append")))))))))))) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/loop.lux new file mode 100644 index 000000000..35477e3f7 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/loop.lux @@ -0,0 +1,66 @@ +(.require + [library + [lux (.except Scope) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" set (.only Set)]]] + [math + [number + ["n" nat]]] + [meta + [target + ["_" r]]]]] + ["[0]" // + [runtime (.only Operation Phase Generator)] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + [synthesis + ["[0]" case]] + ["/[1]" // + ["[0]" synthesis (.only Scope Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + ["[1][0]" phase] + [meta + [archive (.only Archive)]] + [reference + [variable (.only Register)]]]]]]]) + +(def .public (scope expression archive [offset initsS+ bodyS]) + (Generator (Scope Synthesis)) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [$scope (at ! each _.var (/////generation.symbol "loop_scope")) + initsO+ (monad.each ! (expression archive) initsS+) + bodyO (/////generation.with_anchor $scope + (expression archive bodyS))] + (in (_.block + (all _.then + (_.set! $scope + (_.function (|> initsS+ + list.size + list.indices + (list#each (|>> (n.+ offset) //case.register))) + bodyO)) + (_.apply initsO+ $scope))))))) + +(def .public (again expression archive argsS+) + (Generator (List Synthesis)) + (do [! ///////phase.monad] + [$scope /////generation.anchor + argsO+ (monad.each ! (expression archive) argsS+)] + (in (_.apply argsO+ $scope)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/primitive.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/primitive.lux new file mode 100644 index 000000000..ffd4625bb --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/primitive.lux @@ -0,0 +1,19 @@ +(.require + [library + [lux (.except i64) + [meta + [target + ["_" r (.only Expression)]]]]] + ["[0]" // + ["[1][0]" runtime]]) + +(with_template [<name> <type> <code>] + [(def .public <name> + (-> <type> Expression) + <code>)] + + [bit Bit _.bool] + [i64 (I64 Any) (|>> .int //runtime.i64)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/procedure/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/procedure/common.lux new file mode 100644 index 000000000..a64f95bc9 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/procedure/common.lux @@ -0,0 +1,291 @@ +(.require + lux + (lux (control [library + [monad (.only do)]] + ["ex" exception (.only exception)] + ["p" parser]) + (data ["e" error] + [text] + text/format + [number] + (coll [list "list/" Functor<List>] + (dictionary ["dict" unordered (.only Dict)]))) + [macro (.only with_symbols)] + (macro [code] + ["s" syntax (.only syntax)]) + [host]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [r (.only Expression)]))) + [///] + (/// ["[0]T" runtime] + ["[0]T" case] + ["[0]T" function] + ["[0]T" loop])) + +... [Types] +(type .public Translator + (-> ls.Synthesis (Meta Expression))) + +(type .public Proc + (-> Translator (List ls.Synthesis) (Meta Expression))) + +(type .public Bundle + (Dict Text Proc)) + +... [Utils] +(def .public (install name unnamed) + (-> Text (-> Text Proc) + (-> Bundle Bundle)) + (dict.has name (unnamed name))) + +(def .public (prefix prefix bundle) + (-> Text Bundle Bundle) + (|> bundle + dict.entries + (list/each (function (_ [key val]) [(format prefix " " key) val])) + (dict.from_list text.Hash<Text>))) + +... [Procedures] +... [[Lux]] +(def (lux//is [leftO rightO]) + Binary + (r.apply (list leftO rightO) + (r.global "identical"))) + +(def (lux//if [testO thenO elseO]) + Trinary + (caseT.translate_if testO thenO elseO)) + +(def (lux//try riskyO) + Unary + (runtimeT.lux//try riskyO)) + +(exception .public (Wrong_Syntax [message Text]) + message) + +(def .public (wrong_syntax procedure args) + (-> Text (List ls.Synthesis) Text) + (format "Procedure: " procedure "\n" + "Arguments: " (%code (code.tuple args)))) + +(def lux//loop + (-> Text Proc) + (function (_ proc_name) + (function (_ translate inputsS) + (case (s.result inputsS (all p.and s.nat (s.tuple (p.many s.any)) s.any)) + {e.#Success [offset initsS+ bodyS]} + (loopT.translate_loop translate offset initsS+ bodyS) + + {e.#Error error} + (&.throw Wrong_Syntax (wrong_syntax proc_name inputsS))) + ))) + +(def lux//again + (-> Text Proc) + (function (_ proc_name) + (function (_ translate inputsS) + (loopT.translate_again translate inputsS)))) + +(def lux_procs + Bundle + (|> (dict.empty text.Hash<Text>) + (install "is" (binary lux//is)) + (install "try" (unary lux//try)) + (install "if" (trinary lux//if)) + (install "loop" lux//loop) + (install "again" lux//again) + )) + +... [[Bits]] +(with_template [<name> <op>] + [(def (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [bit//and runtimeT.bit//and] + [bit//or runtimeT.bit//or] + [bit//xor runtimeT.bit//xor] + ) + +(with_template [<name> <op>] + [(def (<name> [subjectO paramO]) + Binary + (<op> (runtimeT.int64_low paramO) subjectO))] + + [bit//left_shifted runtimeT.bit//left_shifted] + [bit//arithmetic_right_shifted runtimeT.bit//arithmetic_right_shifted] + [bit//logical_right_shifted runtimeT.bit//logical_right_shifted] + ) + +(def bit_procs + Bundle + (<| (prefix "bit") + (|> (dict.empty text.Hash<Text>) + (install "and" (binary bit//and)) + (install "or" (binary bit//or)) + (install "xor" (binary bit//xor)) + (install "left-shift" (binary bit//left_shifted)) + (install "logical-right-shift" (binary bit//logical_right_shifted)) + (install "arithmetic-right-shift" (binary bit//arithmetic_right_shifted)) + ))) + +... [[Numbers]] +(host.import java/lang/Double + ("static" MIN_VALUE Double) + ("static" MAX_VALUE Double)) + +(with_template [<name> <const> <encode>] + [(def (<name> _) + Nullary + (<encode> <const>))] + + [frac//smallest Double::MIN_VALUE r.float] + [frac//min (f/* -1.0 Double::MAX_VALUE) r.float] + [frac//max Double::MAX_VALUE r.float] + ) + +(with_template [<name> <op>] + [(def (<name> [subjectO paramO]) + Binary + (|> subjectO (<op> paramO)))] + + [int//add runtimeT.int//+] + [int//sub runtimeT.int//-] + [int//mul runtimeT.int//*] + [int//div runtimeT.int///] + [int//rem runtimeT.int//%] + ) + +(with_template [<name> <op>] + [(def (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [frac//add r.+] + [frac//sub r.-] + [frac//mul r.*] + [frac//div r./] + [frac//rem r.%%] + [frac//= r.=] + [frac//< r.<] + + [text//= r.=] + [text//< r.<] + ) + +(with_template [<name> <cmp>] + [(def (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [int//= runtimeT.int//=] + [int//< runtimeT.int//<] + ) + +(def (apply1 func) + (-> Expression (-> Expression Expression)) + (function (_ value) + (r.apply (list value) func))) + +(def int//char (|>> runtimeT.int64_low (apply1 (r.global "intToUtf8")))) + +(def int_procs + Bundle + (<| (prefix "int") + (|> (dict.empty text.Hash<Text>) + (install "+" (binary int//add)) + (install "-" (binary int//sub)) + (install "*" (binary int//mul)) + (install "/" (binary int//div)) + (install "%" (binary int//rem)) + (install "=" (binary int//=)) + (install "<" (binary int//<)) + (install "to-frac" (unary runtimeT.int//float)) + (install "char" (unary int//char))))) + +(def (frac//encode value) + (-> Expression Expression) + (r.apply (list (r.string "%f") value) (r.global "sprintf"))) + +(def frac_procs + Bundle + (<| (prefix "frac") + (|> (dict.empty text.Hash<Text>) + (install "+" (binary frac//add)) + (install "-" (binary frac//sub)) + (install "*" (binary frac//mul)) + (install "/" (binary frac//div)) + (install "%" (binary frac//rem)) + (install "=" (binary frac//=)) + (install "<" (binary frac//<)) + (install "smallest" (nullary frac//smallest)) + (install "min" (nullary frac//min)) + (install "max" (nullary frac//max)) + (install "to-int" (unary (apply1 (r.global "as.integer")))) + (install "encode" (unary frac//encode)) + (install "decode" (unary runtimeT.frac//decode))))) + +... [[Text]] +(def (text//concat [subjectO paramO]) + Binary + (r.apply (list subjectO paramO) (r.global "paste0"))) + +(def (text//char [subjectO paramO]) + Binary + (runtimeT.text//char subjectO paramO)) + +(def (text//clip [subjectO paramO extraO]) + Trinary + (runtimeT.text//clip subjectO paramO extraO)) + +(def (text//index [textO partO startO]) + Trinary + (runtimeT.text//index textO partO startO)) + +(def text_procs + Bundle + (<| (prefix "text") + (|> (dict.empty text.Hash<Text>) + (install "=" (binary text//=)) + (install "<" (binary text//<)) + (install "concat" (binary text//concat)) + (install "index" (trinary text//index)) + (install "size" (unary (|>> (apply1 (r.global "nchar")) runtimeT.int//from_float))) + (install "char" (binary text//char)) + (install "clip" (trinary text//clip)) + ))) + +... [[IO]] +(def (io//exit input) + Unary + (r.apply_kw (list) + (list ["status" (runtimeT.int//float input)]) + (r.global "quit"))) + +(def (void code) + (-> Expression Expression) + (r.block (r.then code runtimeT.unit))) + +(def io_procs + Bundle + (<| (prefix "io") + (|> (dict.empty text.Hash<Text>) + (install "log" (unary (|>> r.print ..void))) + (install "error" (unary r.stop)) + (install "exit" (unary io//exit)) + (install "current-time" (nullary (function (_ _) + (runtimeT.io//current_time! runtimeT.unit))))))) + +... [Bundles] +(def .public procedures + Bundle + (<| (prefix "lux") + (|> lux_procs + (dict.composite bit_procs) + (dict.composite int_procs) + (dict.composite frac_procs) + (dict.composite text_procs) + (dict.composite io_procs) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/procedure/host.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/procedure/host.lux new file mode 100644 index 000000000..b5a3fcb3a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/procedure/host.lux @@ -0,0 +1,90 @@ +(.require + lux + (lux (control [library + [monad (.only do)]]) + (data [text] + text/format + (coll [list "list/" Functor<List>] + (dictionary ["dict" unordered (.only Dict)]))) + [macro "macro/" Monad<Meta>]) + (luxc ["&" lang] + (lang ["la" analysis] + ["ls" synthesis] + (host [ruby (.only Ruby Expression Statement)]))) + [///] + (/// ["[0]T" runtime]) + (// ["@" common])) + +... (with_template [<name> <lua>] +... [(def (<name> _) @.Nullary <lua>)] + +... [lua//nil "nil"] +... [lua//table "{}"] +... ) + +... (def (lua//global proc translate inputs) +... (-> Text @.Proc) +... (case inputs +... (list [_ {.#Text name}]) +... (do macro.Monad<Meta> +... [] +... (in name)) + +... _ +... (&.throw @.Wrong_Syntax (@.wrong_syntax proc inputs)))) + +... (def (lua//call proc translate inputs) +... (-> Text @.Proc) +... (case inputs +... (list.partial functionS argsS+) +... (do [@ macro.Monad<Meta>] +... [functionO (translate functionS) +... argsO+ (monad.each @ translate argsS+)] +... (in (lua.apply functionO argsO+))) + +... _ +... (&.throw @.Wrong_Syntax (@.wrong_syntax proc inputs)))) + +... (def lua_procs +... @.Bundle +... (|> (dict.empty text.Hash<Text>) +... (@.install "nil" (@.nullary lua//nil)) +... (@.install "table" (@.nullary lua//table)) +... (@.install "global" lua//global) +... (@.install "call" lua//call))) + +... (def (table//call proc translate inputs) +... (-> Text @.Proc) +... (case inputs +... (list.partial tableS [_ {.#Text field}] argsS+) +... (do [@ macro.Monad<Meta>] +... [tableO (translate tableS) +... argsO+ (monad.each @ translate argsS+)] +... (in (lua.method field tableO argsO+))) + +... _ +... (&.throw @.Wrong_Syntax (@.wrong_syntax proc inputs)))) + +... (def (table//get [fieldO tableO]) +... @.Binary +... (runtimeT.lua//get tableO fieldO)) + +... (def (table//set [fieldO valueO tableO]) +... @.Trinary +... (runtimeT.lua//set tableO fieldO valueO)) + +... (def table_procs +... @.Bundle +... (<| (@.prefix "table") +... (|> (dict.empty text.Hash<Text>) +... (@.install "call" table//call) +... (@.install "get" (@.binary table//get)) +... (@.install "set" (@.trinary table//set))))) + +(def .public procedures + @.Bundle + (<| (@.prefix "lua") + (dict.empty text.Hash<Text>) + ... (|> lua_procs + ... (dict.composite table_procs)) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/reference.lux new file mode 100644 index 000000000..b80350acf --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/reference.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [meta + [target + ["_" r (.only Expression)]]]]] + [/// + [reference (.only System)]]) + +(def .public system + (System Expression) + (implementation + (def constant _.var) + (def variable _.var))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/runtime.lux new file mode 100644 index 000000000..c23b725d5 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/runtime.lux @@ -0,0 +1,882 @@ +(.require + [library + [lux (.except Location ++ i64) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" sequence]]] + [math + [number (.only hex) + ["n" nat] + ["i" int (.use "[1]#[0]" interval)] + ["[0]" i64]]] + ["[0]" meta (.only) + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)]] + ["@" target (.only) + ["_" r (.only SVar Expression)]]]]] + ["[0]" /// + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Variant)] + ["[1][0]" synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// (.only) + ["[1][0]" phase] + [reference + [variable (.only Register)]] + [meta + [archive (.only Output Archive) + ["[0]" artifact (.only Registry)]]]]]]) + +(def module_id + 0) + +(with_template [<name> <base>] + [(type .public <name> + (<base> _.SVar _.Expression _.Expression))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type .public (Generator i) + (-> Phase Archive i (Operation Expression))) + +(def .public unit + Expression + (_.string /////synthesis.unit)) + +(def full_32 (hex "FFFFFFFF")) +(def half_32 (hex "7FFFFFFF")) +(def post_32 (hex "100000000")) + +(def (cap_32 input) + (-> Nat Int) + (cond (n.> full_32 input) + (|> input (i64.and full_32) cap_32) + + (n.> half_32 input) + (|> post_32 (n.- input) .int (i.* -1)) + + ... else + (.int input))) + +(def .public with_vars + (syntax (_ [vars (<code>.tuple (<>.some <code>.local)) + body <code>.any]) + (do [! meta.monad] + [ids (monad.all ! (list.repeated (list.size vars) meta.seed))] + (in (list (` (let [(,* (|> vars + (list.zipped_2 ids) + (list#each (function (_ [id var]) + (list (code.local var) + (` (_.var (, (code.text (format "v" (%.nat id))))))))) + list.together))] + (, body)))))))) + +(def runtime + (syntax (_ [declaration (<>.or <code>.local + (<code>.form (<>.and <code>.local + (<>.some <code>.local)))) + code <code>.any]) + (do meta.monad + [runtime_id meta.seed] + (macro.with_symbols [g!_] + (let [runtime (code.local (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (, (code.text (%.code runtime)))))] + (case declaration + {.#Left name} + (let [g!name (code.local name)] + (in (list (` (def .public (, g!name) + _.SVar + (, runtime_name))) + + (` (def (, (code.local (format "@" name))) + _.Expression + (_.set! (, runtime_name) (, code))))))) + + {.#Right [name inputs]} + (let [g!name (code.local name) + inputsC (list#each code.local inputs) + inputs_typesC (list#each (function.constant (` _.Expression)) + inputs)] + (in (list (` (def .public ((, g!name) (,* inputsC)) + (-> (,* inputs_typesC) _.Expression) + (_.apply (list (,* inputsC)) (, runtime_name)))) + + (` (def (, (code.local (format "@" name))) + _.Expression + (..with_vars [(,* inputsC)] + (_.set! (, runtime_name) + (_.function (list (,* inputsC)) + (, code))))))))))))))) + +(def .public variant_tag_field "luxVT") +(def .public variant_flag_field "luxVF") +(def .public variant_value_field "luxVV") + +(def .public (flag value) + (-> Bit Expression) + (if value + (_.string "") + _.null)) + +(runtime + (adt::variant tag last? value) + (_.named_list (list [..variant_tag_field (_.as::integer tag)] + [..variant_flag_field last?] + [..variant_value_field value]))) + +(def .public (variant tag last? value) + (-> Nat Bit Expression Expression) + (adt::variant (_.int (.int tag)) + (flag last?) + value)) + +(def .public none + Expression + (variant 0 #0 ..unit)) + +(def .public some + (-> Expression Expression) + (variant 1 #1)) + +(def .public left + (-> Expression Expression) + (variant 0 #0)) + +(def .public right + (-> Expression Expression) + (variant 1 #1)) + +(def high_shift (_.bit_shl (_.int +32))) + +(with_template [<name> <power>] + [(runtime + <name> (|> (_.as::integer (_.int +2)) (_.** (_.as::integer (_.int <power>)))))] + + [f2^32 +32] + [f2^63 +63] + ) + +(def (as_double value) + (-> Expression Expression) + (_.apply (list value) (_.var "as.double"))) + +(def .public i64_high_field "luxIH") +(def .public i64_low_field "luxIL") + +(runtime + (i64::unsigned_low input) + (with_vars [low] + (all _.then + (_.set! low (_.item (_.string ..i64_low_field) input)) + (_.if (_.< (_.int +0) low) + (_.+ f2^32 low) + low)))) + +(runtime + (i64::float input) + (let [high (|> input + (_.item (_.string ..i64_high_field)) + high_shift) + low (|> input + i64::unsigned_low)] + (|> high (_.+ low) as_double))) + +(runtime + (i64::new high low) + (_.named_list (list [..i64_high_field (_.as::integer high)] + [..i64_low_field (_.as::integer low)]))) + +(def high_32 + (-> Nat Nat) + (i64.right_shifted 32)) + +(def low_32 + (-> Nat Nat) + (|>> (i64.and (hex "FFFFFFFF")))) + +(def .public (i64 value) + (-> Int Expression) + (let [value (.nat value)] + (i64::new (|> value ..high_32 ..cap_32 _.int) + (|> value ..low_32 ..cap_32 _.int)))) + +(def .public (lux_i64 high low) + (-> Int Int Int) + (|> high + (i64.left_shifted 32) + (i64.or low))) + +(with_template [<name> <value>] + [(runtime + <name> + (..i64 <value>))] + + [i64::zero +0] + [i64::one +1] + [i64::min i#bottom] + [i64::max i#top] + ) + +(def .public i64_high (_.item (_.string ..i64_high_field))) +(def .public i64_low (_.item (_.string ..i64_low_field))) + +(runtime + (i64::not input) + (i64::new (|> input i64_high _.bit_not) + (|> input i64_low _.bit_not))) + +(runtime + (i64::+ param subject) + (with_vars [sH sL pH pL + x00 x16 x32 x48] + (all _.then + (_.set! sH (|> subject i64_high)) + (_.set! sL (|> subject i64_low)) + (_.set! pH (|> param i64_high)) + (_.set! pL (|> param i64_low)) + (let [bits16 (_.manual "0xFFFF") + move_top_16 (_.bit_shl (_.int +16)) + top_16 (_.bit_ushr (_.int +16)) + bottom_16 (_.bit_and bits16) + split_16 (function (_ source) + [(|> source top_16) + (|> source bottom_16)]) + split_int (function (_ high low) + [(split_16 high) + (split_16 low)]) + + [[s48 s32] [s16 s00]] (split_int sH sL) + [[p48 p32] [p16 p00]] (split_int pH pL) + new_half (function (_ top bottom) + (|> top bottom_16 move_top_16 + (_.bit_or (bottom_16 bottom))))] + (all _.then + (_.set! x00 (|> s00 (_.+ p00))) + (_.set! x16 (|> x00 top_16 (_.+ s16) (_.+ p16))) + (_.set! x32 (|> x16 top_16 (_.+ s32) (_.+ p32))) + (_.set! x48 (|> x32 top_16 (_.+ s48) (_.+ p48))) + (i64::new (new_half x48 x32) + (new_half x16 x00))))))) + +(runtime + (i64::= reference sample) + (let [n/a? (function (_ value) + (_.apply (list value) (_.var "is.na"))) + isTRUE? (function (_ value) + (_.apply (list value) (_.var "isTRUE"))) + comparison (is (-> (-> Expression Expression) Expression) + (function (_ field) + (|> (|> (field sample) (_.= (field reference))) + (_.or (|> (n/a? (field sample)) + (_.and (n/a? (field reference))))))))] + (|> (comparison i64_high) + (_.and (comparison i64_low)) + isTRUE?))) + +(runtime + (i64::opposite input) + (_.if (|> input (i64::= i64::min)) + i64::min + (|> input i64::not (i64::+ i64::one)))) + +(runtime + i64::-one + (i64::opposite i64::one)) + +(runtime + (i64::- param subject) + (i64::+ (i64::opposite param) subject)) + +(runtime + (i64::< reference sample) + (with_vars [r_? s_?] + (all _.then + (_.set! s_? (|> sample ..i64_high (_.< (_.int +0)))) + (_.set! r_? (|> reference ..i64_high (_.< (_.int +0)))) + (|> (|> s_? (_.and (_.not r_?))) + (_.or (|> (_.not s_?) (_.and r_?) _.not)) + (_.or (|> sample + (i64::- reference) + ..i64_high + (_.< (_.int +0)))))))) + +(runtime + (i64::of_float input) + (_.cond (list [(_.apply (list input) (_.var "is.nan")) + i64::zero] + [(|> input (_.<= (_.opposite f2^63))) + i64::min] + [(|> input (_.+ (_.float +1.0)) (_.>= f2^63)) + i64::max] + [(|> input (_.< (_.float +0.0))) + (|> input _.opposite i64::of_float i64::opposite)]) + (i64::new (|> input (_./ f2^32)) + (|> input (_.%% f2^32))))) + +(runtime + (i64::* param subject) + (with_vars [sH sL pH pL + x00 x16 x32 x48] + (all _.then + (_.set! sH (|> subject i64_high)) + (_.set! pH (|> param i64_high)) + (let [negative_subject? (|> sH (_.< (_.int +0))) + negative_param? (|> pH (_.< (_.int +0)))] + (_.cond (list [negative_subject? + (_.if negative_param? + (i64::* (i64::opposite param) + (i64::opposite subject)) + (i64::opposite (i64::* param + (i64::opposite subject))))] + + [negative_param? + (i64::opposite (i64::* (i64::opposite param) + subject))]) + (all _.then + (_.set! sL (|> subject i64_low)) + (_.set! pL (|> param i64_low)) + (let [bits16 (_.manual "0xFFFF") + move_top_16 (_.bit_shl (_.int +16)) + top_16 (_.bit_ushr (_.int +16)) + bottom_16 (_.bit_and bits16) + split_16 (function (_ source) + [(|> source top_16) + (|> source bottom_16)]) + split_int (function (_ high low) + [(split_16 high) + (split_16 low)]) + new_half (function (_ top bottom) + (|> top bottom_16 move_top_16 + (_.bit_or (bottom_16 bottom)))) + x16_top (|> x16 top_16) + x32_top (|> x32 top_16)] + (with_vars [s48 s32 s16 s00 + p48 p32 p16 p00] + (let [[[_s48 _s32] [_s16 _s00]] (split_int sH sL) + [[_p48 _p32] [_p16 _p00]] (split_int pH pL) + set_subject_chunks! (all _.then (_.set! s48 _s48) (_.set! s32 _s32) (_.set! s16 _s16) (_.set! s00 _s00)) + set_param_chunks! (all _.then (_.set! p48 _p48) (_.set! p32 _p32) (_.set! p16 _p16) (_.set! p00 _p00))] + (all _.then + set_subject_chunks! + set_param_chunks! + (_.set! x00 (|> s00 (_.* p00))) + (_.set! x16 (|> x00 top_16 (_.+ (|> s16 (_.* p00))))) + (_.set! x32 x16_top) + (_.set! x16 (|> x16 bottom_16 (_.+ (|> s00 (_.* p16))))) + (_.set! x32 (|> x32 (_.+ x16_top) (_.+ (|> s32 (_.* p00))))) + (_.set! x48 x32_top) + (_.set! x32 (|> x32 bottom_16 (_.+ (|> s16 (_.* p16))))) + (_.set! x48 (|> x48 (_.+ x32_top))) + (_.set! x32 (|> x32 bottom_16 (_.+ (|> s00 (_.* p32))))) + (_.set! x48 (|> x48 (_.+ x32_top) + (_.+ (|> s48 (_.* p00))) + (_.+ (|> s32 (_.* p16))) + (_.+ (|> s16 (_.* p32))) + (_.+ (|> s00 (_.* p48))))) + (i64::new (new_half x48 x32) + (new_half x16 x00))))) + ))))))) + +(def (limit_shift! shift) + (-> SVar Expression) + (_.set! shift (|> shift (_.bit_and (_.as::integer (_.int +63)))))) + +(def (no_shift_clause shift input) + (-> SVar SVar [Expression Expression]) + [(|> shift (_.= (_.int +0))) + input]) + +(runtime + (i64::left_shifted shift input) + (all _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (let [mid (|> (i64_low input) (_.bit_ushr (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) + (_.bit_shl shift) + (_.bit_or mid)) + low (|> (i64_low input) + (_.bit_shl shift))] + (i64::new high low))]) + (let [high (|> (i64_high input) + (_.bit_shl (|> shift (_.- (_.int +32)))))] + (i64::new high (_.int +0)))))) + +(runtime + (i64::arithmetic_right_shifted_32 shift input) + (let [top_bit (|> input (_.bit_and (_.as::integer (_.int (hex "+80000000")))))] + (|> input + (_.bit_ushr shift) + (_.bit_or top_bit)))) + +(runtime + (i64::arithmetic_right_shifted shift input) + (all _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) + (i64::arithmetic_right_shifted_32 shift)) + low (|> (i64_low input) + (_.bit_ushr shift) + (_.bit_or mid))] + (i64::new high low))]) + (let [low (|> (i64_high input) + (i64::arithmetic_right_shifted_32 (|> shift (_.- (_.int +32))))) + high (_.if (_.< (_.int +0) + (i64_high input)) + (_.int -1) + (_.int +0))] + (i64::new high low))))) + +(runtime + (i64::/ param subject) + (let [negative? (|>> (i64::< i64::zero)) + valid_division_check [(|> param (i64::= i64::zero)) + (_.stop (_.string "Cannot divide by zero!"))] + short_circuit_check [(|> subject (i64::= i64::zero)) + i64::zero]] + (_.cond (list valid_division_check + short_circuit_check + + [(|> subject (i64::= i64::min)) + (_.cond (list [(|> (|> param (i64::= i64::one)) + (_.or (|> param (i64::= i64::-one)))) + i64::min] + [(|> param (i64::= i64::min)) + i64::one]) + (with_vars [approximation] + (all _.then + (_.set! approximation + (|> subject + (i64::arithmetic_right_shifted (_.int +1)) + (i64::/ param) + (i64::left_shifted (_.int +1)))) + (_.if (|> approximation (i64::= i64::zero)) + (_.if (negative? param) + i64::one + i64::-one) + (let [remainder (i64::- (i64::* param approximation) + subject)] + (|> remainder + (i64::/ param) + (i64::+ approximation)))))))] + [(|> param (i64::= i64::min)) + i64::zero] + + [(negative? subject) + (_.if (negative? param) + (|> (i64::opposite subject) + (i64::/ (i64::opposite param))) + (|> (i64::opposite subject) + (i64::/ param) + i64::opposite))] + + [(negative? param) + (|> param + i64::opposite + (i64::/ subject) + i64::opposite)]) + (with_vars [result remainder approximate approximate_result log2 approximate_remainder] + (all _.then + (_.set! result i64::zero) + (_.set! remainder subject) + (_.while (|> (|> remainder (i64::< param)) + (_.or (|> remainder (i64::= param)))) + (let [calc_rough_estimate (_.apply (list (|> (i64::float remainder) (_./ (i64::float param)))) + (_.var "floor")) + calc_approximate_result (i64::of_float approximate) + calc_approximate_remainder (|> approximate_result (i64::* param)) + delta (_.if (_.> log2 (_.float +48.0)) + (_.** (|> log2 (_.- (_.float +48.0))) + (_.float +2.0)) + (_.float +1.0))] + (all _.then + (_.set! approximate (_.apply (list (_.float +1.0) calc_rough_estimate) + (_.var "max"))) + (_.set! log2 (let [log (function (_ input) + (_.apply (list input) (_.var "log")))] + (_.apply (list (|> (log (_.int +2)) + (_./ (log approximate)))) + (_.var "ceil")))) + (_.set! approximate_result calc_approximate_result) + (_.set! approximate_remainder calc_approximate_remainder) + (_.while (|> (negative? approximate_remainder) + (_.or (|> approximate_remainder (i64::< remainder)))) + (all _.then + (_.set! approximate (|> delta (_.- approximate))) + (_.set! approximate_result calc_approximate_result) + (_.set! approximate_remainder calc_approximate_remainder))) + (_.set! result (|> (_.if (|> approximate_result (i64::= i64::zero)) + i64::one + approximate_result) + (i64::+ result))) + (_.set! remainder (|> remainder (i64::- approximate_remainder)))))) + result)) + ))) + +(runtime + (i64::% param subject) + (let [flat (|> subject (i64::/ param) (i64::* param))] + (|> subject (i64::- flat)))) + +(runtime + (lux::try op) + (with_vars [error value] + (_.try (all _.then + (_.set! value (_.apply (list ..unit) op)) + (..right value)) + {.#None} + {.#Some (_.function (list error) + (..left (_.item (_.string "message") + error)))} + {.#None}))) + +(runtime + (lux::program_args program_args) + (with_vars [inputs value] + (all _.then + (_.set! inputs ..none) + (<| (_.for_in value program_args) + (_.set! inputs (..some (_.list (list value inputs))))) + inputs))) + +(def runtime//lux + Expression + (all _.then + @lux::try + @lux::program_args + )) + +(def current_time_float + Expression + (let [raw_time (_.apply (list) (_.var "Sys.time"))] + (_.apply (list raw_time) (_.var "as.numeric")))) + +(runtime + (io::current_time! _) + (|> current_time_float + (_.* (_.float +1,000.0)) + i64::of_float)) + +(def runtime//io + Expression + (all _.then + @io::current_time! + )) + +(def minimum_index_length + (-> SVar Expression) + (|>> (_.+ (_.int +1)))) + +(def (product_element product index) + (-> Expression Expression Expression) + (|> product (_.item (|> index (_.+ (_.int +1)))))) + +(def (product_tail product) + (-> SVar Expression) + (|> product (_.item (_.length product)))) + +(def (updated_index min_length product) + (-> Expression Expression Expression) + (|> min_length (_.- (_.length product)))) + +(runtime + (tuple::left index product) + (let [$index_min_length (_.var "index_min_length")] + (all _.then + (_.set! $index_min_length (minimum_index_length index)) + (_.if (|> (_.length product) (_.> $index_min_length)) + ... No need for recursion + (product_element product index) + ... Needs recursion + (tuple::left (updated_index $index_min_length product) + (product_tail product)))))) + +(runtime + (tuple::right index product) + (let [$index_min_length (_.var "index_min_length")] + (all _.then + (_.set! $index_min_length (minimum_index_length index)) + (_.cond (list [... Last element. + (|> (_.length product) (_.= $index_min_length)) + (product_element product index)] + [... Needs recursion + (|> (_.length product) (_.< $index_min_length)) + (tuple::right (updated_index $index_min_length product) + (product_tail product))]) + ... Must slice + (|> product (_.slice_from index)))))) + +(runtime + (sum::get sum wants_last? wanted_tag) + (let [no_match _.null + sum_tag (|> sum (_.item (_.string ..variant_tag_field))) + sum_flag (|> sum (_.item (_.string ..variant_flag_field))) + sum_value (|> sum (_.item (_.string ..variant_value_field))) + is_last? (|> sum_flag (_.= (_.string ""))) + test_recursion (_.if is_last? + ... Must recurse. + (|> wanted_tag + (_.- sum_tag) + (sum::get sum_value wants_last?)) + no_match)] + (_.cond (list [(_.= sum_tag wanted_tag) + (_.if (_.= wants_last? sum_flag) + sum_value + test_recursion)] + + [(|> wanted_tag (_.> sum_tag)) + test_recursion] + + [(|> (|> wants_last? (_.= (_.string ""))) + (_.and (|> wanted_tag (_.< sum_tag)))) + (adt::variant (|> sum_tag (_.- wanted_tag)) sum_flag sum_value)]) + + no_match))) + +(def runtime//adt + Expression + (all _.then + @tuple::left + @tuple::right + @sum::get + @adt::variant + )) + +(with_template [<name> <op>] + [(runtime + (<name> mask input) + (i64::new (<op> (i64_high mask) + (i64_high input)) + (<op> (i64_low mask) + (i64_low input))))] + + [i64::and _.bit_and] + [i64::or _.bit_or] + [i64::xor _.bit_xor] + ) + +(runtime + (i64::right_shifted shift input) + (all _.then + (limit_shift! shift) + (_.cond (list (no_shift_clause shift input) + [(|> shift (_.< (_.int +32))) + (with_vars [$mid] + (let [mid (|> (i64_high input) (_.bit_shl (|> (_.int +32) (_.- shift)))) + high (|> (i64_high input) (_.bit_ushr shift)) + low (|> (i64_low input) + (_.bit_ushr shift) + (_.bit_or (_.if (_.apply (list $mid) (_.var "is.na")) + (_.as::integer (_.int +0)) + $mid)))] + (all _.then + (_.set! $mid mid) + (i64::new high low))))] + [(|> shift (_.= (_.int +32))) + (let [high (i64_high input)] + (i64::new (_.int +0) high))]) + (let [low (|> (i64_high input) (_.bit_ushr (|> shift (_.- (_.int +32)))))] + (i64::new (_.int +0) low))))) + +(def runtime//i64 + Expression + (all _.then + @f2^32 + @f2^63 + + @i64::new + @i64::of_float + + @i64::and + @i64::or + @i64::xor + @i64::not + @i64::left_shifted + @i64::arithmetic_right_shifted_32 + @i64::arithmetic_right_shifted + @i64::right_shifted + + @i64::zero + @i64::one + @i64::min + @i64::max + @i64::= + @i64::< + @i64::+ + @i64::- + @i64::opposite + @i64::-one + @i64::unsigned_low + @i64::float + @i64::* + @i64::/ + @i64::% + )) + +(runtime + (frac::decode input) + (with_vars [output] + (all _.then + (_.set! output (_.apply (list input) (_.var "as.numeric"))) + (_.if (|> output (_.= _.n/a)) + ..none + (..some output))))) + +(def runtime//frac + Expression + (all _.then + @frac::decode + )) + +(def ++ + (-> Expression Expression) + (|>> (_.+ (_.int +1)))) + +(def (text_clip start end text) + (-> Expression Expression Expression Expression) + (_.apply (list text start end) + (_.var "substr"))) + +(def (text_length text) + (-> Expression Expression) + (_.apply (list text) (_.var "nchar"))) + +(runtime + (text::index subject param start) + (with_vars [idx startF subjectL] + (all _.then + (_.set! startF (i64::float start)) + (_.set! subjectL (text_length subject)) + (_.if (_.< subjectL startF) + (all _.then + (_.set! idx (|> (_.apply_kw (list param (_.if (|> startF (_.= (_.int +0))) + subject + (text_clip (++ startF) + (++ subjectL) + subject))) + (list ["fixed" (_.bool #1)]) + (_.var "regexpr")) + (_.item (_.int +1)))) + (_.if (|> idx (_.= (_.int -1))) + ..none + (..some (i64::of_float (|> idx (_.+ startF)))))) + ..none)))) + +(runtime + (text::clip text minimum additional) + (with_vars [length] + (all _.then + (_.set! length (_.length text)) + (_.set! to (_.+ additional minimum)) + (_.if (_.< length to) + (..some (text_clip (++ minimum) (++ to) text)) + ..none)))) + +(def (char_at idx text) + (-> Expression Expression Expression) + (_.apply (list (text_clip idx idx text)) + (_.var "utf8ToInt"))) + +(runtime + (text::char text idx) + (_.if (_.< (_.length text) idx) + (all _.then + (_.set! idx (++ idx)) + (..some (i64::of_float (char_at idx text)))) + ..none)) + +(def runtime//text + Expression + (all _.then + @text::index + @text::clip + @text::char + )) + +(def (check_index_out_of_bounds array idx body) + (-> Expression Expression Expression Expression) + (_.if (_.> (_.length array) idx) + (_.stop (_.string "Array index out of bounds!")) + body)) + +(runtime + (array::new size) + (with_vars [output] + (all _.then + (_.set! output (_.list (list))) + (_.set_item! (|> size (_.+ (_.int +1))) + _.null + output) + output))) + +(runtime + (array::get array idx) + (with_vars [temp] + (<| (check_index_out_of_bounds array idx) + (all _.then + (_.set! temp (|> array (_.item (_.+ (_.int +1) idx)))) + (_.if (|> temp (_.= _.null)) + ..none + (..some temp)))))) + +(runtime + (array::put array idx value) + (<| (check_index_out_of_bounds array idx) + (all _.then + (_.set_item! (_.+ (_.int +1) idx) value array) + array))) + +(def runtime//array + Expression + (all _.then + @array::new + @array::get + @array::put + )) + +(def full_runtime + Expression + (all _.then + runtime//lux + runtime//i64 + runtime//adt + runtime//frac + runtime//text + runtime//array + runtime//io + )) + +(def .public generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..full_runtime) + _ (/////generation.save! (%.nat ..module_id) ..full_runtime)] + (in [(|> artifact.empty + artifact.resource + product.right) + (sequence.sequence [(%.nat ..module_id) + (|> ..full_runtime + _.code + (at utf8.codec encoded))])]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/structure.lux new file mode 100644 index 000000000..b381f8d63 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/r/structure.lux @@ -0,0 +1,41 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [data + [collection + ["[0]" list]]] + [meta + [target + ["_" r (.only Expression)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" primitive] + ["///[1]" //// + [analysis (.only Variant Tuple)] + ["[1][0]" synthesis (.only Synthesis)] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)]]]]) + +(def .public (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + {.#End} + (///////phase#in (//primitive.text /////synthesis.unit)) + + {.#Item singletonS {.#End}} + (expression archive singletonS) + + _ + (|> elemsS+ + (monad.each ///////phase.monad (expression archive)) + (///////phase#each _.list)))) + +(def .public (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (++ lefts) + lefts)] + (///////phase#each (|>> (//runtime.variant tag right?)) + (expression archive valueS)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/reference.lux new file mode 100644 index 000000000..bc1c562c2 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/reference.lux @@ -0,0 +1,99 @@ +(.require + [library + [lux (.except local) + [data + [text + ["%" \\format (.only format)]]] + [meta + ["@" target] + ["[0]" version]]]] + ["[0]" //// + ["[1][0]" generation] + ["//[1]" /// + ["[0]" phase (.use "[1]#[0]" monad)] + ["[0]" reference (.only Reference) + ["[0]" variable (.only Register Variable)]] + [meta + [archive (.only Archive) + ["[0]" unit]]]]]) + +... This universe constant is for languages where one can't just turn all compiled definitions +... into the local variables of some scoping function. +(def .public universe + (for @.lua + ... In the case of Lua, there is a limit of 200 locals in a function's scope. + (not ("lua script universe")) + + @.ruby + ... Cannot make all definitions be local variables because of limitations with JRuby. + (not ("ruby script universe")) + + @.php + ... Cannot make all definitions be local variables because of limitations with PHP itself. + (not ("php script universe")) + + @.scheme + ... Cannot make all definitions be local variables because of limitations with Kawa. + (not ("scheme script universe")) + #0)) + +(def universe_label + Text + (with_expansions [<label> (format "u" (%.nat (if ..universe 1 0)))] + (for @.lua <label> + @.ruby <label> + @.php <label> + @.scheme <label> + ""))) + +(def .public (artifact [module artifact]) + (-> unit.ID Text) + (format "l" (%.nat version.latest) + ..universe_label + "m" (%.nat module) + "a" (%.nat artifact))) + +(type .public (System expression) + (Interface + (is (-> Text expression) + constant') + (is (-> Text expression) + variable'))) + +(def .public (constant system archive name) + (All (_ anchor expression declaration) + (-> (System expression) Archive Symbol + (////generation.Operation anchor expression declaration expression))) + (phase#each (|>> ..artifact (at system constant')) + (////generation.remember archive name))) + +(with_template [<sigil> <name>] + [(def .public (<name> system) + (All (_ expression) + (-> (System expression) + (-> Register expression))) + (|>> %.nat (format <sigil>) (at system variable')))] + + ["f" foreign] + ["l" local] + ) + +(def .public (variable system variable) + (All (_ expression) + (-> (System expression) Variable expression)) + (case variable + {variable.#Local register} + (..local system register) + + {variable.#Foreign register} + (..foreign system register))) + +(def .public (reference system archive reference) + (All (_ anchor expression declaration) + (-> (System expression) Archive Reference (////generation.Operation anchor expression declaration expression))) + (case reference + {reference.#Constant value} + (..constant system archive value) + + {reference.#Variable value} + (phase#in (..variable system value)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby.lux new file mode 100644 index 000000000..f3e5aed3c --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby.lux @@ -0,0 +1,80 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["[0]" exception (.only exception)]] + [meta + [macro + ["^" pattern]] + [target + ["_" ruby]]]]] + ["[0]" / + [runtime (.only Phase Phase!)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" function] + ["[1][0]" case] + ["[1][0]" loop] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" extension (.only) + [generation + [ruby + ["[1]/[0]" common]]]] + ["/[1]" // + [analysis (.only)] + ["[1][0]" synthesis] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference (.only) + [variable (.only)]]]]]]]) + +(exception .public cannot_recur_as_an_expression) + +(def (expression archive synthesis) + Phase + (case synthesis + (^.with_template [<tag> <generator>] + [(<tag> value) + (//////phase#in (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> expression archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + + [////synthesis.branch/exec /case.exec] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + + [////synthesis.function/apply /function.apply]) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> ///extension/common.statement expression archive value)]) + ([////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.function/abstraction /function.function]) + + (////synthesis.loop/again _) + (//////phase.except ..cannot_recur_as_an_expression []) + + {////synthesis.#Reference value} + (//reference.reference /reference.system archive value) + + {////synthesis.#Extension extension} + (///extension.apply archive expression extension))) + +(def .public generate + Phase + ..expression) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/case.lux new file mode 100644 index 000000000..88a7e039e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/case.lux @@ -0,0 +1,382 @@ +(.require + [library + [lux (.except case exec let if symbol) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set]]] + [math + [number + ["n" nat] + ["i" int]]] + [meta + [macro + ["^" pattern]] + [target + ["_" ruby (.only Expression LVar Statement)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator Phase! Generator!)] + ["[1][0]" reference] + ["[1][0]" primitive] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + [synthesis + ["[0]" case]] + ["/[1]" // + ["[1][0]" generation] + ["[1][0]" synthesis (.only Synthesis Path) + [access + ["[0]" member (.only Member)]]] + ["//[1]" /// + [reference + ["[1][0]" variable (.only Register)]] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)]]]]]]]) + +(def .public (symbol prefix) + (-> Text (Operation LVar)) + (///////phase#each (|>> %.nat (format prefix) _.local) /////generation.next)) + +(def .public register + (-> Register LVar) + (|>> (///reference.local //reference.system) as_expected)) + +(def .public capture + (-> Register LVar) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def .public (exec expression archive [this that]) + (Generator [Synthesis Synthesis]) + (do ///////phase.monad + [this (expression archive this) + that (expression archive that)] + (in (|> (_.array (list this that)) + (_.item (_.int +1)))))) + +(def .public (exec! statement expression archive [this that]) + (Generator! [Synthesis Synthesis]) + (do ///////phase.monad + [this (expression archive this) + that (statement expression archive that)] + (in (all _.then + (_.statement this) + that + )))) + +(def .public (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + ... TODO: Find some way to do 'let' without paying the price of the closure. + (in (|> bodyO + _.return + [(list (..register register))] (_.lambda {.#None}) + (_.apply_lambda (list valueO)))))) + +(def .public (let! statement expression archive [valueS register bodyS]) + (Generator! [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (statement expression archive bodyS)] + (in (all _.then + (_.set (list (..register register)) valueO) + bodyO)))) + +(def .public (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (in (_.? testO thenO elseO)))) + +(def .public (if! statement expression archive [testS thenS elseS]) + (Generator! [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [test! (expression archive testS) + then! (statement expression archive thenS) + else! (statement expression archive elseS)] + (in (_.if test! + then! + else!)))) + +(def .public (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (in (list#mix (function (_ side source) + (.let [method (.if (the member.#right? side) + (//runtime.tuple//right (_.int (.int (the member.#lefts side)))) + (//runtime.tuple//left (_.int (.int (the member.#lefts side)))))] + (method source))) + valueO + (list.reversed pathP))))) + +(def @savepoint (_.local "lux_pm_savepoint")) +(def @cursor (_.local "lux_pm_cursor")) +(def @temp (_.local "lux_pm_temp")) + +(def (push! value) + (-> Expression Statement) + (_.statement (|> @cursor (_.do "push" (list value) {.#None})))) + +(def peek_and_pop + Expression + (|> @cursor (_.do "pop" (list) {.#None}))) + +(def pop! + Statement + (_.statement ..peek_and_pop)) + +(def peek + Expression + (_.item (_.int -1) @cursor)) + +(def save! + Statement + (.let [cursor (_.array_range (_.int +0) (_.int -1) @cursor)] + (_.statement (|> @savepoint (_.do "push" (list cursor) {.#None}))))) + +(def restore! + Statement + (_.set (list @cursor) (|> @savepoint (_.do "pop" (list) {.#None})))) + +(def fail! _.break) + +(def (multi_pop! pops) + (-> Nat Statement) + (_.statement (_.do "slice!" + (list (_.int (i.* -1 (.int pops))) + (_.int (.int pops))) + {.#None} + @cursor))) + +(with_template [<name> <flag>] + [(def (<name> simple? idx) + (-> Bit Nat Statement) + (all _.then + (_.set (list @temp) (//runtime.sum//get ..peek <flag> + (|> idx .int _.int))) + (.if simple? + (_.when (_.= _.nil @temp) + fail!) + (_.if (_.= _.nil @temp) + fail! + (..push! @temp)))))] + + [left_choice _.nil] + [right_choice //runtime.unit] + ) + +(def (with_looping in_closure? g!once g!continue? body!) + (-> Bit LVar LVar Statement Statement) + (.if in_closure? + (all _.then + (_.while (_.bool true) + body!)) + (all _.then + (_.set (list g!once) (_.bool true)) + (_.set (list g!continue?) (_.bool false)) + (<| (_.while (_.bool true)) + (_.if g!once + (all _.then + (_.set (list g!once) (_.bool false)) + body!) + (all _.then + (_.set (list g!continue?) (_.bool true)) + _.break))) + (_.when g!continue? + _.next)))) + +(def (alternation in_closure? g!once g!continue? pre! post!) + (-> Bit LVar LVar Statement Statement Statement) + (all _.then + (with_looping in_closure? g!once g!continue? + (all _.then + ..save! + pre!)) + ..restore! + post!)) + +(def (primitive_pattern_matching again pathP) + (-> (-> Path (Operation Statement)) + (-> Path (Operation (Maybe Statement)))) + (.case pathP + {/////synthesis.#Bit_Fork when thenP elseP} + (do [! ///////phase.monad] + [then! (again thenP) + else! (.case elseP + {.#Some elseP} + (again elseP) + + {.#None} + (in ..fail!))] + (in {.#Some (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!))})) + + (^.with_template [<tag> <format>] + [{<tag> item} + (do [! ///////phase.monad] + [clauses (monad.each ! (function (_ [match then]) + (at ! each + (|>> [(_.= (|> match <format>) + ..peek)]) + (again then))) + {.#Item item})] + (in {.#Some (list#mix (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)}))]) + ([/////synthesis.#I64_Fork (<| //primitive.i64 .int)] + [/////synthesis.#F64_Fork (<| //primitive.f64)] + [/////synthesis.#Text_Fork (<| //primitive.text)]) + + _ + (at ///////phase.monad in {.#None}))) + +(def (pattern_matching' in_closure? statement expression archive) + (-> Bit (Generator! Path)) + (function (again pathP) + (do ///////phase.monad + [?output (primitive_pattern_matching again pathP)] + (.case ?output + {.#Some output} + (in output) + + {.#None} + (.case pathP + {/////synthesis.#Then bodyS} + (statement expression archive bodyS) + + {/////synthesis.#Pop} + (///////phase#in ..pop!) + + {/////synthesis.#Bind register} + (///////phase#in (_.set (list (..register register)) ..peek)) + + {/////synthesis.#Bit_Fork when thenP elseP} + (do [! ///////phase.monad] + [then! (again thenP) + else! (.case elseP + {.#Some elseP} + (again elseP) + + {.#None} + (in ..fail!))] + (in (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^.with_template [<tag> <format>] + [{<tag> item} + (do [! ///////phase.monad] + [clauses (monad.each ! (function (_ [match then]) + (at ! each + (|>> [(_.= (|> match <format>) + ..peek)]) + (again then))) + {.#Item item})] + (in (list#mix (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)))]) + ([/////synthesis.#I64_Fork (<| //primitive.i64 .int)] + [/////synthesis.#F64_Fork (<| //primitive.f64)] + [/////synthesis.#Text_Fork (<| //primitive.text)]) + + (^.with_template [<complex> <simple> <choice>] + [(<complex> idx) + (///////phase#in (<choice> false idx)) + + (<simple> idx nextP) + (|> nextP + again + (///////phase#each (_.then (<choice> true idx))))]) + ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] + [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) + + (/////synthesis.member/left 0) + (///////phase#in (|> ..peek (_.item (_.int +0)) ..push!)) + + (^.with_template [<pm> <getter>] + [(<pm> lefts) + (///////phase#in (|> ..peek (<getter> (_.int (.int lefts))) ..push!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (/////synthesis.!bind_top register thenP) + (do ///////phase.monad + [then! (again thenP)] + (///////phase#in (all _.then + (_.set (list (..register register)) ..peek_and_pop) + then!))) + + (/////synthesis.!multi_pop nextP) + (.let [[extra_pops nextP'] (case.count_pops nextP)] + (do ///////phase.monad + [next! (again nextP')] + (///////phase#in (all _.then + (..multi_pop! (n.+ 2 extra_pops)) + next!)))) + + (/////synthesis.path/seq preP postP) + (do ///////phase.monad + [pre! (again preP) + post! (again postP)] + (in (all _.then + pre! + post!))) + + (/////synthesis.path/alt preP postP) + (do ///////phase.monad + [pre! (again preP) + post! (again postP) + g!once (..symbol "once") + g!continue? (..symbol "continue")] + (in (..alternation in_closure? g!once g!continue? pre! post!)))))))) + +(def (pattern_matching in_closure? statement expression archive pathP) + (-> Bit (Generator! Path)) + (do ///////phase.monad + [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP) + g!once (..symbol "once") + g!continue? (..symbol "continue")] + (in (all _.then + (..with_looping in_closure? g!once g!continue? + pattern_matching!) + (_.statement (_.raise (_.string case.pattern_matching_error))))))) + +(def .public (case! in_closure? statement expression archive [valueS pathP]) + (-> Bit (Generator! [Synthesis Path])) + (do ///////phase.monad + [stack_init (expression archive valueS) + pattern_matching! (pattern_matching in_closure? statement expression archive pathP)] + (in (all _.then + (_.set (list @cursor) (_.array (list stack_init))) + (_.set (list @savepoint) (_.array (list))) + pattern_matching! + )))) + +(def .public (case statement expression archive case) + (-> Phase! (Generator [Synthesis Path])) + (|> case + (case! true statement expression archive) + (at ///////phase.monad each + (|>> [(list)] (_.lambda {.#None}) + (_.apply_lambda (list)))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/function.lux new file mode 100644 index 000000000..51cf79c55 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/function.lux @@ -0,0 +1,123 @@ +(.require + [library + [lux (.except function) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)]]] + [meta + [target + ["_" ruby (.only LVar GVar Expression Statement)]]]]] + ["[0]" // + [runtime (.only Operation Phase Generator Phase! Generator!)] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["/[1]" // + ["[1][0]" reference] + ["//[1]" /// + [synthesis (.only Synthesis)] + [analysis (.only Environment Abstraction Reification Analysis)] + ["[1][0]" generation] + ["//[1]" /// + [arity (.only Arity)] + ["[1][0]" phase] + [reference + [variable (.only Register Variable)]] + [meta + ["[0]" cache + [dependency + ["[1]/[0]" artifact]]]]]]]]) + +(def .public (apply expression archive [functionS argsS+]) + (Generator (Reification Synthesis)) + (do [! ///////phase.monad] + [functionO (expression archive functionS) + argsO+ (monad.each ! (expression archive) argsS+)] + (in (_.apply_lambda argsO+ functionO)))) + +(def .public capture + (-> Register LVar) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def (with_closure inits self function_definition) + (-> (List Expression) Text Expression [Statement Expression]) + (let [@self (_.global self)] + (case inits + {.#End} + [(_.set (list @self) function_definition) + @self] + + _ + [(_.set (list @self) (_.lambda {.#None} + [(|> (list.enumeration inits) + (list#each (|>> product.left ..capture))) + (let [@self (_.local self)] + (all _.then + (_.set (list @self) function_definition) + (_.return @self)))])) + (_.apply_lambda inits @self)]))) + +(def input + (|>> ++ //case.register)) + +(def .public (function statement expression archive [environment arity bodyS]) + (-> Phase! (Generator (Abstraction Synthesis))) + (do [! ///////phase.monad] + [dependencies (cache/artifact.dependencies archive bodyS) + [[function_module function_artifact] body!] (/////generation.with_new_context archive dependencies + (/////generation.with_anchor 1 + (statement expression archive bodyS))) + closureO+ (monad.each ! (expression archive) environment) + .let [function_name (///reference.artifact [function_module function_artifact]) + @curried (_.local "curried") + arityO (|> arity .int _.int) + limitO (|> arity -- .int _.int) + @num_args (_.local "num_args") + @self (is _.Location + (case closureO+ + {.#End} + (_.global function_name) + + _ + (_.local function_name))) + initialize_self! (_.set (list (//case.register 0)) @self) + initialize! (list#mix (.function (_ post pre!) + (all _.then + pre! + (_.set (list (..input post)) (_.item (|> post .int _.int) @curried)))) + initialize_self! + (list.indices arity)) + [declaration instatiation] (with_closure closureO+ function_name + (_.lambda {.#None} + [(list (_.variadic @curried)) + (all _.then + (_.set (list @num_args) (_.the "length" @curried)) + (<| (_.if (|> @num_args (_.= arityO)) + (<| (_.then initialize!) + //loop.with_scope + body!)) + (_.if (|> @num_args (_.> arityO)) + (let [slice (.function (_ from to) + (_.array_range from to @curried)) + arity_args (_.splat (slice (_.int +0) limitO)) + output_func_args (_.splat (slice arityO @num_args))] + (_.return (|> @self + (_.apply_lambda (list arity_args)) + (_.apply_lambda (list output_func_args)))))) + ... (|> @num_args (_.< arityO)) + (let [@missing (_.local "missing")] + (_.return (_.lambda {.#None} + [(list (_.variadic @missing)) + (_.return (|> @self + (_.apply_lambda (list (_.splat (|> (_.array (list)) + (_.do "concat" (list @curried) {.#None}) + (_.do "concat" (list @missing) {.#None})))))))])))) + )]))] + _ (/////generation.execute! declaration) + _ (/////generation.save! function_artifact {.#None} declaration)] + (in instatiation))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/loop.lux new file mode 100644 index 000000000..1a82b9e18 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/loop.lux @@ -0,0 +1,96 @@ +(.require + [library + [lux (.except Scope symbol) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set]]] + [math + [number + ["n" nat]]] + [meta + [target + ["_" ruby (.only Expression LVar Statement)]]]]] + ["[0]" // + [runtime (.only Operation Phase Generator Phase! Generator!)] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + [synthesis + ["[0]" case]] + ["/[1]" // + ["[0]" synthesis (.only Scope Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + ["[1][0]" phase] + [reference + ["[1][0]" variable (.only Register)]]]]]]]) + +(def (setup offset bindings body) + (-> Register (List Expression) Statement Statement) + (let [variables (|> bindings + list.enumeration + (list#each (|>> product.left (n.+ offset) //case.register)))] + (all _.then + (_.set variables (_.multi bindings)) + body))) + +(def symbol + (_.symbol "lux_continue")) + +(def .public with_scope + (-> Statement Statement) + (_.while (_.bool true))) + +(def .public (scope! statement expression archive [start initsS+ bodyS]) + (Generator! (Scope Synthesis)) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (statement expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [initsO+ (monad.each ! (expression archive) initsS+) + body! (/////generation.with_anchor start + (statement expression archive bodyS))] + (in (<| (..setup start initsO+) + ..with_scope + body!))))) + +(def .public (scope statement expression archive [start initsS+ bodyS]) + (-> Phase! (Generator (Scope Synthesis))) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [body! (scope! statement expression archive [start initsS+ bodyS])] + (in (|> body! + [(list)] (_.lambda {.#None}) + (_.apply_lambda (list))))))) + +(def .public (again! statement expression archive argsS+) + (Generator! (List Synthesis)) + (do [! ///////phase.monad] + [offset /////generation.anchor + @temp (//case.symbol "lux_again_values") + argsO+ (monad.each ! (expression archive) argsS+) + .let [re_binds (|> argsO+ + list.enumeration + (list#each (function (_ [idx _]) + (_.item (_.int (.int idx)) @temp))))]] + (in (all _.then + (_.set (list @temp) (_.array argsO+)) + (..setup offset re_binds + _.next))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/primitive.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/primitive.lux new file mode 100644 index 000000000..06b100bc5 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/primitive.lux @@ -0,0 +1,17 @@ +(.require + [library + [lux (.except i64) + [meta + [target + ["_" ruby (.only Literal)]]]]]) + +(with_template [<type> <name> <implementation>] + [(def .public <name> + (-> <type> Literal) + <implementation>)] + + [Bit bit _.bool] + [(I64 Any) i64 (|>> .int _.int)] + [Frac f64 _.float] + [Text text _.string] + ) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/reference.lux new file mode 100644 index 000000000..28629dc19 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/reference.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [meta + [target + ["_" ruby (.only Expression)]]]]] + [/// + [reference (.only System)]]) + +(def .public system + (System Expression) + (implementation + (def constant' _.global) + (def variable' _.local))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/runtime.lux new file mode 100644 index 000000000..194b97c7e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/runtime.lux @@ -0,0 +1,629 @@ +(.require + [library + [lux (.except i64 left right) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" sequence]]] + [math + [number (.only hex) + ["[0]" i64] + ["[0]" int (.use "[1]#[0]" interval)]]] + ["[0]" meta (.only) + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)]] + ["@" target (.only) + ["_" ruby (.only Expression LVar Computation Literal Statement)]]]]] + ["[0]" /// + ["[1][0]" reference] + ["//[1]" /// + ["[1][0]" synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// (.only) + ["[1][0]" phase] + [reference + [variable (.only Register)]] + [meta + [archive (.only Output Archive) + ["[0]" unit] + ["[0]" registry (.only Registry)]]]]]]) + +(with_template [<name> <base>] + [(type .public <name> + (<base> Register Expression Statement))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type .public (Generator i) + (-> Phase Archive i (Operation Expression))) + +(type .public Phase! + (-> Phase Archive Synthesis (Operation Statement))) + +(type .public (Generator! i) + (-> Phase! Phase Archive i (Operation Statement))) + +(def .public unit + (_.string /////synthesis.unit)) + +(def (flag value) + (-> Bit Literal) + (if value + ..unit + _.nil)) + +(def .public with_vars + (syntax (_ [vars (<code>.tuple (<>.some <code>.local)) + body <code>.any]) + (do [! meta.monad] + [ids (monad.all ! (list.repeated (list.size vars) meta.seed))] + (in (list (` (let [(,* (|> vars + (list.zipped_2 ids) + (list#each (function (_ [id var]) + (list (code.local var) + (` (_.local (, (code.text (format "v" (%.nat id))))))))) + list.together))] + (, body)))))))) + +(def module_id + 0) + +(def $Numeric + _.CVar + (_.manual "Numeric")) + +(def mruby? + _.Expression + (_.and (|> $Numeric + (_.do "method_defined?" (list (_.string "remainder")) {.#None}) + _.not) + (|> $Numeric + (_.do "method_defined?" (list (_.string "remainder_of_divide")) {.#None})))) + +(def normal_ruby? + _.Expression + (_.not ..mruby?) + ... (|> (_.local "Object") + ... (_.do "const_defined?" (list (_.string "Encoding")) {.#None})) + ) + +(def runtime + (syntax (_ [declaration (<>.or <code>.local + (<code>.form (<>.and <code>.local + (<>.some <code>.local)))) + conditional_implementations (<>.some (<code>.tuple (<>.and <code>.any <code>.any))) + default_implementation <code>.any]) + (do meta.monad + [runtime_id meta.seed] + (macro.with_symbols [g!_] + (case declaration + {.#Left name} + (macro.with_symbols [g!_] + (let [runtime (code.local (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.constant (, (code.text (%.code runtime))))) + g!name (code.local name)] + (in (list (` (def .public (, g!name) _.CVar (, runtime_name))) + (` (def (, (code.local (format "@" name))) + Statement + (, (list#mix (function (_ [when then] else) + (` (_.if (, when) + (_.set (list (, runtime_name)) (, then)) + (, else)))) + (` (_.set (list (, runtime_name)) (, default_implementation))) + conditional_implementations)))))))) + + {.#Right [name inputs]} + (macro.with_symbols [g!_] + (let [runtime (code.local (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.local (, (code.text (%.code runtime))))) + g!name (code.local name) + inputsC (list#each code.local inputs) + inputs_typesC (list#each (function.constant (` _.Expression)) + inputs)] + (in (list (` (def .public ((, g!name) (,* inputsC)) + (-> (,* inputs_typesC) Computation) + (_.apply (list (,* inputsC)) {.#None} + (, runtime_name)))) + + (` (def (, (code.local (format "@" name))) + Statement + (..with_vars [(,* inputsC)] + (, (list#mix (function (_ [when then] else) + (` (_.if (, when) + (_.function (, runtime_name) (list (,* inputsC)) + (, then)) + (, else)))) + (` (_.function (, runtime_name) (list (,* inputsC)) + (, default_implementation))) + conditional_implementations)))))))))))))) + +(def tuple_size + (_.the "length")) + +(def last_index + (|>> ..tuple_size (_.- (_.int +1)))) + +(with_expansions [<recur> (these (all _.then + (_.set (list lefts) (_.- last_index_right lefts)) + (_.set (list tuple) (_.item last_index_right tuple))))] + (runtime + (tuple//left lefts tuple) + (with_vars [last_index_right] + (<| (_.while (_.bool true)) + (all _.then + (_.set (list last_index_right) (..last_index tuple)) + (_.if (_.> lefts last_index_right) + ... No need for recursion + (_.return (_.item lefts tuple)) + ... Needs recursion + <recur>))))) + + (runtime + (tuple//right lefts tuple) + (with_vars [last_index_right right_index] + (<| (_.while (_.bool true)) + (all _.then + (_.set (list last_index_right) (..last_index tuple)) + (_.set (list right_index) (_.+ (_.int +1) lefts)) + (<| (_.if (_.= last_index_right right_index) + (_.return (_.item right_index tuple))) + (_.if (_.> last_index_right right_index) + ... Needs recursion. + <recur>) + (_.return (_.array_range right_index (..tuple_size tuple) tuple))) + ))))) + +(def .public variant_tag_field "_lux_tag") +(def .public variant_flag_field "_lux_flag") +(def .public variant_value_field "_lux_value") + +(runtime + (sum//make tag last? value) + (_.return (_.hash (list [(_.string ..variant_tag_field) tag] + [(_.string ..variant_flag_field) last?] + [(_.string ..variant_value_field) value])))) + +(def .public (variant tag last? value) + (-> Nat Bit Expression Computation) + (sum//make (_.int (.int tag)) (..flag last?) value)) + +(def .public left + (-> Expression Computation) + (..variant 0 #0)) + +(def .public right + (-> Expression Computation) + (..variant 0 #1)) + +(def .public none + Computation + (..left ..unit)) + +(def .public some + (-> Expression Computation) + ..right) + +(runtime + (sum//get sum expected::right? expected::lefts) + (let [mismatch! (_.return _.nil) + actual::lefts (_.item (_.string ..variant_tag_field) sum) + actual::right? (_.item (_.string ..variant_flag_field) sum) + actual::value (_.item (_.string ..variant_value_field) sum) + recur! (all _.then + (_.set (list expected::lefts) (|> expected::lefts + (_.- actual::lefts) + (_.- (_.int +1)))) + (_.set (list sum) actual::value))] + (<| (_.while (_.bool true)) + (_.if (_.= expected::lefts actual::lefts) + (_.if (_.= expected::right? actual::right?) + (_.return actual::value) + mismatch!)) + (_.if (_.< expected::lefts actual::lefts) + (_.if (_.= ..unit actual::right?) + recur! + mismatch!)) + (_.if (_.= ..unit expected::right?) + (_.return (sum//make (|> actual::lefts + (_.- expected::lefts) + (_.- (_.int +1))) + actual::right? + actual::value))) + mismatch!))) + +(def runtime//adt + Statement + (all _.then + @tuple//left + @tuple//right + @sum//make + @sum//get + )) + +(runtime + (lux//try risky) + (with_vars [error value] + (_.begin (all _.then + (_.set (list value) (_.apply_lambda (list ..unit) risky)) + (_.return (..right value))) + (list [(list) error + (_.return (..left (_.the "message" error)))])))) + +(runtime + (lux//program_args raw) + (with_vars [tail head] + (all _.then + (_.set (list tail) ..none) + (<| (_.for_in head raw) + (_.set (list tail) (..some (_.array (list head tail))))) + (_.return tail)))) + +(def runtime//lux + Statement + (all _.then + @lux//try + @lux//program_args + )) + +(def i64::+limit (_.manual "+0x7FFFFFFFFFFFFFFF")) +(def i64::-limit (_.manual "-0x8000000000000000")) +(def i64::+cap (_.manual "+0x8000000000000000")) +(def i64::-cap (_.manual "-0x8000000000000001")) + +(runtime + i64::+iteration (_.manual "(+1<<64)")) +(runtime + i64::-iteration (_.manual "(-1<<64)")) + +(runtime + (i64::i64 input) + [..mruby? (_.return input)] + (with_vars [temp] + (`` (<| (,, (with_template [<scenario> <iteration> <cap> <entrance>] + [(_.if (|> input <scenario>) + (all _.then + (_.set (list temp) (_.% <iteration> input)) + (_.return (_.? (|> temp <scenario>) + (|> temp (_.- <cap>) (_.+ <entrance>)) + temp))))] + + [(_.> ..i64::+limit) ..i64::+iteration ..i64::+cap ..i64::-limit] + [(_.< ..i64::-limit) ..i64::-iteration ..i64::-cap ..i64::+limit] + )) + (_.return input))))) + +(def i32::low + (|>> (_.bit_and (_.manual "+0xFFFFFFFF")))) + +(def i32::high + (|>> (_.bit_shr (_.int +32)) + ..i32::low)) + +(def i32::positive? + (|>> (_.bit_and (_.manual "+0x80000000")) + (_.= (_.int +0)))) + +(def i32::up + (_.bit_shl (_.int +32))) + +(def i64 + (template (_ @high @low) + [(|> (_.? (i32::positive? @high) + @high + (|> (_.manual "+0xFFFFFFFF") + (_.- @high) + _.bit_not)) + i32::up + (_.bit_or @low))])) + +(def as_nat + (_.% ..i64::+iteration)) + +(with_template [<runtime> <host>] + [(runtime + (<runtime> left right) + [..normal_ruby? (_.return (..i64::i64 (<host> (..as_nat left) (..as_nat right))))] + (with_vars [high low] + (all _.then + (_.set (list high) (<host> (i32::high left) (..i32::high right))) + (_.set (list low) (<host> (i32::low left) (..i32::low right))) + (_.return (..i64 high low)))))] + + [i64::and _.bit_and] + [i64::or _.bit_or] + [i64::xor _.bit_xor] + ) + +(def (cap_shift! shift) + (-> LVar Statement) + (_.set (list shift) (|> shift (_.bit_and (_.int +63))))) + +(def (handle_no_shift! shift input) + (-> LVar LVar (-> Statement Statement)) + (_.if (|> shift (_.= (_.int +0))) + (_.return input))) + +(def small_shift? + (-> LVar Expression) + (|>> (_.< (_.int +32)))) + +(runtime + (i64::left_shifted shift input) + [..normal_ruby? (_.return (|> input + (_.bit_shl (_.% (_.int +64) shift)) + ..i64::i64))] + (with_vars [high low] + (all _.then + (..cap_shift! shift) + (<| (..handle_no_shift! shift input) + (_.if (..small_shift? shift) + (all _.then + (_.set (list high) (_.bit_or (|> input i32::high (_.bit_shl shift)) + (|> input i32::low (_.bit_shr (_.- shift (_.int +32)))))) + (_.set (list low) (|> input i32::low (_.bit_shl shift))) + (_.return (..i64 (i32::low high) + (i32::low low))))) + (all _.then + (_.set (list high) (|> input i32::low (_.bit_shl (_.- (_.int +32) shift)))) + (_.return (..i64 (i32::low high) + (_.int +0))))) + ))) + +(runtime + (i64::right_shifted shift input) + [..normal_ruby? (all _.then + (_.set (list shift) (_.% (_.int +64) shift)) + (_.return (_.? (_.= (_.int +0) shift) + input + (|> input + ..as_nat + (_.bit_shr shift)))))] + (with_vars [high low] + (all _.then + (..cap_shift! shift) + (<| (..handle_no_shift! shift input) + (_.if (..small_shift? shift) + (all _.then + (_.set (list high) (|> input i32::high (_.bit_shr shift))) + (_.set (list low) (|> input i32::low (_.bit_shr shift) + (_.bit_or (|> input i32::high (_.bit_shl (_.- shift (_.int +32))))))) + (_.return (..i64 high low)))) + (_.return (_.? (|> shift (_.= (_.int +32))) + (i32::high input) + (|> input i32::high (_.bit_shr (_.- (_.int +32) shift))))))))) + +(runtime + (i64::/ parameter subject) + (_.return (_.? (_.and (_.= (_.int -1) parameter) + (_.= (_.int int#bottom) subject)) + subject + (let [extra (_.do "remainder" (list parameter) {.#None} subject)] + (|> subject + (_.- extra) + (_./ parameter)))))) + +(runtime + (i64::+ parameter subject) + [..normal_ruby? (_.return (i64::i64 (_.+ parameter subject)))] + (with_vars [high low] + (all _.then + (_.set (list low) (_.+ (i32::low subject) + (i32::low parameter))) + (_.set (list high) (|> (i32::high low) + (_.+ (i32::high subject)) + (_.+ (i32::high parameter)) + i32::low)) + + (_.return (..i64 high (i32::low low))) + ))) + +(def i64::min + (_.manual "-0x8000000000000000")) + +(def (i64::opposite value) + (_.? (_.= i64::min value) + i64::min + (i64::+ (_.int +1) (_.bit_not value)))) + +(runtime + (i64::- parameter subject) + [..normal_ruby? (_.return (i64::i64 (_.- parameter subject)))] + (_.return (i64::+ (i64::opposite parameter) subject))) + +(def i16::high + (_.bit_shr (_.int +16))) + +(def i16::low + (_.bit_and (_.manual "+0xFFFF"))) + +(def i16::up + (_.bit_shl (_.int +16))) + +(runtime + (i64::* parameter subject) + [..normal_ruby? (_.return (i64::i64 (_.* parameter subject)))] + (let [hh (|>> i32::high i16::high) + hl (|>> i32::high i16::low) + lh (|>> i32::low i16::high) + ll (|>> i32::low i16::low)] + (with_vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00 + high low] + (all _.then + (_.set (list l48) (hh subject)) + (_.set (list l32) (hl subject)) + (_.set (list l16) (lh subject)) + (_.set (list l00) (ll subject)) + + (_.set (list r48) (hh parameter)) + (_.set (list r32) (hl parameter)) + (_.set (list r16) (lh parameter)) + (_.set (list r00) (ll parameter)) + + (_.set (list x00) (_.* l00 r00)) + (_.set (list x16) (i16::high x00)) + (_.set (list x00) (i16::low x00)) + + (_.set (list x16) (|> x16 (_.+ (_.* l16 r00)))) + (_.set (list x32) (i16::high x16)) (_.set (list x16) (i16::low x16)) + (_.set (list x16) (|> x16 (_.+ (_.* l00 r16)))) + (_.set (list x32) (|> x32 (_.+ (i16::high x16)))) (_.set (list x16) (i16::low x16)) + + (_.set (list x32) (|> x32 (_.+ (_.* l32 r00)))) + (_.set (list x48) (i16::high x32)) (_.set (list x32) (i16::low x32)) + (_.set (list x32) (|> x32 (_.+ (_.* l16 r16)))) + (_.set (list x48) (|> x48 (_.+ (i16::high x32)))) (_.set (list x32) (i16::low x32)) + (_.set (list x32) (|> x32 (_.+ (_.* l00 r32)))) + (_.set (list x48) (|> x48 (_.+ (i16::high x32)))) (_.set (list x32) (i16::low x32)) + + (_.set (list x48) (|> x48 + (_.+ (_.* l48 r00)) + (_.+ (_.* l32 r16)) + (_.+ (_.* l16 r32)) + (_.+ (_.* l00 r48)) + i16::low)) + + (_.set (list high) (_.bit_or (i16::up x48) x32)) + (_.set (list low) (_.bit_or (i16::up x16) x00)) + (_.return (..i64 high low)) + ))) + ) + +(runtime + (i64::char subject) + [..mruby? (_.return (_.do "chr" (list) {.#None} subject))] + (_.return (_.do "chr" (list (_.string "UTF-8")) {.#None} subject))) + +(def runtime//i64 + Statement + (all _.then + @i64::+iteration + @i64::-iteration + @i64::i64 + @i64::left_shifted + @i64::right_shifted + @i64::and + @i64::or + @i64::xor + @i64::+ + @i64::- + @i64::* + @i64::/ + @i64::char + )) + +(runtime + (f64//decode inputG) + (with_vars [@input @temp] + (all _.then + (_.set (list @input) inputG) + (_.set (list @temp) (_.do "to_f" (list) {.#None} @input)) + (_.if (all _.or + (_.not (_.= (_.float +0.0) @temp)) + (_.= (_.string "0") @input) + (_.= (_.string ".0") @input) + (_.= (_.string "0.0") @input)) + (_.return (..some @temp)) + (_.return ..none))))) + +(def runtime//f64 + Statement + (all _.then + @f64//decode + )) + +(runtime + (text//index subject param start) + (with_vars [idx] + (all _.then + (_.set (list idx) (|> subject (_.do "index" (list param start) {.#None}))) + (_.if (_.= _.nil idx) + (_.return ..none) + (_.return (..some idx)))))) + +(def (within? top value) + (-> Expression Expression Computation) + (_.and (|> value (_.>= (_.int +0))) + (|> value (_.< top)))) + +(runtime + (text//clip offset length text) + (_.if (_.= (_.int +0) length) + (_.return (_.string "")) + (_.return (_.array_range offset (_.+ offset (_.- (_.int +1) length)) text)))) + +(runtime + (text//char idx text) + (_.if (|> idx (within? (_.the "length" text))) + (_.return (|> text (_.array_range idx idx) (_.do "ord" (list) {.#None}))) + (_.statement (_.raise (_.string "[Lux Error] Cannot get char from text."))))) + +(def runtime//text + Statement + (all _.then + @text//index + @text//clip + @text//char + )) + +(runtime + (array//write idx value array) + (all _.then + (_.set (list (_.item idx array)) value) + (_.return array))) + +(def runtime//array + Statement + (all _.then + @array//write + )) + +(def runtime + Statement + (all _.then + (_.when ..mruby? + ... We're in DragonRuby territory. + (_.statement + (_.do "class_eval" (list) {.#Some [(list (_.local "_")) + (_.statement + (_.alias_method/2 (_.string "remainder") + (_.string "remainder_of_divide")))]} + $Numeric))) + runtime//adt + runtime//lux + runtime//i64 + runtime//f64 + runtime//text + runtime//array + )) + +(def .public generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! ..module_id {.#None} ..runtime)] + (in [(|> registry.empty + (registry.resource true unit.none) + product.right) + (sequence.sequence [..module_id + {.#None} + (|> ..runtime + _.code + (at utf8.codec encoded))])]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/structure.lux new file mode 100644 index 000000000..5947bc8c4 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/ruby/structure.lux @@ -0,0 +1,36 @@ +(.require + [library + [lux (.except Variant Tuple) + [abstract + ["[0]" monad (.only do)]] + [meta + [target + ["_" ruby (.only Expression)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" primitive] + ["///[1]" //// + [analysis + [complex (.only Variant Tuple)]] + ["[1][0]" synthesis (.only Synthesis)] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)]]]]) + +(def .public (tuple generate archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + {.#End} + (///////phase#in (//primitive.text /////synthesis.unit)) + + {.#Item singletonS {.#End}} + (generate archive singletonS) + + _ + (|> elemsS+ + (monad.each ///////phase.monad (generate archive)) + (///////phase#each _.array)))) + +(def .public (variant generate archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (///////phase#each (//runtime.variant lefts right?) + (generate archive valueS))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme.lux new file mode 100644 index 000000000..cdedd1a3d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme.lux @@ -0,0 +1,62 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [meta + [macro + ["^" pattern]] + [target + ["_" scheme]]]]] + ["[0]" / + [runtime (.only Phase)] + ["[1][0]" primitive] + ["[1][0]" structure] + ["[1][0]" reference] + ["[1][0]" case] + ["[1][0]" loop] + ["[1][0]" function] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" extension] + ["/[1]" // + [analysis (.only)] + ["[1][0]" synthesis] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference (.only) + [variable (.only)]]]]]]]) + +(def .public (generate archive synthesis) + Phase + (case synthesis + (^.with_template [<tag> <generator>] + [(<tag> value) + (//////phase#in (<generator> value))]) + ([////synthesis.bit /primitive.bit] + [////synthesis.i64 /primitive.i64] + [////synthesis.f64 /primitive.f64] + [////synthesis.text /primitive.text]) + + {////synthesis.#Reference value} + (//reference.reference /reference.system archive value) + + (^.with_template [<tag> <generator>] + [(<tag> value) + (<generator> generate archive value)]) + ([////synthesis.variant /structure.variant] + [////synthesis.tuple /structure.tuple] + [////synthesis.branch/let /case.let] + [////synthesis.branch/if /case.if] + [////synthesis.branch/get /case.get] + [////synthesis.function/apply /function.apply] + + [////synthesis.branch/case /case.case] + [////synthesis.loop/scope /loop.scope] + [////synthesis.loop/again /loop.again] + [////synthesis.function/abstraction /function.function]) + + {////synthesis.#Extension extension} + (///extension.apply archive generate extension) + )) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/case.lux new file mode 100644 index 000000000..a1f679836 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/case.lux @@ -0,0 +1,225 @@ +(.require + [library + [lux (.except case let if) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set]]] + [math + [number + ["i" int]]] + [meta + [macro + ["^" pattern] + ["[0]" template]] + [target + ["_" scheme (.only Expression Computation Var)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" reference] + ["[1][0]" primitive] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + ["[1][0]" synthesis + ["[1]/[0]" case]] + ["/[1]" // + ["[1][0]" synthesis (.only Member Synthesis Path)] + ["[1][0]" generation] + ["//[1]" /// + [reference + ["[1][0]" variable (.only Register)]] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [meta + [archive (.only Archive)]]]]]]]) + +(def .public register + (-> Register Var) + (|>> (///reference.local //reference.system) as_expected)) + +(def .public capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def .public (let expression archive [valueS register bodyS]) + (Generator [Synthesis Register Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS) + bodyO (expression archive bodyS)] + (in (_.let (list [(..register register) valueO]) + bodyO)))) + +(def .public (if expression archive [testS thenS elseS]) + (Generator [Synthesis Synthesis Synthesis]) + (do ///////phase.monad + [testO (expression archive testS) + thenO (expression archive thenS) + elseO (expression archive elseS)] + (in (_.if testO thenO elseO)))) + +(def .public (get expression archive [pathP valueS]) + (Generator [(List Member) Synthesis]) + (do ///////phase.monad + [valueO (expression archive valueS)] + (in (list#mix (function (_ side source) + (.let [method (.case side + (^.with_template [<side> <accessor>] + [(<side> lefts) + (<accessor> (_.int (.int lefts)))]) + ([.#Left //runtime.tuple//left] + [.#Right //runtime.tuple//right]))] + (method source))) + valueO + (list.reversed pathP))))) + +(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 (_.cdr/1 var))) + +(def save_cursor! + Computation + (push! @cursor @savepoint)) + +(def restore_cursor! + Computation + (_.begin (list (_.set! @cursor (_.car/1 @savepoint)) + (_.set! @savepoint (_.cdr/1 @savepoint))))) + +(def peek + Computation + (_.car/1 @cursor)) + +(def pop_cursor! + Computation + (pop! @cursor)) + +(def pm_error + (_.string (template.with_locals [pm_error] + (template.text [pm_error])))) + +(def fail! + (_.raise/1 pm_error)) + +(def (try_pm on_failure happy_path) + (-> Expression Expression Computation) + (_.guard @alt_error + (list [(_.and (list (_.string?/1 @alt_error) + (_.string=?/2 ..pm_error @alt_error))) + on_failure]) + {.#None} + happy_path)) + +(def (pattern_matching' expression archive) + (Generator Path) + (function (again pathP) + (.case pathP + {/////synthesis.#Then bodyS} + (expression archive bodyS) + + {/////synthesis.#Pop} + (///////phase#in pop_cursor!) + + {/////synthesis.#Bind register} + (///////phase#in (_.define_constant (..register register) ..peek)) + + {/////synthesis.#Bit_Fork when thenP elseP} + (do [! ///////phase.monad] + [then! (again thenP) + else! (.case elseP + {.#Some elseP} + (again elseP) + + {.#None} + (in ..fail!))] + (in (.if when + (_.if ..peek + then! + else!) + (_.if ..peek + else! + then!)))) + + (^.with_template [<tag> <format> <=>] + [{<tag> item} + (do [! ///////phase.monad] + [clauses (monad.each ! (function (_ [match then]) + (do ! + [then! (again then)] + (in [(<=> (|> match <format>) + ..peek) + then!]))) + {.#Item item})] + (in (list#mix (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)))]) + ([/////synthesis.#I64_Fork //primitive.i64 _.=/2] + [/////synthesis.#F64_Fork //primitive.f64 _.=/2] + [/////synthesis.#Text_Fork //primitive.text _.string=?/2]) + + (^.with_template [<pm> <flag> <prep>] + [(<pm> idx) + (///////phase#in (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek (_.bool <flag>)))]) + (_.if (_.null?/1 @temp) + ..fail! + (push_cursor! @temp))))]) + ([/////synthesis.side/left false (<|)] + [/////synthesis.side/right true ++]) + + (/////synthesis.member/left 0) + (///////phase#in (..push_cursor! (_.vector_ref/2 ..peek (_.int +0)))) + + (^.with_template [<pm> <getter>] + [(<pm> lefts) + (///////phase#in (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))]) + ([/////synthesis.member/left //runtime.tuple//left] + [/////synthesis.member/right //runtime.tuple//right]) + + (/////synthesis.path/seq leftP rightP) + (do ///////phase.monad + [leftO (again leftP) + rightO (again rightP)] + (in (_.begin (list leftO + rightO)))) + + (/////synthesis.path/alt leftP rightP) + (do [! ///////phase.monad] + [leftO (again leftP) + rightO (again rightP)] + (in (try_pm (_.begin (list restore_cursor! + rightO)) + (_.begin (list save_cursor! + leftO))))) + ))) + +(def (pattern_matching expression archive pathP) + (Generator Path) + (at ///////phase.monad each + (try_pm (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (pattern_matching' expression archive pathP))) + +(def .public (case expression archive [valueS pathP]) + (Generator [Synthesis Path]) + (do [! ///////phase.monad] + [valueO (expression archive valueS)] + (<| (at ! each (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/extension.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/extension.lux new file mode 100644 index 000000000..1d1c8473f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/extension.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [data + [collection + ["[0]" dictionary]]]]] + [// + [runtime (.only Bundle)]] + [/ + ["[0]" common]]) + +(def .public bundle + Bundle + common.bundle) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/extension/common.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/extension/common.lux new file mode 100644 index 000000000..0c86e0ee3 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/extension/common.lux @@ -0,0 +1,179 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" text] + [number (.only hex) + ["f" frac]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["dict" dictionary (.only Dictionary)]]] + [meta + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only with_symbols) + [syntax (.only syntax)]] + [target + ["_" scheme (.only Expression Computation)]]]]] + ["[0]" /// + ["[1][0]" runtime (.only Operation Phase Handler Bundle)] + ["[1]//" /// (.only) + ["[1][0]" extension (.only) + ["[0]" bundle]] + ["[1]/" // + ["[1][0]" synthesis (.only Synthesis)]]]]) + +(def bundle::lux + Bundle + (|> bundle.empty + (bundle.install "is?" (binary (product.uncurried _.eq?/2))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(with_template [<name> <op>] + [(def (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [i64::and _.bit_and/2] + [i64::or _.bit_or/2] + [i64::xor _.bit_xor/2] + ) + +(def (i64::left_shifted [subjectO paramO]) + Binary + (_.arithmetic_shift/2 (_.remainder/2 (_.int +64) paramO) + subjectO)) + +(def (i64::arithmetic_right_shifted [subjectO paramO]) + Binary + (_.arithmetic_shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) + subjectO)) + +(def (i64::logical_right_shifted [subjectO paramO]) + Binary + (///runtime.i64//logical_right_shifted (_.remainder/2 (_.int +64) paramO) subjectO)) + +(with_template [<name> <op>] + [(def (<name> [subjectO paramO]) + Binary + (|> subjectO (<op> paramO)))] + + [i64::+ _.+/2] + [i64::- _.-/2] + [i64::* _.*/2] + [i64::/ _.quotient/2] + [i64::% _.remainder/2] + ) + +(with_template [<name> <op>] + [(def (<name> [subjectO paramO]) + Binary + (<op> paramO subjectO))] + + [f64::+ _.+/2] + [f64::- _.-/2] + [f64::* _.*/2] + [f64::/ _.//2] + [f64::% _.mod/2] + [f64::= _.=/2] + [f64::< _.</2] + + [text::= _.string=?/2] + [text::< _.string<?/2] + ) + +(with_template [<name> <cmp>] + [(def (<name> [subjectO paramO]) + Binary + (<cmp> paramO subjectO))] + + [i64::= _.=/2] + [i64::< _.</2] + ) + +(def i64::char (|>> _.integer->char/1 _.string/1)) + +(def bundle::i64 + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary i64::and)) + (bundle.install "or" (binary i64::or)) + (bundle.install "xor" (binary i64::xor)) + (bundle.install "left-shift" (binary i64::left_shifted)) + (bundle.install "logical-right-shift" (binary i64::logical_right_shifted)) + (bundle.install "arithmetic-right-shift" (binary i64::arithmetic_right_shifted)) + (bundle.install "+" (binary i64::+)) + (bundle.install "-" (binary i64::-)) + (bundle.install "*" (binary i64::*)) + (bundle.install "/" (binary i64::/)) + (bundle.install "%" (binary i64::%)) + (bundle.install "=" (binary i64::=)) + (bundle.install "<" (binary i64::<)) + (bundle.install "f64" (unary (|>> (_.//2 (_.float +1.0))))) + (bundle.install "char" (unary i64::char))))) + +(def bundle::f64 + Bundle + (<| (bundle.prefix "f64") + (|> bundle.empty + (bundle.install "+" (binary f64::+)) + (bundle.install "-" (binary f64::-)) + (bundle.install "*" (binary f64::*)) + (bundle.install "/" (binary f64::/)) + (bundle.install "%" (binary f64::%)) + (bundle.install "=" (binary f64::=)) + (bundle.install "<" (binary f64::<)) + (bundle.install "i64" (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.uncurried _.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 .public bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle::lux + (dict.composite bundle::i64) + (dict.composite bundle::f64) + (dict.composite bundle::text) + (dict.composite bundle::io) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/function.lux new file mode 100644 index 000000000..cbddbab59 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/function.lux @@ -0,0 +1,102 @@ +(.require + [library + [lux (.except function) + [abstract + ["[0]" monad (.only do)]] + [control + pipe] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [meta + [target + ["_" scheme (.only Expression Computation Var)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" reference] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Variant Tuple Abstraction Application Analysis)] + [synthesis (.only Synthesis)] + ["[1][0]" generation (.only Context)] + ["//[1]" /// + [arity (.only Arity)] + ["[1][0]" phase (.use "[1]#[0]" monad)] + [reference + [variable (.only Register Variable)]]]]]]) + +(def .public (apply expression archive [functionS argsS+]) + (Generator (Application Synthesis)) + (do [! ///////phase.monad] + [functionO (expression archive functionS) + argsO+ (monad.each ! (expression archive) argsS+)] + (in (_.apply argsO+ functionO)))) + +(def capture + (-> Register Var) + (|>> (///reference.foreign //reference.system) as_expected)) + +(def (with_closure inits function_definition) + (-> (List Expression) Computation (Operation Computation)) + (///////phase#in + (case inits + {.#End} + function_definition + + _ + (|> function_definition + (_.lambda [(|> (list.enumeration inits) + (list#each (|>> product.left ..capture))) + {.#None}]) + (_.apply inits))))) + +(def @curried (_.var "curried")) +(def @missing (_.var "missing")) + +(def input + (|>> ++ //case.register)) + +(def .public (function expression archive [environment arity bodyS]) + (Generator (Abstraction Synthesis)) + (do [! ///////phase.monad] + [[function_name bodyO] (/////generation.with_new_context archive + (do ! + [@self (at ! each (|>> ///reference.artifact _.var) + (/////generation.context archive))] + (/////generation.with_anchor @self + (expression archive bodyS)))) + closureO+ (monad.each ! (expression archive) environment) + .let [arityO (|> arity .int _.int) + apply_poly (.function (_ args func) + (_.apply/2 (_.var "apply") func args)) + @num_args (_.var "num_args") + @self (_.var (///reference.artifact function_name))]] + (with_closure closureO+ + (_.letrec (list [@self (_.lambda [(list) {.#Some @curried}] + (_.let (list [@num_args (_.length/1 @curried)]) + (<| (_.if (|> @num_args (_.=/2 arityO)) + (<| (_.let (list [(//case.register 0) @self])) + (_.let_values (list [[(|> (list.indices arity) + (list#each ..input)) + {.#None}] + (_.apply/2 (_.var "apply") (_.var "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)] + (_.begin (list (|> @self + (apply_poly arity_args) + (apply_poly output_func_args)))))) + ... (|> @num_args (_.</2 arityO)) + (_.lambda [(list) {.#Some @missing}] + (|> @self + (apply_poly (_.append/2 @curried @missing))))) + ))]) + @self)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/loop.lux new file mode 100644 index 000000000..d8cf4511e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/loop.lux @@ -0,0 +1,65 @@ +(.require + [library + [lux (.except Scope) + [abstract + ["[0]" monad (.only do)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" set (.only Set)]]] + [math + [number + ["n" nat]]] + [meta + [target + ["_" scheme]]]]] + ["[0]" // + [runtime (.only Operation Phase Generator)] + ["[1][0]" case] + ["/[1]" // + ["[1][0]" reference] + ["/[1]" // + [synthesis + ["[0]" case]] + ["/[1]" // + ["[0]" synthesis (.only Scope Synthesis)] + ["[1][0]" generation] + ["//[1]" /// + ["[1][0]" phase] + [meta + [archive (.only Archive)]] + [reference + [variable (.only Register)]]]]]]]) + +(def @scope + (_.var "scope")) + +(def .public (scope expression archive [start initsS+ bodyS]) + (Generator (Scope Synthesis)) + (case initsS+ + ... function/false/non-independent loop + {.#End} + (expression archive bodyS) + + ... true loop + _ + (do [! ///////phase.monad] + [initsO+ (monad.each ! (expression archive) initsS+) + bodyO (/////generation.with_anchor @scope + (expression archive bodyS))] + (in (_.letrec (list [@scope (_.lambda [(|> initsS+ + list.enumeration + (list#each (|>> product.left (n.+ start) //case.register))) + {.#None}] + bodyO)]) + (_.apply initsO+ @scope)))))) + +(def .public (again expression archive argsS+) + (Generator (List Synthesis)) + (do [! ///////phase.monad] + [@scope /////generation.anchor + argsO+ (monad.each ! (expression archive) argsS+)] + (in (_.apply argsO+ @scope)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/primitive.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/primitive.lux new file mode 100644 index 000000000..707968187 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/primitive.lux @@ -0,0 +1,17 @@ +(.require + [library + [lux (.except i64) + [meta + [target + ["_" scheme (.only Expression)]]]]]) + +(with_template [<name> <type> <code>] + [(def .public <name> + (-> <type> Expression) + <code>)] + + [bit Bit _.bool] + [i64 (I64 Any) (|>> .int _.int)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/reference.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/reference.lux new file mode 100644 index 000000000..94bbd7702 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/reference.lux @@ -0,0 +1,14 @@ +(.require + [library + [lux (.except) + [meta + [target + ["_" scheme (.only Expression)]]]]] + [/// + [reference (.only System)]]) + +(def .public system + (System Expression) + (implementation + (def constant _.var) + (def variable _.var))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/runtime.lux new file mode 100644 index 000000000..31803cfab --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/runtime.lux @@ -0,0 +1,389 @@ +(.require + [library + [lux (.except Location) + [abstract + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" sequence]]] + [math + [number (.only hex) + ["[0]" i64]]] + ["[0]" meta (.only) + ["[0]" code (.only) + ["<[1]>" \\parser]] + ["[0]" macro (.only) + [syntax (.only syntax)]] + ["@" target (.only) + ["_" scheme (.only Expression Computation Var)]]]]] + ["[0]" /// + ["[1][0]" reference] + ["//[1]" /// + [analysis (.only Variant)] + ["[1][0]" synthesis (.only Synthesis)] + ["[1][0]" generation] + ["//[1]" /// (.only) + ["[1][0]" phase] + [reference + [variable (.only Register)]] + [meta + [archive (.only Output Archive) + ["[0]" artifact (.only Registry)]]]]]]) + +(def module_id + 0) + +(with_template [<name> <base>] + [(type .public <name> + (<base> Var Expression Expression))] + + [Operation /////generation.Operation] + [Phase /////generation.Phase] + [Handler /////generation.Handler] + [Bundle /////generation.Bundle] + ) + +(type .public (Generator i) + (-> Phase Archive i (Operation Expression))) + +(def .public unit + (_.string /////synthesis.unit)) + +(def .public with_vars + (syntax (_ [vars (<code>.tuple (<>.some <code>.local)) + body <code>.any]) + (do [! meta.monad] + [ids (monad.all ! (list.repeated (list.size vars) meta.seed))] + (in (list (` (let [(,* (|> vars + (list.zipped_2 ids) + (list#each (function (_ [id var]) + (list (code.local var) + (` (_.var (, (code.text (format "v" (%.nat id))))))))) + list.together))] + (, body)))))))) + +(def runtime + (syntax (_ [declaration (<>.or <code>.local + (<code>.form (<>.and <code>.local + (<>.some <code>.local)))) + code <code>.any]) + (do meta.monad + [runtime_id meta.seed] + (macro.with_symbols [g!_] + (let [runtime (code.local (///reference.artifact [..module_id runtime_id])) + runtime_name (` (_.var (, (code.text (%.code runtime)))))] + (case declaration + {.#Left name} + (let [g!name (code.local name)] + (in (list (` (def .public (, g!name) + Var + (, runtime_name))) + + (` (def (, (code.local (format "@" name))) + _.Computation + (_.define_constant (, runtime_name) (, code))))))) + + {.#Right [name inputs]} + (let [g!name (code.local name) + inputsC (list#each code.local inputs) + inputs_typesC (list#each (function.constant (` _.Expression)) + inputs)] + (in (list (` (def .public ((, g!name) (,* inputsC)) + (-> (,* inputs_typesC) _.Computation) + (_.apply (list (,* inputsC)) (, runtime_name)))) + + (` (def (, (code.local (format "@" name))) + _.Computation + (..with_vars [(,* inputsC)] + (_.define_function (, runtime_name) [(list (,* inputsC)) {.#None}] + (, code)))))))))))))) + +(def last_index + (-> Expression Computation) + (|>> _.length/1 (_.-/2 (_.int +1)))) + +(runtime + (tuple//left lefts tuple) + (with_vars [last_index_right] + (_.begin + (list (_.define_constant last_index_right (..last_index tuple)) + (_.if (_.>/2 lefts last_index_right) + ... No need for recursion + (_.vector_ref/2 tuple lefts) + ... Needs recursion + (tuple//left (_.-/2 last_index_right lefts) + (_.vector_ref/2 tuple last_index_right))))))) + +(runtime + (tuple//right lefts tuple) + (with_vars [last_index_right right_index @slice] + (_.begin + (list (_.define_constant last_index_right (..last_index tuple)) + (_.define_constant right_index (_.+/2 (_.int +1) lefts)) + (<| (_.if (_.=/2 last_index_right right_index) + (_.vector_ref/2 tuple right_index)) + (_.if (_.>/2 last_index_right right_index) + ... Needs recursion. + (tuple//right (_.-/2 last_index_right lefts) + (_.vector_ref/2 tuple last_index_right))) + (_.begin + (list (_.define_constant @slice (_.make_vector/1 (_.-/2 right_index (_.length/1 tuple)))) + (_.vector_copy!/5 @slice (_.int +0) tuple right_index (_.length/1 tuple)) + @slice)))) + ))) + +(def (variant' tag last? value) + (-> Expression Expression Expression Computation) + (all _.cons/2 + tag + last? + value)) + +(runtime + (sum//make tag last? value) + (variant' tag last? value)) + +(def .public (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (..sum//make (_.int (.int lefts)) (_.bool right?) value)) + +(runtime + (sum//get sum last? wanted_tag) + (with_vars [sum_tag sum_flag sum_value sum_temp sum_dump] + (let [no_match _.nil + test_recursion (_.if sum_flag + ... Must recurse. + (sum//get sum_value + last? + (|> wanted_tag (_.-/2 sum_tag))) + no_match)] + (<| (_.let (list [sum_tag (_.car/1 sum)] + [sum_temp (_.cdr/1 sum)])) + (_.let (list [sum_flag (_.car/1 sum_temp)] + [sum_value (_.cdr/1 sum_temp)])) + (_.if (_.=/2 wanted_tag sum_tag) + (_.if (_.eqv?/2 last? sum_flag) + sum_value + test_recursion)) + (_.if (_.</2 wanted_tag sum_tag) + test_recursion) + (_.if last? + (variant' (|> sum_tag (_.-/2 wanted_tag)) sum_flag sum_value)) + no_match)))) + +(def runtime//adt + Computation + (_.begin (list @tuple//left + @tuple//right + @sum//get + @sum//make))) + +(def .public none + Computation + (|> ..unit [0 #0] variant)) + +(def .public some + (-> Expression Computation) + (|>> [1 #1] ..variant)) + +(def .public left + (-> Expression Computation) + (|>> [0 #0] ..variant)) + +(def .public right + (-> Expression Computation) + (|>> [1 #1] ..variant)) + +(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)) + +(runtime + (lux//try op) + (with_vars [error] + (_.with_exception_handler + (_.lambda [(list error) {.#None}] + (..left error)) + (_.lambda [(list) {.#None}] + (..right (_.apply (list ..unit) op)))))) + +(runtime + (lux//program_args program_args) + (with_vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) {.#None}] + (_.if (_.null?/1 @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 i64//+limit (_.manual "+9223372036854775807" + ... "+0x7FFFFFFFFFFFFFFF" + )) +(def i64//-limit (_.manual "-9223372036854775808" + ... "-0x8000000000000000" + )) +(def i64//+iteration (_.manual "+18446744073709551616" + ... "+0x10000000000000000" + )) +(def i64//-iteration (_.manual "-18446744073709551616" + ... "-0x10000000000000000" + )) +(def i64//+cap (_.manual "+9223372036854775808" + ... "+0x8000000000000000" + )) +(def i64//-cap (_.manual "-9223372036854775809" + ... "-0x8000000000000001" + )) + +(runtime + (i64//64 input) + (with_vars [temp] + (`` (<| (,, (with_template [<scenario> <iteration> <cap> <entrance>] + [(_.if (|> input <scenario>) + (_.let (list [temp (_.remainder/2 <iteration> input)]) + (_.if (|> temp <scenario>) + (|> temp (_.-/2 <cap>) (_.+/2 <entrance>)) + temp)))] + + [(_.>/2 ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit] + [(_.</2 ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit] + )) + input)))) + +(runtime + (i64//left_shifted param subject) + (|> subject + (_.arithmetic_shift/2 (_.remainder/2 (_.int +64) param)) + ..i64//64)) + +(def as_nat + (_.remainder/2 ..i64//+iteration)) + +(runtime + (i64//right_shifted shift subject) + (_.let (list [shift (_.remainder/2 (_.int +64) shift)]) + (_.if (_.=/2 (_.int +0) shift) + subject + (|> subject + ..as_nat + (_.arithmetic_shift/2 (_.-/2 shift (_.int +0))))))) + +(with_template [<runtime> <host>] + [(runtime + (<runtime> left right) + (..i64//64 (<host> (..as_nat left) (..as_nat right))))] + + [i64//or _.bitwise_ior/2] + [i64//xor _.bitwise_xor/2] + [i64//and _.bitwise_and/2] + ) + +(runtime + (i64//division param subject) + (|> subject (_.//2 param) _.truncate/1 ..i64//64)) + +(def runtime//i64 + Computation + (_.begin (list @i64//64 + @i64//left_shifted + @i64//right_shifted + @i64//or + @i64//xor + @i64//and + @i64//division))) + +(runtime + (f64//decode input) + (with_vars [@output] + (let [output_is_not_a_number? (_.not/1 (_.=/2 @output @output)) + input_is_not_a_number? (_.string=?/2 (_.string "+nan.0") input)] + (_.let (list [@output (_.string->number/1 input)]) + (_.if (_.and (list output_is_not_a_number? + (_.not/1 input_is_not_a_number?))) + ..none + (..some @output)))))) + +(def runtime//f64 + Computation + (_.begin (list @f64//decode))) + +(runtime + (text//index offset sub text) + (with_vars [index] + (_.let (list [index (_.string_contains/3 text sub offset)]) + (_.if index + (..some index) + ..none)))) + +(runtime + (text//clip offset length text) + (_.substring/3 text offset (_.+/2 offset length))) + +(runtime + (text//char index text) + (_.char->integer/1 (_.string_ref/2 text index))) + +(def runtime//text + (_.begin (list @text//index + @text//clip + @text//char))) + +(runtime + (array//write idx value array) + (_.begin (list (_.vector_set!/3 array idx value) + array))) + +(def runtime//array + Computation + (all _.then + @array//write + )) + +(def runtime + Computation + (_.begin (list @slice + runtime//lux + runtime//i64 + runtime//adt + runtime//f64 + runtime//text + runtime//array + ))) + +(def .public generate + (Operation [Registry Output]) + (do ///////phase.monad + [_ (/////generation.execute! ..runtime) + _ (/////generation.save! (%.nat ..module_id) ..runtime)] + (in [(|> artifact.empty + artifact.resource + product.right) + (sequence.sequence [(%.nat ..module_id) + (|> ..runtime + _.code + (at utf8.codec encoded))])]))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/structure.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/structure.lux new file mode 100644 index 000000000..e98aa8ff4 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/generation/scheme/structure.lux @@ -0,0 +1,41 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [data + [collection + ["[0]" list]]] + [meta + [target + ["_" scheme (.only Expression)]]]]] + ["[0]" // + ["[1][0]" runtime (.only Operation Phase Generator)] + ["[1][0]" primitive] + ["///[1]" //// + [analysis (.only Variant Tuple)] + ["[1][0]" synthesis (.only Synthesis)] + ["//[1]" /// + ["[1][0]" phase (.use "[1]#[0]" monad)]]]]) + +(def .public (tuple expression archive elemsS+) + (Generator (Tuple Synthesis)) + (case elemsS+ + {.#End} + (///////phase#in (//primitive.text /////synthesis.unit)) + + {.#Item singletonS {.#End}} + (expression archive singletonS) + + _ + (|> elemsS+ + (monad.each ///////phase.monad (expression archive)) + (///////phase#each _.vector/*)))) + +(def .public (variant expression archive [lefts right? valueS]) + (Generator (Variant Synthesis)) + (let [tag (if right? + (++ lefts) + lefts)] + (///////phase#each (|>> [tag right?] //runtime.variant) + (expression archive valueS)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis.lux new file mode 100644 index 000000000..b21dbdaae --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis.lux @@ -0,0 +1,110 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" pipe] + ["[0]" try]] + [data + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" dictionary (.only Dictionary)]]] + [meta + [macro + ["^" pattern]]]]] + ["[0]" / + ["[1][0]" function] + ["[1][0]" case] + ["[1][0]" variable] + ["/[1]" // + ["[1][0]" extension] + ["/[1]" // + ["/" synthesis (.only Synthesis Phase) + ["[1][0]" simple]] + ["[1][0]" analysis (.only Analysis) + ["[2][0]" simple] + ["[2][0]" complex]] + [/// + ["[0]" phase (.use "[1]#[0]" monad)] + [reference (.only) + [variable (.only)]]]]]]) + +(def (simple analysis) + (-> ///simple.Simple /simple.Simple) + (case analysis + {///simple.#Unit} + {/simple.#Text /.unit} + + (^.with_template [<analysis> <synthesis>] + [{<analysis> value} + {<synthesis> value}]) + ([///simple.#Bit /simple.#Bit] + [///simple.#Frac /simple.#F64] + [///simple.#Text /simple.#Text]) + + (^.with_template [<analysis> <synthesis>] + [{<analysis> value} + {<synthesis> (.i64 value)}]) + ([///simple.#Nat /simple.#I64] + [///simple.#Int /simple.#I64] + [///simple.#Rev /simple.#I64]))) + +(def (optimization archive) + Phase + (function (optimization' analysis) + (case analysis + {///analysis.#Simple analysis'} + (phase#in {/.#Simple (..simple analysis')}) + + {///analysis.#Reference reference} + (phase#in {/.#Reference reference}) + + {///analysis.#Structure structure} + (/.with_currying? false + (case structure + {///complex.#Variant variant} + (do phase.monad + [valueS (optimization' (the ///complex.#value variant))] + (in (/.variant (has ///complex.#value valueS variant)))) + + {///complex.#Tuple tuple} + (|> tuple + (monad.each phase.monad optimization') + (phase#each (|>> /.tuple))))) + + {///analysis.#Case inputA branchesAB+} + (/.with_currying? false + (/case.synthesize optimization branchesAB+ archive inputA)) + + (///analysis.no_op value) + (optimization' value) + + {///analysis.#Apply _} + (/.with_currying? false + (/function.apply optimization archive analysis)) + + {///analysis.#Function environmentA bodyA} + (/function.abstraction optimization environmentA archive bodyA) + + {///analysis.#Extension name args} + (/.with_currying? false + (function (_ state) + (|> (//extension.apply archive optimization [name args]) + (phase.result' state) + (pipe.case + {try.#Success output} + {try.#Success output} + + {try.#Failure _} + (|> args + (monad.each phase.monad optimization') + (phase#each (|>> [name] {/.#Extension})) + (phase.result' state)))))) + ))) + +(def .public (phase archive analysis) + Phase + (do phase.monad + [synthesis (..optimization archive analysis)] + (phase.lifted (/variable.optimization synthesis)))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/case.lux new file mode 100644 index 000000000..e755791ab --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/case.lux @@ -0,0 +1,467 @@ +(.require + [library + [lux (.except Pattern) + [abstract + [equivalence (.only Equivalence)] + ["[0]" monad (.only do)]] + [control + ["[0]" pipe]] + [data + ["[0]" product] + ["[0]" bit (.use "[1]#[0]" equivalence)] + ["[0]" text (.use "[1]#[0]" equivalence)] + [collection + ["[0]" list (.use "[1]#[0]" functor mix monoid)] + ["[0]" set (.only Set)]]] + [math + [number + ["n" nat] + ["[0]" i64] + ["[0]" frac]]] + [meta + [macro + ["^" pattern]]]]] + ["[0]" /// + [// + ["[1][0]" analysis (.only Match Analysis) + ["[2][0]" simple] + ["[2][0]" complex] + ["[2][0]" pattern (.only Pattern)]] + ["/" synthesis (.only Path Synthesis Operation Phase) + ["[1][0]" access (.only) + ["[2][0]" side] + ["[2][0]" member (.only Member)]]] + [/// + ["[1]" phase (.use "[1]#[0]" monad)] + ["[1][0]" reference (.only) + ["[1]/[0]" variable (.only Register Variable)]] + [meta + [archive (.only Archive)]]]]]) + +(def clean_up + (-> Path Path) + (|>> {/.#Seq {/.#Pop}})) + +(def (path' pattern end? thenC) + (-> Pattern Bit (Operation Path) (Operation Path)) + (case pattern + {///pattern.#Simple simple} + (case simple + {///simple.#Unit} + thenC + + {///simple.#Bit when} + (///#each (function (_ then) + {/.#Bit_Fork when then {.#None}}) + thenC) + + (^.with_template [<from> <to> <conversion>] + [{<from> test} + (///#each (function (_ then) + {<to> [(<conversion> test) then] (list)}) + thenC)]) + ([///simple.#Nat /.#I64_Fork .i64] + [///simple.#Int /.#I64_Fork .i64] + [///simple.#Rev /.#I64_Fork .i64] + [///simple.#Frac /.#F64_Fork |>] + [///simple.#Text /.#Text_Fork |>])) + + {///pattern.#Bind register} + (<| (at ///.monad each (|>> {/.#Seq {/.#Bind register}})) + /.with_new_local + thenC) + + {///pattern.#Complex {///complex.#Variant [lefts right? value_pattern]}} + (<| (///#each (|>> {/.#Seq {/.#Access {/access.#Side [/side.#lefts lefts + /side.#right? right?]}}})) + (path' value_pattern end?) + (pipe.when [(pipe.new (not end?) [])] [(///#each ..clean_up)]) + thenC) + + {///pattern.#Complex {///complex.#Tuple tuple}} + (let [tuple::last (-- (list.size tuple))] + (list#mix (function (_ [tuple::lefts tuple::member] nextC) + (.case tuple::member + {///pattern.#Simple {///simple.#Unit}} + nextC + + _ + (let [right? (n.= tuple::last tuple::lefts) + end?' (and end? right?)] + (<| (///#each (|>> {/.#Seq {/.#Access {/access.#Member [/member.#lefts (if right? + (-- tuple::lefts) + tuple::lefts) + /member.#right? right?]}}})) + (path' tuple::member end?') + (pipe.when [(pipe.new (not end?') [])] [(///#each ..clean_up)]) + nextC)))) + thenC + (list.reversed (list.enumeration tuple)))) + )) + +(def (path archive synthesize pattern bodyA) + (-> Archive Phase Pattern Analysis (Operation Path)) + (path' pattern true (///#each (|>> {/.#Then}) (synthesize archive bodyA)))) + +(def (weave_branch weave equivalence [new_test new_then] [[old_test old_then] old_tail]) + (All (_ a) + (-> (-> Path Path Path) (Equivalence a) [a Path] (/.Fork a Path) + (/.Fork a Path))) + (if (at equivalence = new_test old_test) + [[old_test (weave new_then old_then)] old_tail] + [[old_test old_then] + (case old_tail + {.#End} + (list [new_test new_then]) + + {.#Item old_item} + {.#Item (weave_branch weave equivalence [new_test new_then] old_item)})])) + +(def (weave_fork weave equivalence new_fork old_fork) + (All (_ a) + (-> (-> Path Path Path) (Equivalence a) (/.Fork a Path) (/.Fork a Path) + (/.Fork a Path))) + (list#mix (..weave_branch weave equivalence) old_fork {.#Item new_fork})) + +(def (weave new old) + (-> Path Path Path) + (with_expansions [<default> (these {/.#Alt old new})] + (case [new old] + [_ + {/.#Alt old_left old_right}] + {/.#Alt old_left + (weave new old_right)} + + [{/.#Seq preN postN} + {/.#Seq preO postO}] + (case (weave preN preO) + {/.#Alt _} + <default> + + woven + {/.#Seq woven (weave postN postO)}) + + [{/.#Pop} {/.#Pop}] + old + + [{/.#Bit_Fork new_when new_then new_else} + {/.#Bit_Fork old_when old_then old_else}] + (if (bit#= new_when old_when) + {/.#Bit_Fork old_when + (weave new_then old_then) + (case [new_else old_else] + [{.#None} {.#None}] + {.#None} + + (^.or [{.#Some woven_then} {.#None}] + [{.#None} {.#Some woven_then}]) + {.#Some woven_then} + + [{.#Some new_else} {.#Some old_else}] + {.#Some (weave new_else old_else)})} + {/.#Bit_Fork old_when + (case new_else + {.#None} + old_then + + {.#Some new_else} + (weave new_else old_then)) + {.#Some (case old_else + {.#None} + new_then + + {.#Some old_else} + (weave new_then old_else))}}) + + (^.with_template [<tag> <equivalence>] + [[{<tag> new_fork} {<tag> old_fork}] + {<tag> (..weave_fork weave <equivalence> new_fork old_fork)}]) + ([/.#I64_Fork i64.equivalence] + [/.#F64_Fork frac.equivalence] + [/.#Text_Fork text.equivalence]) + + (^.with_template [<access> <side> <lefts> <right?>] + [[{/.#Access {<access> [<lefts> newL <right?> <side>]}} + {/.#Access {<access> [<lefts> oldL <right?> <side>]}}] + (if (n.= newL oldL) + old + <default>)]) + ([/access.#Side #0 /side.#lefts /side.#right?] + [/access.#Side #1 /side.#lefts /side.#right?] + + [/access.#Member #0 /member.#lefts /member.#right?] + [/access.#Member #1 /member.#lefts /member.#right?]) + + [{/.#Bind newR} {/.#Bind oldR}] + (if (n.= newR oldR) + old + <default>) + + _ + <default>))) + +(def (get patterns @selection) + (-> (///complex.Tuple Pattern) Register (List Member)) + (loop (again [lefts 0 + patterns patterns]) + (with_expansions [<failure> (these (list)) + <continue> (these (again (++ lefts) + tail)) + <member> (these (let [right? (list.empty? tail)] + [/member.#lefts (if right? + (-- lefts) + lefts) + /member.#right? right?]))] + (case patterns + {.#End} + <failure> + + {.#Item head tail} + (case head + {///pattern.#Simple {///simple.#Unit}} + <continue> + + {///pattern.#Bind register} + (if (n.= @selection register) + (list <member>) + <continue>) + + {///pattern.#Complex {///complex.#Tuple sub_patterns}} + (case (get sub_patterns @selection) + {.#End} + <continue> + + sub_members + (list.partial <member> sub_members)) + + _ + <failure>))))) + +(def .public (synthesize_case synthesize archive input [[headP headA] tailPA+]) + (-> Phase Archive Synthesis Match (Operation Synthesis)) + (do [! ///.monad] + [headSP (path archive synthesize headP headA) + tailSP+ (monad.each ! (product.uncurried (path archive synthesize)) tailPA+)] + (in (/.branch/case [input (list#mix weave headSP tailSP+)])))) + +(def !masking + (template (_ <variable> <output>) + [[[{///pattern.#Bind <variable>} + {///analysis.#Reference (///reference.local <output>)}] + (list)]])) + +(def .public (synthesize_exec synthesize archive before after) + (-> Phase Archive Synthesis Analysis (Operation Synthesis)) + (do ///.monad + [after (synthesize archive after)] + (in (/.branch/exec [before after])))) + +(def .public (synthesize_let synthesize archive input @variable body) + (-> Phase Archive Synthesis Register Analysis (Operation Synthesis)) + (do ///.monad + [body (/.with_new_local + (synthesize archive body))] + (in (/.branch/let [input @variable body])))) + +(def .public (synthesize_masking synthesize archive input @variable @output) + (-> Phase Archive Synthesis Register Register (Operation Synthesis)) + (if (n.= @variable @output) + (///#in input) + (..synthesize_let synthesize archive input @variable {///analysis.#Reference (///reference.local @output)}))) + +(def .public (synthesize_if synthesize archive test then else) + (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis)) + (do ///.monad + [then (synthesize archive then) + else (synthesize archive else)] + (in (/.branch/if [test then else])))) + +(def !get + (template (_ <patterns> <output>) + [[[(///pattern.tuple <patterns>) + {///analysis.#Reference (///reference.local <output>)}] + (.list)]])) + +(def .public (synthesize_get synthesize archive input patterns @member) + (-> Phase Archive Synthesis (///complex.Tuple Pattern) Register (Operation Synthesis)) + (case (..get patterns @member) + {.#End} + (..synthesize_case synthesize archive input (!get patterns @member)) + + path + (case input + (/.branch/get [sub_path sub_input]) + (///#in (/.branch/get [(list#composite path sub_path) sub_input])) + + _ + (///#in (/.branch/get [path input]))))) + +(def .public (synthesize synthesize^ [headB tailB+] archive inputA) + (-> Phase Match Phase) + (do [! ///.monad] + [inputS (synthesize^ archive inputA)] + (case [headB tailB+] + (!masking @variable @output) + (..synthesize_masking synthesize^ archive inputS @variable @output) + + [[(///pattern.unit) body] + {.#End}] + (case inputA + (^.or {///analysis.#Simple _} + {///analysis.#Structure _} + {///analysis.#Reference _}) + (synthesize^ archive body) + + _ + (..synthesize_exec synthesize^ archive inputS body)) + + [[{///pattern.#Bind @variable} body] + {.#End}] + (..synthesize_let synthesize^ archive inputS @variable body) + + (^.or [[(///pattern.bit #1) then] + (list [(///pattern.bit #0) else])] + [[(///pattern.bit #1) then] + (list [(///pattern.unit) else])] + + [[(///pattern.bit #0) else] + (list [(///pattern.bit #1) then])] + [[(///pattern.bit #0) else] + (list [(///pattern.unit) then])]) + (..synthesize_if synthesize^ archive inputS then else) + + (!get patterns @member) + (..synthesize_get synthesize^ archive inputS patterns @member) + + match + (..synthesize_case synthesize^ archive inputS match)))) + +(def .public (count_pops path) + (-> Path [Nat Path]) + (case path + (/.path/seq {/.#Pop} path') + (let [[pops post_pops] (count_pops path')] + [(++ pops) post_pops]) + + _ + [0 path])) + +(def .public pattern_matching_error + "Invalid expression for pattern-matching.") + +(type .public Storage + (Record + [#bindings (Set Register) + #dependencies (Set Variable)])) + +(def empty + Storage + [#bindings (set.empty n.hash) + #dependencies (set.empty ///reference/variable.hash)]) + +... TODO: Use this to declare all local variables at the beginning of +... script functions. +... That way, it should be possible to do cheap "let" expressions, +... since the variable will exist beforehand, so no closure will need +... to be created for it. +... Apply this trick to JS, Python et al. +(def .public (storage path) + (-> Path Storage) + (loop (for_path [path path + path_storage ..empty]) + (case path + (^.or {/.#Pop} + {/.#Access Access}) + path_storage + + (/.path/bind register) + (revised #bindings (set.has register) + path_storage) + + {/.#Bit_Fork _ default otherwise} + (|> (case otherwise + {.#None} + path_storage + + {.#Some otherwise} + (for_path otherwise path_storage)) + (for_path default)) + + (^.or {/.#I64_Fork forks} + {/.#F64_Fork forks} + {/.#Text_Fork forks}) + (|> {.#Item forks} + (list#each product.right) + (list#mix for_path path_storage)) + + (^.or (/.path/seq left right) + (/.path/alt left right)) + (list#mix for_path path_storage (list left right)) + + (/.path/then bodyS) + (loop (for_synthesis [bodyS bodyS + synthesis_storage path_storage]) + (case bodyS + (^.or {/.#Simple _} + (/.constant _)) + synthesis_storage + + (/.variant [lefts right? valueS]) + (for_synthesis valueS synthesis_storage) + + (/.tuple members) + (list#mix for_synthesis synthesis_storage members) + + {/.#Reference {///reference.#Variable {///reference/variable.#Local register}}} + (if (set.member? (the #bindings synthesis_storage) register) + synthesis_storage + (revised #dependencies (set.has {///reference/variable.#Local register}) synthesis_storage)) + + {/.#Reference {///reference.#Variable var}} + (revised #dependencies (set.has var) synthesis_storage) + + (/.function/apply [functionS argsS]) + (list#mix for_synthesis synthesis_storage {.#Item functionS argsS}) + + (/.function/abstraction [environment arity bodyS]) + (list#mix for_synthesis synthesis_storage environment) + + (/.branch/case [inputS pathS]) + (revised #dependencies + (set.union (the #dependencies (for_path pathS synthesis_storage))) + (for_synthesis inputS synthesis_storage)) + + (/.branch/exec [before after]) + (list#mix for_synthesis synthesis_storage (list before after)) + + (/.branch/let [inputS register exprS]) + (revised #dependencies + (set.union (|> synthesis_storage + (revised #bindings (set.has register)) + (for_synthesis exprS) + (the #dependencies))) + (for_synthesis inputS synthesis_storage)) + + (/.branch/if [testS thenS elseS]) + (list#mix for_synthesis synthesis_storage (list testS thenS elseS)) + + (/.branch/get [access whole]) + (for_synthesis whole synthesis_storage) + + (/.loop/scope [start initsS+ iterationS]) + (revised #dependencies + (set.union (|> synthesis_storage + (revised #bindings (set.union (|> initsS+ + list.enumeration + (list#each (|>> product.left (n.+ start))) + (set.of_list n.hash)))) + (for_synthesis iterationS) + (the #dependencies))) + (list#mix for_synthesis synthesis_storage initsS+)) + + (/.loop/again replacementsS+) + (list#mix for_synthesis synthesis_storage replacementsS+) + + {/.#Extension [extension argsS]} + (list#mix for_synthesis synthesis_storage argsS))) + ))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/function.lux new file mode 100644 index 000000000..a97634d68 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/function.lux @@ -0,0 +1,291 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)] + ["[0]" enum]] + [control + ["[0]" pipe] + ["[0]" maybe (.use "[1]#[0]" functor)] + ["[0]" exception (.only exception)]] + [data + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor monoid)]]] + [math + [number + ["n" nat]]] + [meta + [macro + ["^" pattern]]]]] + ["[0]" // + ["[1][0]" loop (.only Transform)] + ["//[1]" /// + ["[1][0]" analysis (.only Environment Analysis) + ["[1]/[0]" complex]] + ["/" synthesis (.only Path Abstraction Synthesis Operation Phase)] + [/// + [arity (.only Arity)] + ["[0]" phase (.use "[1]#[0]" monad)] + ["[1][0]" reference (.only) + ["[1]/[0]" variable (.only Register Variable)]]]]]) + +(exception .public (cannot_find_foreign_variable_in_environment [foreign Register + environment (Environment Synthesis)]) + (exception.report + "Foreign" (%.nat foreign) + "Environment" (exception.listing /.%synthesis environment))) + +(def arity_arguments + (-> Arity (List Synthesis)) + (|>> -- + (enum.range n.enum 1) + (list#each (|>> /.variable/local)))) + +(def .public self_reference + (template (self_reference) + [(/.variable/local 0)])) + +(def (expanded_nested_self_reference arity) + (-> Arity Synthesis) + (/.function/apply [(..self_reference) (arity_arguments arity)])) + +(def .public (apply phase) + (-> Phase Phase) + (function (_ archive exprA) + (let [[funcA argsA] (////analysis.reification exprA)] + (do [! phase.monad] + [funcS (phase archive funcA) + argsS (monad.each ! (phase archive) argsA)] + (with_expansions [<apply> (these (/.function/apply [funcS argsS]))] + (case funcS + (/.function/abstraction functionS) + (if (n.= (the /.#arity functionS) + (list.size argsS)) + (do ! + [locals /.locals] + (in (|> functionS + (//loop.optimization true locals argsS) + (maybe#each (is (-> [Nat (List Synthesis) Synthesis] Synthesis) + (function (_ [start inits iteration]) + (case iteration + (/.loop/scope [start' inits' output]) + (if (and (n.= start start') + (list.empty? inits')) + (/.loop/scope [start inits output]) + (/.loop/scope [start inits iteration])) + + _ + (/.loop/scope [start inits iteration]))))) + (maybe.else <apply>)))) + (in <apply>)) + + (/.function/apply [funcS' argsS']) + (in (/.function/apply [funcS' (list#composite argsS' argsS)])) + + _ + (in <apply>))))))) + +(def (find_foreign environment register) + (-> (Environment Synthesis) Register (Operation Synthesis)) + (case (list.item register environment) + {.#Some aliased} + (phase#in aliased) + + {.#None} + (phase.except ..cannot_find_foreign_variable_in_environment [register environment]))) + +(def (grow_path grow path) + (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) + (case path + {/.#Bind register} + (phase#in {/.#Bind (++ register)}) + + (^.with_template [<tag>] + [{<tag> left right} + (do phase.monad + [left' (grow_path grow left) + right' (grow_path grow right)] + (in {<tag> left' right'}))]) + ([/.#Alt] [/.#Seq]) + + {/.#Bit_Fork when then else} + (do [! phase.monad] + [then (grow_path grow then) + else (case else + {.#Some else} + (at ! each (|>> {.#Some}) (grow_path grow else)) + + {.#None} + (in {.#None}))] + (in {/.#Bit_Fork when then else})) + + (^.with_template [<tag>] + [{<tag> [[test then] elses]} + (do [! phase.monad] + [then (grow_path grow then) + elses (monad.each ! (function (_ [else_test else_then]) + (do ! + [else_then (grow_path grow else_then)] + (in [else_test else_then]))) + elses)] + (in {<tag> [[test then] elses]}))]) + ([/.#I64_Fork] + [/.#F64_Fork] + [/.#Text_Fork]) + + {/.#Then thenS} + (|> thenS + grow + (phase#each (|>> {/.#Then}))) + + _ + (phase#in path))) + +(def (grow environment expression) + (-> (Environment Synthesis) Synthesis (Operation Synthesis)) + (case expression + {/.#Structure structure} + (case structure + {////analysis/complex.#Variant [lefts right? subS]} + (|> subS + (grow environment) + (phase#each (|>> [lefts right?] /.variant))) + + {////analysis/complex.#Tuple membersS+} + (|> membersS+ + (monad.each phase.monad (grow environment)) + (phase#each (|>> /.tuple)))) + + (..self_reference) + (phase#in (/.function/apply [expression (list (/.variable/local 1))])) + + {/.#Reference reference} + (case reference + {////reference.#Variable variable} + (case variable + {////reference/variable.#Local register} + (phase#in (/.variable/local (++ register))) + + {////reference/variable.#Foreign register} + (..find_foreign environment register)) + + {////reference.#Constant constant} + (phase#in expression)) + + {/.#Control control} + (case control + {/.#Branch branch} + (case branch + {/.#Exec [this that]} + (do phase.monad + [this (grow environment this) + that (grow environment that)] + (in (/.branch/exec [this that]))) + + {/.#Let [inputS register bodyS]} + (do phase.monad + [inputS' (grow environment inputS) + bodyS' (grow environment bodyS)] + (in (/.branch/let [inputS' (++ register) bodyS']))) + + {/.#If [testS thenS elseS]} + (do phase.monad + [testS' (grow environment testS) + thenS' (grow environment thenS) + elseS' (grow environment elseS)] + (in (/.branch/if [testS' thenS' elseS']))) + + {/.#Get members inputS} + (do phase.monad + [inputS' (grow environment inputS)] + (in (/.branch/get [members inputS']))) + + {/.#Case [inputS pathS]} + (do phase.monad + [inputS' (grow environment inputS) + pathS' (grow_path (grow environment) pathS)] + (in (/.branch/case [inputS' pathS'])))) + + {/.#Loop loop} + (case loop + {/.#Scope [start initsS+ iterationS]} + (do [! phase.monad] + [initsS+' (monad.each ! (grow environment) initsS+) + iterationS' (grow environment iterationS)] + (in (/.loop/scope [(++ start) initsS+' iterationS']))) + + {/.#Again argumentsS+} + (|> argumentsS+ + (monad.each phase.monad (grow environment)) + (phase#each (|>> /.loop/again)))) + + {/.#Function function} + (case function + {/.#Abstraction [_env _arity _body]} + (do [! phase.monad] + [_env' (monad.each ! + (|>> (pipe.case + {/.#Reference {////reference.#Variable {////reference/variable.#Foreign register}}} + (..find_foreign environment register) + + captured + (grow environment captured))) + _env)] + (in (/.function/abstraction [_env' _arity _body]))) + + {/.#Apply funcS argsS+} + (do [! phase.monad] + [funcS (grow environment funcS) + argsS+ (monad.each ! (grow environment) argsS+)] + (in (/.function/apply (case funcS + (/.function/apply [(..self_reference) pre_argsS+]) + [(..self_reference) + (list#composite pre_argsS+ argsS+)] + + _ + [funcS + argsS+])))))) + + {/.#Extension name argumentsS+} + (|> argumentsS+ + (monad.each phase.monad (grow environment)) + (phase#each (|>> {/.#Extension name}))) + + {/.#Simple _} + (phase#in expression))) + +(def .public (abstraction phase environment archive bodyA) + (-> Phase (Environment Analysis) Phase) + (do [! phase.monad] + [environment (monad.each ! (phase archive) environment) + bodyS (/.with_currying? true + (/.with_locals 2 + (phase archive bodyA))) + abstraction (is (Operation Abstraction) + (case bodyS + (/.function/abstraction [env' down_arity' bodyS']) + (|> bodyS' + (grow env') + (at ! each (function (_ body) + [/.#environment environment + /.#arity (++ down_arity') + /.#body body]))) + + _ + (in [/.#environment environment + /.#arity 1 + /.#body bodyS]))) + currying? /.currying?] + (in (/.function/abstraction + (if currying? + abstraction + (case (//loop.optimization false 1 (list) abstraction) + {.#Some [startL initsL bodyL]} + [/.#environment environment + /.#arity (the /.#arity abstraction) + /.#body (/.loop/scope [startL initsL bodyL])] + + {.#None} + abstraction)))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/loop.lux new file mode 100644 index 000000000..c967930bf --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/loop.lux @@ -0,0 +1,219 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" maybe (.use "[1]#[0]" monad)]] + [data + [collection + ["[0]" list]]] + [math + [number + ["n" nat]]] + [meta + [macro + ["^" pattern]]]]] + [//// + ["[0]" analysis (.only Environment) + ["[1]/[0]" complex]] + ["/" synthesis (.only Path Abstraction Synthesis)] + [/// + [arity (.only Arity)] + ["[0]" reference (.only) + ["[0]" variable (.only Register Variable)]]]]) + +(type .public (Transform a) + (-> a (Maybe a))) + +(def .public (register_optimization offset) + (-> Register (-> Register Register)) + (|>> -- (n.+ offset))) + +(def (path_optimization body_optimization offset) + (-> (Transform Synthesis) Register (Transform Path)) + (function (again path) + (case path + {/.#Bind register} + {.#Some {/.#Bind (register_optimization offset register)}} + + (^.with_template [<tag>] + [{<tag> left right} + (do maybe.monad + [left' (again left) + right' (again right)] + (in {<tag> left' right'}))]) + ([/.#Alt] [/.#Seq]) + + {/.#Bit_Fork when then else} + (do [! maybe.monad] + [then (again then) + else (case else + {.#Some else} + (at ! each (|>> {.#Some}) (again else)) + + {.#None} + (in {.#None}))] + (in {/.#Bit_Fork when then else})) + + (^.with_template [<tag>] + [{<tag> [[test then] elses]} + (do [! maybe.monad] + [then (again then) + elses (monad.each ! (function (_ [else_test else_then]) + (do ! + [else_then (again else_then)] + (in [else_test else_then]))) + elses)] + (in {<tag> [[test then] elses]}))]) + ([/.#I64_Fork] + [/.#F64_Fork] + [/.#Text_Fork]) + + {/.#Then body} + (|> body + body_optimization + (maybe#each (|>> {/.#Then}))) + + _ + {.#Some path}))) + +(def (body_optimization true_loop? offset scope_environment arity expr) + (-> Bit Register (Environment Synthesis) Arity (Transform Synthesis)) + (loop (again [return? true + expr expr]) + (case expr + {/.#Simple _} + {.#Some expr} + + {/.#Structure structure} + (case structure + {analysis/complex.#Variant variant} + (do maybe.monad + [value' (|> variant (the analysis/complex.#value) (again false))] + (in (|> variant + (has analysis/complex.#value value') + /.variant))) + + {analysis/complex.#Tuple tuple} + (|> tuple + (monad.each maybe.monad (again false)) + (maybe#each (|>> /.tuple)))) + + {/.#Reference reference} + (case reference + {reference.#Variable (variable.self)} + (if true_loop? + {.#None} + {.#Some expr}) + + (reference.constant constant) + {.#Some expr} + + (reference.local register) + {.#Some {/.#Reference (reference.local (register_optimization offset register))}} + + (reference.foreign register) + (if true_loop? + (list.item register scope_environment) + {.#Some expr})) + + (/.branch/case [input path]) + (do maybe.monad + [input' (again false input) + path' (path_optimization (again return?) offset path)] + (in (|> path' [input'] /.branch/case))) + + (/.branch/exec [this that]) + (do maybe.monad + [this (again false this) + that (again return? that)] + (in (/.branch/exec [this that]))) + + (/.branch/let [input register body]) + (do maybe.monad + [input' (again false input) + body' (again return? body)] + (in (/.branch/let [input' (register_optimization offset register) body']))) + + (/.branch/if [input then else]) + (do maybe.monad + [input' (again false input) + then' (again return? then) + else' (again return? else)] + (in (/.branch/if [input' then' else']))) + + (/.branch/get [path record]) + (do maybe.monad + [record (again false record)] + (in (/.branch/get [path record]))) + + (/.loop/scope scope) + (do [! maybe.monad] + [inits' (|> scope + (the /.#inits) + (monad.each ! (again false))) + iteration' (again return? (the /.#iteration scope))] + (in (/.loop/scope [/.#start (|> scope (the /.#start) (register_optimization offset)) + /.#inits inits' + /.#iteration iteration']))) + + (/.loop/again args) + (|> args + (monad.each maybe.monad (again false)) + (maybe#each (|>> /.loop/again))) + + (/.function/abstraction [environment arity body]) + (do [! maybe.monad] + [environment' (monad.each ! (again false) environment)] + (in (/.function/abstraction [environment' arity body]))) + + (/.function/apply [abstraction arguments]) + (do [! maybe.monad] + [arguments' (monad.each ! (again false) arguments)] + (with_expansions [<application> (these (do ! + [abstraction' (again false abstraction)] + (in (/.function/apply [abstraction' arguments']))))] + (case abstraction + {/.#Reference {reference.#Variable (variable.self)}} + (if (and return? + (n.= arity (list.size arguments))) + (in (/.loop/again arguments')) + (if true_loop? + {.#None} + <application>)) + + _ + <application>))) + + ... TODO: Stop relying on this custom code. + {/.#Extension ["lux syntax char case!" (list.partial input else matches)]} + (if return? + (do [! maybe.monad] + [input (again false input) + matches (monad.each ! + (function (_ match) + (case match + {/.#Structure {analysis/complex.#Tuple (list when then)}} + (do ! + [when (again false when) + then (again return? then)] + (in {/.#Structure {analysis/complex.#Tuple (list when then)}})) + + _ + (again false match))) + matches) + else (again return? else)] + (in {/.#Extension ["lux syntax char case!" (list.partial input else matches)]})) + {.#None}) + + {/.#Extension [name args]} + (|> args + (monad.each maybe.monad (again false)) + (maybe#each (|>> [name] {/.#Extension})))))) + +(def .public (optimization true_loop? offset inits functionS) + (-> Bit Register (List Synthesis) Abstraction (Maybe [Register (List Synthesis) Synthesis])) + (|> (the /.#body functionS) + (body_optimization true_loop? offset (the /.#environment functionS) (the /.#arity functionS)) + (maybe#each (|>> [offset inits])))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/variable.lux new file mode 100644 index 000000000..80fce0c79 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/phase/synthesis/variable.lux @@ -0,0 +1,457 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" maybe (.use "[1]#[0]" functor)] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format]] + [collection + ["[0]" dictionary (.only Dictionary)] + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" set]]] + [math + [number + ["n" nat]]] + [meta + [macro + ["^" pattern]]]]] + [//// + ["[0]" analysis (.only) + ["[1]/[0]" complex]] + ["/" synthesis (.only Path Synthesis) + ["[1][0]" access]] + [/// + [arity (.only Arity)] + ["[0]" reference (.only) + ["[0]" variable (.only Register Variable)]]]]) + +(def (prune redundant register) + (-> Register Register Register) + (if (n.> redundant register) + (-- register) + register)) + +(type (Remover a) + (-> Register (-> a a))) + +(def (remove_local_from_path remove_local redundant) + (-> (Remover Synthesis) (Remover Path)) + (function (again path) + (case path + {/.#Seq {/.#Bind register} + post} + (if (n.= redundant register) + (again post) + {/.#Seq {/.#Bind (if (n.> redundant register) + (-- register) + register)} + (again post)}) + + (^.or {/.#Seq {/.#Access {/access.#Member member}} + {/.#Seq {/.#Bind register} + post}} + ... This alternative form should never occur in practice. + ... Yet, it is "technically" possible to construct it. + {/.#Seq {/.#Seq {/.#Access {/access.#Member member}} + {/.#Bind register}} + post}) + (if (n.= redundant register) + (again post) + {/.#Seq {/.#Access {/access.#Member member}} + {/.#Seq {/.#Bind (if (n.> redundant register) + (-- register) + register)} + (again post)}}) + + (^.with_template [<tag>] + [{<tag> left right} + {<tag> (again left) (again right)}]) + ([/.#Seq] + [/.#Alt]) + + {/.#Bit_Fork when then else} + {/.#Bit_Fork when (again then) (maybe#each again else)} + + (^.with_template [<tag>] + [{<tag> [[test then] tail]} + {<tag> [[test (again then)] + (list#each (function (_ [test' then']) + [test' (again then')]) + tail)]}]) + ([/.#I64_Fork] + [/.#F64_Fork] + [/.#Text_Fork]) + + (^.or {/.#Pop} + {/.#Access _}) + path + + {/.#Bind register} + (undefined) + + {/.#Then then} + {/.#Then (remove_local redundant then)} + ))) + +(def (remove_local_from_variable redundant variable) + (Remover Variable) + (case variable + {variable.#Local register} + {variable.#Local (..prune redundant register)} + + {variable.#Foreign register} + variable)) + +(def (remove_local redundant) + (Remover Synthesis) + (function (again synthesis) + (case synthesis + {/.#Simple _} + synthesis + + {/.#Structure structure} + {/.#Structure (case structure + {analysis/complex.#Variant [lefts right value]} + {analysis/complex.#Variant [lefts right (again value)]} + + {analysis/complex.#Tuple tuple} + {analysis/complex.#Tuple (list#each again tuple)})} + + {/.#Reference reference} + (case reference + {reference.#Variable variable} + (/.variable (..remove_local_from_variable redundant variable)) + + {reference.#Constant constant} + synthesis) + + {/.#Control control} + {/.#Control (case control + {/.#Branch branch} + {/.#Branch (case branch + {/.#Exec this that} + {/.#Exec (again this) + (again that)} + + {/.#Let input register output} + {/.#Let (again input) + (..prune redundant register) + (again output)} + + {/.#If test then else} + {/.#If (again test) (again then) (again else)} + + {/.#Get path record} + {/.#Get path (again record)} + + {/.#Case input path} + {/.#Case (again input) (remove_local_from_path remove_local redundant path)})} + + {/.#Loop loop} + {/.#Loop (case loop + {/.#Scope [start inits iteration]} + {/.#Scope [(..prune redundant start) + (list#each again inits) + (again iteration)]} + + {/.#Again resets} + {/.#Again (list#each again resets)})} + + {/.#Function function} + {/.#Function (case function + {/.#Abstraction [environment arity body]} + {/.#Abstraction [(list#each again environment) + arity + body]} + + {/.#Apply abstraction inputs} + {/.#Apply (again abstraction) (list#each again inputs)})})} + + {/.#Extension name inputs} + {/.#Extension name (list#each again inputs)}))) + +(type Redundancy + (Dictionary Register Bit)) + +(def initial + Redundancy + (dictionary.empty n.hash)) + +(def redundant! true) +(def necessary! false) + +(def (extended offset amount redundancy) + (-> Register Nat Redundancy [(List Register) Redundancy]) + (let [extension (|> amount list.indices (list#each (n.+ offset)))] + [extension + (list#mix (function (_ register redundancy) + (dictionary.has register ..necessary! redundancy)) + redundancy + extension)])) + +(def (default arity) + (-> Arity Redundancy) + (product.right (..extended 0 (++ arity) ..initial))) + +(type (Optimization a) + (-> [Redundancy a] (Try [Redundancy a]))) + +(def (list_optimization optimization) + (All (_ a) (-> (Optimization a) (Optimization (List a)))) + (function (again [redundancy values]) + (case values + {.#End} + {try.#Success [redundancy + values]} + + {.#Item head tail} + (do try.monad + [[redundancy head] (optimization [redundancy head]) + [redundancy tail] (again [redundancy tail])] + (in [redundancy + {.#Item head tail}]))))) + +(with_template [<name>] + [(exception .public (<name> [register Register]) + (exception.report + "Register" (%.nat register)))] + + [redundant_declaration] + [unknown_register] + ) + +(def (declare register redundancy) + (-> Register Redundancy (Try Redundancy)) + (case (dictionary.value register redundancy) + {.#None} + {try.#Success (dictionary.has register ..redundant! redundancy)} + + {.#Some _} + (exception.except ..redundant_declaration [register]))) + +(def (observe register redundancy) + (-> Register Redundancy (Try Redundancy)) + (case (dictionary.value register redundancy) + {.#None} + (exception.except ..unknown_register [register]) + + {.#Some _} + {try.#Success (dictionary.has register ..necessary! redundancy)})) + +(def (format redundancy) + (%.Format Redundancy) + (|> redundancy + dictionary.entries + (list#each (function (_ [register redundant?]) + (%.format (%.nat register) ": " (%.bit redundant?)))) + (text.interposed ", "))) + +(def (path_optimization optimization) + (-> (Optimization Synthesis) (Optimization Path)) + (function (again [redundancy path]) + (case path + (^.or {/.#Pop} + {/.#Access _}) + {try.#Success [redundancy + path]} + + {/.#Bit_Fork when then else} + (do [! try.monad] + [[redundancy then] (again [redundancy then]) + [redundancy else] (case else + {.#Some else} + (at ! each + (function (_ [redundancy else]) + [redundancy {.#Some else}]) + (again [redundancy else])) + + {.#None} + (in [redundancy {.#None}]))] + (in [redundancy {/.#Bit_Fork when then else}])) + + (^.with_template [<tag> <type>] + [{<tag> [[test then] elses]} + (do [! try.monad] + [[redundancy then] (again [redundancy then]) + [redundancy elses] (..list_optimization (is (Optimization [<type> Path]) + (function (_ [redundancy [else_test else_then]]) + (do ! + [[redundancy else_then] (again [redundancy else_then])] + (in [redundancy [else_test else_then]])))) + [redundancy elses])] + (in [redundancy {<tag> [[test then] elses]}]))]) + ([/.#I64_Fork I64] + [/.#F64_Fork Frac] + [/.#Text_Fork Text]) + + {/.#Bind register} + (do try.monad + [redundancy (..declare register redundancy)] + (in [redundancy + path])) + + {/.#Alt left right} + (do try.monad + [[redundancy left] (again [redundancy left]) + [redundancy right] (again [redundancy right])] + (in [redundancy {/.#Alt left right}])) + + {/.#Seq pre post} + (do try.monad + [.let [baseline (|> redundancy + dictionary.keys + (set.of_list n.hash))] + [redundancy pre] (again [redundancy pre]) + .let [bindings (|> redundancy + dictionary.keys + (set.of_list n.hash) + (set.difference baseline))] + [redundancy post] (again [redundancy post]) + .let [redundants (|> redundancy + dictionary.entries + (list.only (function (_ [register redundant?]) + (and (set.member? bindings register) + redundant?))) + (list#each product.left))]] + (in [(list#mix dictionary.lacks redundancy (set.list bindings)) + (|> redundants + (list.sorted n.>) + (list#mix (..remove_local_from_path ..remove_local) {/.#Seq pre post}))])) + + {/.#Then then} + (do try.monad + [[redundancy then] (optimization [redundancy then])] + (in [redundancy {/.#Then then}])) + ))) + +(def (optimization' [redundancy synthesis]) + (Optimization Synthesis) + (with_expansions [<no_op> (these {try.#Success [redundancy + synthesis]})] + (case synthesis + {/.#Simple _} + <no_op> + + {/.#Structure structure} + (case structure + {analysis/complex.#Variant [lefts right value]} + (do try.monad + [[redundancy value] (optimization' [redundancy value])] + (in [redundancy + {/.#Structure {analysis/complex.#Variant [lefts right value]}}])) + + {analysis/complex.#Tuple tuple} + (do try.monad + [[redundancy tuple] (..list_optimization optimization' [redundancy tuple])] + (in [redundancy + {/.#Structure {analysis/complex.#Tuple tuple}}]))) + + {/.#Reference reference} + (case reference + {reference.#Variable variable} + (case variable + {variable.#Local register} + (do try.monad + [redundancy (..observe register redundancy)] + <no_op>) + + {variable.#Foreign register} + <no_op>) + + {reference.#Constant constant} + <no_op>) + + {/.#Control control} + (case control + {/.#Branch branch} + (case branch + {/.#Exec this that} + (do try.monad + [[redundancy this] (optimization' [redundancy this]) + [redundancy that] (optimization' [redundancy that])] + (in [redundancy + (/.branch/exec [this that])])) + + {/.#Let input register output} + (do try.monad + [[redundancy input] (optimization' [redundancy input]) + redundancy (..declare register redundancy) + [redundancy output] (optimization' [redundancy output]) + .let [redundant? (|> redundancy + (dictionary.value register) + (maybe.else ..necessary!))]] + (in [(dictionary.lacks register redundancy) + {/.#Control {/.#Branch (if redundant? + {/.#Exec input (..remove_local register output)} + {/.#Let input register output})}}])) + + {/.#If test then else} + (do try.monad + [[redundancy test] (optimization' [redundancy test]) + [redundancy then] (optimization' [redundancy then]) + [redundancy else] (optimization' [redundancy else])] + (in [redundancy + {/.#Control {/.#Branch {/.#If test then else}}}])) + + {/.#Get path record} + (do try.monad + [[redundancy record] (optimization' [redundancy record])] + (in [redundancy + {/.#Control {/.#Branch {/.#Get path record}}}])) + + {/.#Case input path} + (do try.monad + [[redundancy input] (optimization' [redundancy input]) + [redundancy path] (..path_optimization optimization' [redundancy path])] + (in [redundancy + {/.#Control {/.#Branch {/.#Case input path}}}]))) + + {/.#Loop loop} + (case loop + {/.#Scope [start inits iteration]} + (do try.monad + [[redundancy inits] (..list_optimization optimization' [redundancy inits]) + .let [[extension redundancy] (..extended start (list.size inits) redundancy)] + [redundancy iteration] (optimization' [redundancy iteration])] + (in [(list#mix dictionary.lacks redundancy extension) + {/.#Control {/.#Loop {/.#Scope [start inits iteration]}}}])) + + {/.#Again resets} + (do try.monad + [[redundancy resets] (..list_optimization optimization' [redundancy resets])] + (in [redundancy + {/.#Control {/.#Loop {/.#Again resets}}}]))) + + {/.#Function function} + (case function + {/.#Abstraction [environment arity body]} + (do [! try.monad] + [[redundancy environment] (..list_optimization optimization' [redundancy environment]) + [_ body] (optimization' [(..default arity) body])] + (in [redundancy + {/.#Control {/.#Function {/.#Abstraction [environment arity body]}}}])) + + {/.#Apply abstraction inputs} + (do try.monad + [[redundancy abstraction] (optimization' [redundancy abstraction]) + [redundancy inputs] (..list_optimization optimization' [redundancy inputs])] + (in [redundancy + {/.#Control {/.#Function {/.#Apply abstraction inputs}}}])))) + + {/.#Extension name inputs} + (do try.monad + [[redundancy inputs] (..list_optimization optimization' [redundancy inputs])] + (in [redundancy + {/.#Extension name inputs}]))))) + +(def .public optimization + (-> Synthesis (Try Synthesis)) + (|>> [..initial] + optimization' + (at try.monad each product.right))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/program.lux b/stdlib/source/library/lux/meta/compiler/language/lux/program.lux new file mode 100644 index 000000000..9b9c15e3f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/program.lux @@ -0,0 +1,57 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" maybe] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]]]] + [//// + [meta + ["[0]" archive (.only Archive) + ["[0]" registry (.only Registry)] + ["[0]" unit] + [module + ["[0]" descriptor]]]]]) + +(type .public (Program expression declaration) + (-> unit.ID expression declaration)) + +(def .public name + Text + "") + +(exception .public (cannot_find_program [modules (List descriptor.Module)]) + (exception.report + "Modules" (exception.listing %.text modules))) + +(def .public (context archive) + (-> Archive (Try unit.ID)) + (do [! try.monad] + [registries (|> archive + archive.archived + (monad.each ! + (function (_ module) + (do ! + [id (archive.id module archive) + [_module output registry] (archive.find module archive)] + (in [[module id] registry])))))] + (case (list.one (function (_ [[module module_id] registry]) + (do maybe.monad + [program_id (registry.id ..name registry)] + (in [module_id program_id]))) + registries) + {.#Some program_context} + (in program_context) + + {.#None} + (|> registries + (list#each (|>> product.left product.left)) + (exception.except ..cannot_find_program))))) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/syntax.lux b/stdlib/source/library/lux/meta/compiler/language/lux/syntax.lux new file mode 100644 index 000000000..922ab5495 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/syntax.lux @@ -0,0 +1,621 @@ +... This is LuxC's parser. +... It takes the source code of a Lux file in raw text form and +... extracts the syntactic structure of the code from it. +... It only produces Lux Code nodes, and thus removes any white-space +... and comments while processing its inputs. + +... Another important aspect of the parser is that it keeps track of +... its position within the input data. +... That is, the parser takes into account the line and column +... information in the input text (it doesn't really touch the +... file-name aspect of the location, leaving it intact in whatever +... base-line location it is given). + +... This particular piece of functionality is not located in one +... function, but it is instead scattered throughout several parsers, +... since the logic for how to update the location varies, depending on +... what is being parsed, and the rules involved. + +... You will notice that several parsers have a "where" parameter, that +... tells them the location position prior to the parser being run. +... They are supposed to produce some parsed output, alongside an +... updated location pointing to the end position, after the parser was run. + +... Lux Code nodes/tokens are annotated with location meta-data +... [file-name, line, column] to keep track of their provenance and +... location, which is helpful for documentation and debugging. +(.require + [library + [lux (.except prelude) + [abstract + [monad (.only do)]] + [control + ["<>" parser] + ["[0]" maybe] + ["[0]" exception (.only exception)]] + [data + ["[0]" text (.only) + [\\parser (.only Offset)] + ["%" \\format (.only format)]] + [collection + ["[0]" list] + ["[0]" dictionary (.only Dictionary)]]] + [meta + ["@" target] + ["[0]" symbol] + ["[0]" code + ["<[1]>" \\parser]] + [macro + [syntax (.only syntax)] + ["[0]" template]]] + [math + [number + ["n" nat] + ["[0]" int] + ["[0]" rev] + ["[0]" frac]]]]]) + +(def declaration_name + (syntax (_ [[name parameters] (<code>.form (<>.and <code>.any (<>.some <code>.any)))]) + (in (list name)))) + +(def inlined + (template (_ <declaration> <type> <body>) + [(for @.python (def <declaration> <type> <body>) + ... TODO: No longer skip inlining Lua after Rembulan isn't being used anymore. + @.lua (def <declaration> <type> <body>) + (`` (def (,, (..declaration_name <declaration>)) + (template <declaration> + [<body>]))))])) + +... TODO: Implement "lux syntax char case!" as a custom extension. +... That way, it should be possible to obtain the char without wrapping +... it into a java.lang.Long, thereby improving performance. + +... TODO: Make an extension to take advantage of java/lang/String::indexOf<int,int> +... to get better performance than the current "lux text index" extension. + +... TODO: Instead of always keeping a "where" location variable, keep the +... individual components (i.e. file, line and column) separate, so +... that updated the "where" only involved updating the components, and +... producing the locations only involved building them, without any need +... for pattern-matching and de-structuring. + +(type Char + Nat) + +(with_template [<extension> <diff> <name>] + [(def <name> + (template (_ value) + [(<extension> <diff> value)]))] + + ["lux i64 +" 1 !++] + ["lux i64 +" 2 !++/2] + ["lux i64 -" 1 !--] + ) + +(def !clip + (template (_ from to text) + [("lux text clip" from (n.- from to) text)])) + +(with_template [<name> <extension>] + [(def <name> + (template (_ reference subject) + [(<extension> reference subject)]))] + + [!n/= "lux i64 ="] + [!i/< "lux i64 <"] + ) + +(with_template [<name> <extension>] + [(def <name> + (template (_ param subject) + [(<extension> param subject)]))] + + [!n/+ "lux i64 +"] + [!n/- "lux i64 -"] + ) + +(type .public Aliases + (Dictionary Text Text)) + +(def .public no_aliases + Aliases + (dictionary.empty text.hash)) + +(def .public prelude + .prelude) + +(def .public text_delimiter text.double_quote) + +(with_template [<char> <definition>] + [(def .public <definition> <char>)] + + ... Form delimiters + ["(" open_form] + [")" close_form] + + ... Variant delimiters + ["{" open_variant] + ["}" close_variant] + + ... Tuple delimiters + ["[" open_tuple] + ["]" close_tuple] + + ["#" sigil] + + ["," digit_separator] + + ["+" positive_sign] + ["-" negative_sign] + + ["." frac_separator] + + ... The parts of a name are separated by a single mark. + ... E.g. module.short. + ... Only one such mark may be used in an name, since there + ... can only be 2 parts to a name (the module [before the + ... mark], and the short [after the mark]). + ... There are also some extra rules regarding name syntax, + ... encoded in the parser. + [symbol.separator symbol_separator] + ) + +(exception .public (end_of_file [module Text]) + (exception.report + "Module" (%.text module))) + +(def amount_of_input_shown 64) + +(inlined (input_at start input) + (-> Offset Text Text) + (let [end (|> start (!n/+ amount_of_input_shown) (n.min ("lux text size" input)))] + (!clip start end input))) + +(exception .public (unrecognized_input [[file line column] Location + context Text + input Text + offset Offset]) + (exception.report + "File" file + "Line" (%.nat line) + "Column" (%.nat column) + "Context" (%.text context) + "Input" (input_at offset input))) + +(exception .public (text_cannot_contain_new_lines [text Text]) + (exception.report + "Text" (%.text text))) + +(def !failure + (template (_ parser where offset source_code) + [{.#Left [[where offset source_code] + (exception.error ..unrecognized_input [where (%.symbol (symbol parser)) source_code offset])]}])) + +(def !end_of_file + (template (_ where offset source_code current_module) + [{.#Left [[where offset source_code] + (exception.error ..end_of_file current_module)]}])) + +(type (Parser a) + (-> Source (Either [Source Text] [Source a]))) + +(def !with_char+ + (template (_ @source_code_size @source_code @offset @char @else @body) + [(if (!i/< (as Int @source_code_size) + (as Int @offset)) + (let [@char ("lux text char" @offset @source_code)] + @body) + @else)])) + +(def !with_char + (template (_ @source_code @offset @char @else @body) + [(!with_char+ ("lux text size" @source_code) @source_code @offset @char @else @body)])) + +(def !letE + (template (_ <binding> <computation> <body>) + [(case <computation> + {.#Right <binding>} + <body> + + ... {.#Left error} + <<otherwise>> + (as_expected <<otherwise>>))])) + +(def !horizontal + (template (_ where offset source_code) + [[(revised .#column ++ where) + (!++ offset) + source_code]])) + +(inlined (!new_line where) + (-> Location Location) + (let [[where::file where::line where::column] where] + [where::file (!++ where::line) 0])) + +(inlined (!forward length where) + (-> Nat Location Location) + (let [[where::file where::line where::column] where] + [where::file where::line (!n/+ length where::column)])) + +(def !vertical + (template (_ where offset source_code) + [[(!new_line where) + (!++ offset) + source_code]])) + +(with_template [<name> <close> <tag>] + [(inlined (<name> parse where offset source_code) + (-> (Parser Code) Location Offset Text + (Either [Source Text] [Source Code])) + (loop (again [source (is Source [(!forward 1 where) offset source_code]) + stack (is (List Code) {.#End})]) + (case (parse source) + {.#Right [source' top]} + (again source' {.#Item top stack}) + + {.#Left [source' error]} + (if (same? <close> error) + {.#Right [source' + [where {<tag> (list.reversed stack)}]]} + {.#Left [source' error]}))))] + + ... Form and tuple syntax is mostly the same, differing only in the + ... delimiters involved. + ... They may have an arbitrary number of arbitrary Code nodes as elements. + [form_parser ..close_form .#Form] + [variant_parser ..close_variant .#Variant] + [tuple_parser ..close_tuple .#Tuple] + ) + +(def !guarantee_no_new_lines + (template (_ where offset source_code content body) + [(case ("lux text index" 0 (static text.new_line) content) + {.#None} + body + + g!_ + {.#Left [[where offset source_code] + (exception.error ..text_cannot_contain_new_lines content)]})])) + +(def (text_parser where offset source_code) + (-> Location Offset Text (Either [Source Text] [Source Code])) + (case ("lux text index" offset (static ..text_delimiter) source_code) + {.#Some g!end} + (<| (let [g!content (!clip offset g!end source_code)]) + (!guarantee_no_new_lines where offset source_code g!content) + {.#Right [[(let [size (!n/- offset g!end)] + (revised .#column (|>> (!n/+ size) (!n/+ 2)) where)) + (!++ g!end) + source_code] + [where + {.#Text g!content}]]}) + + _ + (!failure ..text_parser where offset source_code))) + +(with_expansions [<digits> (these "0" "1" "2" "3" "4" "5" "6" "7" "8" "9") + <non_symbol_chars> (with_template [<char>] + [(,, (static <char>))] + + [text.space] + [text.new_line] [text.carriage_return] + [..symbol_separator] + [..open_form] [..close_form] + [..open_variant] [..close_variant] + [..open_tuple] [..close_tuple] + [..text_delimiter]) + <digit_separator> (static ..digit_separator)] + (def !if_digit? + (template (_ @char @then @else) + [("lux syntax char case!" @char + [[<digits>] + @then] + + ... else + @else)])) + + (def !if_digit?+ + (template (_ @char @then @else_options @else) + [(`` ("lux syntax char case!" @char + [[<digits> <digit_separator>] + @then + + (,, (template.spliced @else_options))] + + ... else + @else))])) + + (`` (def !if_symbol_char?|tail + (template (_ @char @then @else) + [("lux syntax char case!" @char + [[<non_symbol_chars>] + @else] + + ... else + @then)]))) + + (`` (def !if_symbol_char?|head + (template (_ @char @then @else) + [("lux syntax char case!" @char + [[<non_symbol_chars> <digits>] + @else] + + ... else + @then)]))) + ) + +(def !number_output + (template (_ <source_code> <start> <end> <codec> <tag>) + [(case (|> <source_code> + (!clip <start> <end>) + (text.replaced ..digit_separator "") + (at <codec> decoded)) + {.#Right output} + {.#Right [[(let [[where::file where::line where::column] where] + [where::file where::line (!n/+ (!n/- <start> <end>) where::column)]) + <end> + <source_code>] + [where {<tag> output}]]} + + {.#Left error} + {.#Left [[where <start> <source_code>] + error]})])) + +(def no_exponent + Offset + 0) + +(with_expansions [<int_output> (these (!number_output source_code start end int.decimal .#Int)) + <frac_output> (these (!number_output source_code start end frac.decimal .#Frac)) + <failure> (!failure ..frac_parser where offset source_code) + <frac_separator> (static ..frac_separator) + <signs> (with_template [<sign>] + [(,, (static <sign>))] + + [..positive_sign] + [..negative_sign])] + (inlined (frac_parser source_code//size start where offset source_code) + (-> Nat Nat Location Offset Text + (Either [Source Text] [Source Code])) + (loop (again [end offset + exponent (static ..no_exponent)]) + (<| (!with_char+ source_code//size source_code end char/0 <frac_output>) + (!if_digit?+ char/0 + (again (!++ end) exponent) + + [["e" "E"] + (if (same? (static ..no_exponent) exponent) + (<| (!with_char+ source_code//size source_code (!++ end) char/1 <failure>) + (`` ("lux syntax char case!" char/1 + [[<signs>] + (<| (!with_char+ source_code//size source_code (!n/+ 2 end) char/2 <failure>) + (!if_digit?+ char/2 + (again (!n/+ 3 end) char/0) + [] + <failure>))] + ... else + <failure>))) + <frac_output>)] + + <frac_output>)))) + + (inlined (signed_parser source_code//size start where offset source_code) + (-> Nat Nat Location Offset Text + (Either [Source Text] [Source Code])) + (loop (again [end offset]) + (<| (!with_char+ source_code//size source_code end char <int_output>) + (!if_digit?+ char + (again (!++ end)) + + [[<frac_separator>] + (frac_parser source_code//size start where (!++ end) source_code)] + + <int_output>)))) + ) + +(with_template [<parser> <codec> <tag>] + [(inlined (<parser> source_code//size start where offset source_code) + (-> Nat Nat Location Offset Text + (Either [Source Text] [Source Code])) + (loop (again [g!end offset]) + (<| (!with_char+ source_code//size source_code g!end g!char (!number_output source_code start g!end <codec> <tag>)) + (!if_digit?+ g!char + (again (!++ g!end)) + [] + (!number_output source_code start g!end <codec> <tag>)))))] + + [nat_parser n.decimal .#Nat] + [rev_parser rev.decimal .#Rev] + ) + +(def !signed_parser + (template (_ source_code//size offset where source_code @aliases @end) + [(<| (let [g!offset/1 (!++ offset)]) + (!with_char+ source_code//size source_code g!offset/1 g!char/1 @end) + (!if_digit? g!char/1 + (signed_parser source_code//size offset where (!++/2 offset) source_code) + (!full_symbol_parser offset [where (!++ offset) source_code] where @aliases .#Symbol)))])) + +(with_expansions [<output> {.#Right [[(revised .#column (|>> (!n/+ (!n/- start end))) where) + end + source_code] + (!clip start end source_code)]}] + (inlined (symbol_part_parser start where offset source_code) + (-> Nat Location Offset Text + (Either [Source Text] [Source Text])) + (let [source_code//size ("lux text size" source_code)] + (loop (again [end offset]) + (<| (!with_char+ source_code//size source_code end char <output>) + (!if_symbol_char?|tail char + (again (!++ end)) + <output>)))))) + +(def !half_symbol_parser + (template (_ @offset @char @module) + [(!if_symbol_char?|head @char + (!letE [source' symbol] (..symbol_part_parser @offset (!forward 1 where) (!++ @offset) source_code) + {.#Right [source' [@module symbol]]}) + (!failure ..!half_symbol_parser where @offset source_code))])) + +(`` (def (short_symbol_parser source_code//size current_module [where offset/0 source_code]) + (-> Nat Text (Parser Symbol)) + (<| (!with_char+ source_code//size source_code offset/0 char/0 + (!end_of_file where offset/0 source_code current_module)) + (if (!n/= (char (,, (static ..symbol_separator))) char/0) + (<| (let [offset/1 (!++ offset/0)]) + (!with_char+ source_code//size source_code offset/1 char/1 + (!end_of_file where offset/1 source_code current_module)) + (!half_symbol_parser offset/1 char/1 current_module)) + (!half_symbol_parser offset/0 char/0 (static ..prelude)))))) + +(def !short_symbol_parser + (template (_ source_code//size @current_module @source @where @tag) + [(!letE [source' symbol] (..short_symbol_parser source_code//size @current_module @source) + {.#Right [source' [@where {@tag symbol}]]})])) + +(with_expansions [<simple> (these {.#Right [source' ["" simple]]})] + (`` (def (full_symbol_parser aliases start source) + (-> Aliases Offset (Parser Symbol)) + (<| (!letE [source' simple] (let [[where offset source_code] source] + (..symbol_part_parser start where offset source_code))) + (let [[where' offset' source_code'] source']) + (!with_char source_code' offset' char/separator <simple>) + (if (!n/= (char (,, (static ..symbol_separator))) char/separator) + (<| (let [offset'' (!++ offset')]) + (!letE [source'' complex] (..symbol_part_parser offset'' (!forward 1 where') offset'' source_code')) + (if ("lux text =" "" complex) + (let [[where offset source_code] source] + (!failure ..full_symbol_parser where offset source_code)) + {.#Right [source'' [(|> aliases + (dictionary.value simple) + (maybe.else simple)) + complex]]})) + <simple>))))) + +(def !full_symbol_parser + (template (_ @offset @source @where @aliases @tag) + [(!letE [source' full_symbol] (..full_symbol_parser @aliases @offset @source) + {.#Right [source' [@where {@tag full_symbol}]]})])) + +... TODO: Grammar macro for specifying syntax. +... (def lux_grammar +... (grammar [expression "..."] +... [form "(" [#* expression] ")"])) + +(with_expansions [<consume_1> (these where (!++ offset/0) source_code) + <move_1> (these [(!forward 1 where) (!++ offset/0) source_code]) + <move_2> (these [(!forward 1 where) (!++/2 offset/0) source_code]) + <again> (these (parse current_module aliases source_code//size))] + + (def !close + (template (_ closer) + [{.#Left [<move_1> closer]}])) + + (def (bit_syntax value [where offset/0 source_code]) + (-> Bit (Parser Code)) + {.#Right [[(revised .#column (|>> !++/2) where) + (!++/2 offset/0) + source_code] + [where {.#Bit value}]]}) + + (def .public (parse current_module aliases source_code//size) + (-> Text Aliases Nat (Parser Code)) + ... The "exec []" is only there to avoid function fusion. + ... This is to preserve the loop as much as possible and keep it tight. + (exec + [] + (function (again [where offset/0 source_code]) + (<| (!with_char+ source_code//size source_code offset/0 char/0 + (!end_of_file where offset/0 source_code current_module)) + (with_expansions [<composites> (with_template [<open> <close> <parser>] + [[(,, (static <open>))] + (<parser> <again> <consume_1>) + + [(,, (static <close>))] + (!close <close>)] + + [..open_form ..close_form form_parser] + [..open_variant ..close_variant variant_parser] + [..open_tuple ..close_tuple tuple_parser] + )] + (`` ("lux syntax char case!" char/0 + [[(,, (static text.space)) + (,, (static text.carriage_return))] + (again (!horizontal where offset/0 source_code)) + + ... New line + [(,, (static text.new_line))] + (again (!vertical where offset/0 source_code)) + + <composites> + + ... Text + [(,, (static ..text_delimiter))] + (text_parser where (!++ offset/0) source_code) + + ... Coincidentally (= ..symbol_separator ..frac_separator) + [(,, (static ..symbol_separator)) + ... (,, (static ..frac_separator)) + ] + ... It's either a Rev, a symbol, or a comment. + (with_expansions [<rev_parser> (rev_parser source_code//size offset/0 where (!++ offset/1) source_code) + <short_symbol_parser> (!short_symbol_parser source_code//size current_module [where offset/1 source_code] where .#Symbol) + <comment_parser> (case ("lux text index" (!++ offset/1) (static text.new_line) source_code) + {.#Some end} + (again (!vertical where end source_code)) + + _ + (!end_of_file where offset/1 source_code current_module))] + (<| (let [offset/1 (!++ offset/0)]) + (!with_char+ source_code//size source_code offset/1 char/1 + (!end_of_file where offset/1 source_code current_module)) + (!if_digit? char/1 + ... It's a Rev. + <rev_parser> + ... It's either a symbol, or a comment. + ("lux syntax char case!" char/1 + [[(,, (static ..symbol_separator))] + ... It's either a symbol, or a comment. + (<| (let [offset/2 (!++ offset/1)]) + (!with_char+ source_code//size source_code offset/2 char/2 + (!end_of_file where offset/2 source_code current_module)) + ("lux syntax char case!" char/2 + [[(,, (static ..symbol_separator))] + ... It's a comment. + <comment_parser>] + ... It's a symbol. + <short_symbol_parser>))] + ... It's a symbol. + <short_symbol_parser>)))) + + [(,, (static ..positive_sign)) + (,, (static ..negative_sign))] + (!signed_parser source_code//size offset/0 where source_code aliases + (!end_of_file where offset/0 source_code current_module)) + + [(,, (static ..sigil))] + (<| (let [offset/1 (!++ offset/0)]) + (!with_char+ source_code//size source_code offset/1 char/1 + (!end_of_file where offset/1 source_code current_module)) + ("lux syntax char case!" char/1 + [(,, (with_template [<char> <bit>] + [[<char>] + (..bit_syntax <bit> [where offset/0 source_code])] + + ["0" #0] + ["1" #1]))] + + ... else + (!full_symbol_parser offset/0 [<consume_1>] where aliases .#Symbol)))] + + ... else + (!if_digit? char/0 + ... Natural number + (nat_parser source_code//size offset/0 where (!++ offset/0) source_code) + ... Symbol + (!full_symbol_parser offset/0 [<consume_1>] where aliases .#Symbol)) + ))) + )))) + ) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/synthesis.lux b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis.lux new file mode 100644 index 000000000..735da0f51 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis.lux @@ -0,0 +1,755 @@ +(.require + [library + [lux (.except Scope i64) + [abstract + [monad (.only do)] + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [control + ["[0]" maybe]] + [data + ["[0]" sum] + ["[0]" product] + ["[0]" bit (.use "[1]#[0]" equivalence)] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only Format format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" dictionary (.only Dictionary)]]] + [math + [number + ["[0]" i64] + ["n" nat] + ["i" int] + ["f" frac]]] + [meta + [macro + ["^" pattern]]]]] + ["[0]" / + ["[1][0]" simple (.only Simple)] + ["[1][0]" access (.only Access) + ["[2][0]" side (.only Side)] + ["[2][0]" member (.only Member)]] + [// + ["[0]" analysis (.only Environment Analysis) + ["[1]/[0]" complex (.only Complex)]] + [phase + ["[0]" extension (.only Extension)]] + [/// + [arity (.only Arity)] + ["[0]" phase] + ["[0]" reference (.only Reference) + ["[0]" variable (.only Register Variable)]]]]]) + +(type .public Resolver + (Dictionary Variable Variable)) + +(type .public State + (Record + [#locals Nat + ... https://en.wikipedia.org/wiki/Currying + #currying? Bit])) + +(def .public fresh_resolver + Resolver + (dictionary.empty variable.hash)) + +(def .public init + State + [#locals 0 + #currying? false]) + +(type .public (Road value next) + (Record + [#when value + #then next])) + +(type .public (Fork value next) + [(Road value next) + (List (Road value next))]) + +(type .public (Path' s) + (Variant + {#Pop} + {#Bind Register} + {#Access Access} + {#Bit_Fork Bit (Path' s) (Maybe (Path' s))} + {#I64_Fork (Fork I64 (Path' s))} + {#F64_Fork (Fork Frac (Path' s))} + {#Text_Fork (Fork Text (Path' s))} + {#Seq (Path' s) (Path' s)} + {#Alt (Path' s) (Path' s)} + {#Then s})) + +(type .public (Abstraction' s) + (Record + [#environment (Environment s) + #arity Arity + #body s])) + +(type .public (Apply' s) + (Record + [#function s + #arguments (List s)])) + +(type .public (Branch s) + (Variant + {#Exec s s} + {#Let s Register s} + {#If s s s} + {#Get (List Member) s} + {#Case s (Path' s)})) + +(type .public (Scope s) + (Record + [#start Register + #inits (List s) + #iteration s])) + +(type .public (Loop s) + (Variant + {#Scope (Scope s)} + {#Again (List s)})) + +(type .public (Function s) + (Variant + {#Abstraction (Abstraction' s)} + {#Apply (Apply' s)})) + +(type .public (Control s) + (Variant + {#Branch (Branch s)} + {#Loop (Loop s)} + {#Function (Function s)})) + +(type .public Synthesis + (Rec Synthesis + (Variant + {#Simple Simple} + {#Structure (Complex Synthesis)} + {#Reference Reference} + {#Control (Control Synthesis)} + {#Extension (Extension Synthesis)}))) + +(with_template [<special> <general>] + [(type .public <special> + (<general> ..State Analysis Synthesis))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(type .public Path + (Path' Synthesis)) + +(def .public path/pop + Path + {#Pop}) + +(with_template [<name> <kind>] + [(def .public <name> + (template (<name> content) + [(.<| {..#Access} + {<kind>} + content)]))] + + [path/side /access.#Side] + [path/member /access.#Member] + ) + +(with_template [<name> <access> <lefts> <right?>] + [(def .public <name> + (template (<name> lefts right?) + [(.<| {..#Access} + {<access>} + [<lefts> lefts + <right?> right?])]))] + + [side /access.#Side /side.#lefts /side.#right?] + [member /access.#Member /member.#lefts /member.#right?] + ) + +(with_template [<access> <side> <name>] + [(def .public <name> + (template (<name> lefts) + [(<access> lefts <side>)]))] + + [..side #0 side/left] + [..side #1 side/right] + + [..member #0 member/left] + [..member #1 member/right] + ) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> content) + [{<tag> content}]))] + + [path/bind ..#Bind] + [path/then ..#Then] + ) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> left right) + [{<tag> left right}]))] + + [path/alt ..#Alt] + [path/seq ..#Seq] + ) + +(type .public Abstraction + (Abstraction' Synthesis)) + +(type .public Apply + (Apply' Synthesis)) + +(def .public unit + Text + "") + +(with_template [<with> <query> <tag> <type>] + [(def .public (<with> value) + (-> <type> (All (_ a) (-> (Operation a) (Operation a)))) + (extension.temporary (has <tag> value))) + + (def .public <query> + (Operation <type>) + (extension.read (the <tag>)))] + + [with_locals locals #locals Nat] + [with_currying? currying? #currying? Bit] + ) + +(def .public with_new_local + (All (_ a) (-> (Operation a) (Operation a))) + (<<| (do phase.monad + [locals ..locals]) + (..with_locals (++ locals)))) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> content) + [{..#Simple {<tag> content}}]))] + + [bit /simple.#Bit] + [i64 /simple.#I64] + [f64 /simple.#F64] + [text /simple.#Text] + ) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> content) + [(.<| {..#Structure} + {<tag>} + content)]))] + + [variant analysis/complex.#Variant] + [tuple analysis/complex.#Tuple] + ) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> content) + [(.<| {..#Reference} + <tag> + content)]))] + + [variable reference.variable] + [constant reference.constant] + [variable/local reference.local] + [variable/foreign reference.foreign] + ) + +(with_template [<name> <family> <tag>] + [(def .public <name> + (template (<name> content) + [(.<| {..#Control} + {<family>} + {<tag>} + content)]))] + + [branch/case ..#Branch ..#Case] + [branch/exec ..#Branch ..#Exec] + [branch/let ..#Branch ..#Let] + [branch/if ..#Branch ..#If] + [branch/get ..#Branch ..#Get] + + [loop/again ..#Loop ..#Again] + [loop/scope ..#Loop ..#Scope] + + [function/abstraction ..#Function ..#Abstraction] + [function/apply ..#Function ..#Apply] + ) + +(def .public (%path' %then value) + (All (_ a) (-> (Format a) (Format (Path' a)))) + (case value + {#Pop} + "_" + + {#Bit_Fork when then else} + (format "(?" + " " (%.bit when) " " (%path' %then then) + (case else + {.#Some else} + (format " " (%.bit (not when)) " " (%path' %then else)) + + {.#None} + "") + ")") + + (^.with_template [<tag> <format>] + [{<tag> item} + (|> {.#Item item} + (list#each (function (_ [test then]) + (format (<format> test) " " (%path' %then then)))) + (text.interposed " ") + (text.enclosed ["(? " ")"]))]) + ([#I64_Fork (|>> .int %.int)] + [#F64_Fork %.frac] + [#Text_Fork %.text]) + + {#Access it} + (/access.format it) + + {#Bind register} + (format "(@ " (%.nat register) ")") + + {#Alt left right} + (format "(| " (%path' %then left) " " (%path' %then right) ")") + + {#Seq left right} + (format "(& " (%path' %then left) " " (%path' %then right) ")") + + {#Then then} + (|> (%then then) + (text.enclosed ["(! " ")"])))) + +(def .public (%synthesis value) + (Format Synthesis) + (case value + {#Simple it} + (/simple.format it) + + {#Structure structure} + (case structure + {analysis/complex.#Variant [lefts right? content]} + (|> (%synthesis content) + (format (%.nat lefts) " " (%.bit right?) " ") + (text.enclosed ["{" "}"])) + + {analysis/complex.#Tuple members} + (|> members + (list#each %synthesis) + (text.interposed " ") + (text.enclosed ["[" "]"]))) + + {#Reference reference} + (reference.format reference) + + {#Control control} + (case control + {#Function function} + (case function + {#Abstraction [environment arity body]} + (let [environment' (|> environment + (list#each %synthesis) + (text.interposed " ") + (text.enclosed ["[" "]"]))] + (|> (format environment' " " (%.nat arity) " " (%synthesis body)) + (text.enclosed ["{#function " "}"]))) + + {#Apply func args} + (|> args + (list#each %synthesis) + (text.interposed " ") + (format (%synthesis func) " ") + (text.enclosed ["(" ")"]))) + + {#Branch branch} + (case branch + {#Exec this that} + (|> (format (%synthesis this) " " (%synthesis that)) + (text.enclosed ["{#exec " "}"])) + + {#Let input register body} + (|> (format (%.nat register) " " (%synthesis input) " " (%synthesis body)) + (text.enclosed ["{#let " "}"])) + + {#If test then else} + (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else)) + (text.enclosed ["{#if " "}"])) + + {#Get members record} + (|> (format (%.list (%path' %synthesis) + (list#each (|>> {/access.#Member} {#Access}) members)) + " " (%synthesis record)) + (text.enclosed ["{#get " "}"])) + + {#Case input path} + (|> (format (%synthesis input) " " (%path' %synthesis path)) + (text.enclosed ["{#case " "}"]))) + + {#Loop loop} + (case loop + {#Scope scope} + (|> (format (%.nat (the #start scope)) + " " (|> (the #inits scope) + (list#each %synthesis) + (text.interposed " ") + (text.enclosed ["[" "]"])) + " " (%synthesis (the #iteration scope))) + (text.enclosed ["{#loop " "}"])) + + {#Again args} + (|> args + (list#each %synthesis) + (text.interposed " ") + (text.enclosed ["{#again " "}"])))) + + {#Extension [name args]} + (|> (list#each %synthesis args) + (text.interposed " ") + (format (%.text name) " ") + (text.enclosed ["(" ")"])))) + +(def .public %path + (Format Path) + (%path' %synthesis)) + +(def .public (path'_equivalence equivalence) + (All (_ a) (-> (Equivalence a) (Equivalence (Path' a)))) + (implementation + (def (= reference sample) + (case [reference sample] + [{#Pop} {#Pop}] + true + + [{#Bit_Fork reference_when reference_then reference_else} + {#Bit_Fork sample_when sample_then sample_else}] + (and (bit#= reference_when sample_when) + (= reference_then sample_then) + (at (maybe.equivalence =) = reference_else sample_else)) + + (^.with_template [<tag> <equivalence>] + [[{<tag> reference_item} + {<tag> sample_item}] + (at (list.equivalence (product.equivalence <equivalence> =)) = + {.#Item reference_item} + {.#Item sample_item})]) + ([#I64_Fork (is (Equivalence I64) i64.equivalence)] + [#F64_Fork f.equivalence] + [#Text_Fork text.equivalence]) + + (^.with_template [<tag> <equivalence>] + [[{<tag> reference'} {<tag> sample'}] + (at <equivalence> = reference' sample')]) + ([#Access /access.equivalence] + [#Then equivalence]) + + [{#Bind reference'} {#Bind sample'}] + (n.= reference' sample') + + (^.with_template [<tag>] + [[{<tag> leftR rightR} {<tag> leftS rightS}] + (and (= leftR leftS) + (= rightR rightS))]) + ([#Alt] + [#Seq]) + + _ + false)))) + +(def (path'_hash super) + (All (_ a) (-> (Hash a) (Hash (Path' a)))) + (implementation + (def equivalence + (..path'_equivalence (at super equivalence))) + + (def (hash value) + (case value + {#Pop} + 2 + + {#Access access} + (n.* 3 (at /access.hash hash access)) + + {#Bind register} + (n.* 5 (at n.hash hash register)) + + {#Bit_Fork when then else} + (all n.* 7 + (at bit.hash hash when) + (hash then) + (at (maybe.hash (path'_hash super)) hash else)) + + (^.with_template [<factor> <tag> <hash>] + [{<tag> item} + (let [case_hash (product.hash <hash> + (path'_hash super)) + item_hash (product.hash case_hash (list.hash case_hash))] + (n.* <factor> (at item_hash hash item)))]) + ([11 #I64_Fork i64.hash] + [13 #F64_Fork f.hash] + [17 #Text_Fork text.hash]) + + (^.with_template [<factor> <tag>] + [{<tag> fork} + (let [again_hash (path'_hash super) + fork_hash (product.hash again_hash again_hash)] + (n.* <factor> (at fork_hash hash fork)))]) + ([19 #Alt] + [23 #Seq]) + + {#Then body} + (n.* 29 (at super hash body)) + )))) + +(def (branch_equivalence (open "#[0]")) + (All (_ a) (-> (Equivalence a) (Equivalence (Branch a)))) + (implementation + (def (= reference sample) + (case [reference sample] + [{#Let [reference_input reference_register reference_body]} + {#Let [sample_input sample_register sample_body]}] + (and (#= reference_input sample_input) + (n.= reference_register sample_register) + (#= reference_body sample_body)) + + [{#If [reference_test reference_then reference_else]} + {#If [sample_test sample_then sample_else]}] + (and (#= reference_test sample_test) + (#= reference_then sample_then) + (#= reference_else sample_else)) + + [{#Get [reference_path reference_record]} + {#Get [sample_path sample_record]}] + (and (at (list.equivalence /member.equivalence) = reference_path sample_path) + (#= reference_record sample_record)) + + [{#Case [reference_input reference_path]} + {#Case [sample_input sample_path]}] + (and (#= reference_input sample_input) + (at (path'_equivalence #=) = reference_path sample_path)) + + _ + false)))) + +(def (branch_hash super) + (All (_ a) (-> (Hash a) (Hash (Branch a)))) + (implementation + (def equivalence + (..branch_equivalence (at super equivalence))) + + (def (hash value) + (case value + {#Exec this that} + (all n.* 2 + (at super hash this) + (at super hash that)) + + {#Let [input register body]} + (all n.* 3 + (at super hash input) + (at n.hash hash register) + (at super hash body)) + + {#If [test then else]} + (all n.* 5 + (at super hash test) + (at super hash then) + (at super hash else)) + + {#Get [path record]} + (all n.* 7 + (at (list.hash /member.hash) hash path) + (at super hash record)) + + {#Case [input path]} + (all n.* 11 + (at super hash input) + (at (..path'_hash super) hash path)) + )))) + +(def (loop_equivalence (open "/#[0]")) + (All (_ a) (-> (Equivalence a) (Equivalence (Loop a)))) + (implementation + (def (= reference sample) + (case [reference sample] + [{#Scope [reference_start reference_inits reference_iteration]} + {#Scope [sample_start sample_inits sample_iteration]}] + (and (n.= reference_start sample_start) + (at (list.equivalence /#=) = reference_inits sample_inits) + (/#= reference_iteration sample_iteration)) + + [{#Again reference} {#Again sample}] + (at (list.equivalence /#=) = reference sample) + + _ + false)))) + +(def (loop_hash super) + (All (_ a) (-> (Hash a) (Hash (Loop a)))) + (implementation + (def equivalence + (..loop_equivalence (at super equivalence))) + + (def (hash value) + (case value + {#Scope [start inits iteration]} + (all n.* 2 + (at n.hash hash start) + (at (list.hash super) hash inits) + (at super hash iteration)) + + {#Again resets} + (all n.* 3 + (at (list.hash super) hash resets)) + )))) + +(def (function_equivalence (open "#[0]")) + (All (_ a) (-> (Equivalence a) (Equivalence (Function a)))) + (implementation + (def (= reference sample) + (case [reference sample] + [{#Abstraction [reference_environment reference_arity reference_body]} + {#Abstraction [sample_environment sample_arity sample_body]}] + (and (at (list.equivalence #=) = reference_environment sample_environment) + (n.= reference_arity sample_arity) + (#= reference_body sample_body)) + + [{#Apply [reference_abstraction reference_arguments]} + {#Apply [sample_abstraction sample_arguments]}] + (and (#= reference_abstraction sample_abstraction) + (at (list.equivalence #=) = reference_arguments sample_arguments)) + + _ + false)))) + +(def (function_hash super) + (All (_ a) (-> (Hash a) (Hash (Function a)))) + (implementation + (def equivalence + (..function_equivalence (at super equivalence))) + + (def (hash value) + (case value + {#Abstraction [environment arity body]} + (all n.* 2 + (at (list.hash super) hash environment) + (at n.hash hash arity) + (at super hash body)) + + {#Apply [abstraction arguments]} + (all n.* 3 + (at super hash abstraction) + (at (list.hash super) hash arguments)) + )))) + +(def (control_equivalence (open "#[0]")) + (All (_ a) (-> (Equivalence a) (Equivalence (Control a)))) + (implementation + (def (= reference sample) + (case [reference sample] + (^.with_template [<tag> <equivalence>] + [[{<tag> reference} {<tag> sample}] + (at (<equivalence> #=) = reference sample)]) + ([#Branch ..branch_equivalence] + [#Loop ..loop_equivalence] + [#Function ..function_equivalence]) + + _ + false)))) + +(def (control_hash super) + (All (_ a) (-> (Hash a) (Hash (Control a)))) + (implementation + (def equivalence + (..control_equivalence (at super equivalence))) + + (def (hash value) + (case value + (^.with_template [<factor> <tag> <hash>] + [{<tag> value} + (n.* <factor> (at (<hash> super) hash value))]) + ([2 #Branch ..branch_hash] + [3 #Loop ..loop_hash] + [5 #Function ..function_hash]) + )))) + +(def .public equivalence + (Equivalence Synthesis) + (implementation + (def (= reference sample) + (case [reference sample] + (^.with_template [<tag> <equivalence>] + [[{<tag> reference'} {<tag> sample'}] + (at <equivalence> = reference' sample')]) + ([#Simple /simple.equivalence] + [#Structure (analysis/complex.equivalence =)] + [#Reference reference.equivalence] + [#Control (control_equivalence =)] + [#Extension (extension.equivalence =)]) + + _ + false)))) + +(def .public path_equivalence + (Equivalence Path) + (path'_equivalence equivalence)) + +(def .public hash + (Hash Synthesis) + (implementation + (def equivalence ..equivalence) + + (def (hash value) + (let [again_hash [..equivalence hash]] + (case value + (^.with_template [<tag> <hash>] + [{<tag> value} + (at <hash> hash value)]) + ([#Simple /simple.hash] + [#Structure (analysis/complex.hash again_hash)] + [#Reference reference.hash] + [#Control (..control_hash again_hash)] + [#Extension (extension.hash again_hash)])))))) + +(def .public !bind_top + (template (!bind_top register thenP) + [(all ..path/seq + {..#Bind register} + {..#Pop} + thenP)])) + +(def .public !multi_pop + (template (!multi_pop nextP) + [(all ..path/seq + {..#Pop} + {..#Pop} + nextP)])) + +... TODO: There are sister patterns to the simple side checks for tuples. +... These correspond to the situation where tuple members are accessed +... and bound to variables, but those variables are never used, so they +... become POPs. +... After re-implementing unused-variable-elimination, must add those +... pattern-optimizations again, since a lot of BINDs will become POPs +... and thus will result in useless code being generated. +(with_template [<name> <side>] + [(def .public <name> + (template (<name> idx nextP) + [(all ..path/seq + (<side> idx) + {..#Pop} + nextP)]))] + + [simple_left_side ..side/left] + [simple_right_side ..side/right] + ) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/access.lux b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/access.lux new file mode 100644 index 000000000..f599f4d90 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/access.lux @@ -0,0 +1,38 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [data + ["[0]" sum] + [text + ["%" \\format (.only Format)]]]]] + ["[0]" / + ["[1][0]" side (.only Side)] + ["[1][0]" member (.only Member)]]) + +(type .public Access + (Variant + {#Side Side} + {#Member Member})) + +(def .public (format it) + (Format Access) + (case it + {#Side it} + (/side.format it) + + {#Member it} + (/member.format it))) + +(def .public hash + (Hash Access) + (all sum.hash + /side.hash + /member.hash + )) + +(def .public equivalence + (Equivalence Access) + (at ..hash equivalence)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/access/member.lux b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/access/member.lux new file mode 100644 index 000000000..667775b7d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/access/member.lux @@ -0,0 +1,34 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [data + ["[0]" product] + ["[0]" bit] + [text + ["%" \\format]]] + [math + [number + ["[0]" nat]]]]]) + +(type .public Member + (Record + [#lefts Nat + #right? Bit])) + +(def .public (format it) + (%.Format Member) + (%.format "[" (%.nat (the #lefts it)) " " (%.bit (the #right? it)) "]")) + +(def .public hash + (Hash Member) + (all product.hash + nat.hash + bit.hash + )) + +(def .public equivalence + (Equivalence Member) + (at ..hash equivalence)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/access/side.lux b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/access/side.lux new file mode 100644 index 000000000..0f8ef1625 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/access/side.lux @@ -0,0 +1,34 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [data + ["[0]" product] + ["[0]" bit] + [text + ["%" \\format]]] + [math + [number + ["[0]" nat]]]]]) + +(type .public Side + (Record + [#lefts Nat + #right? Bit])) + +(def .public (format it) + (%.Format Side) + (%.format "{" (%.nat (the #lefts it)) " " (%.bit (the #right? it)) "}")) + +(def .public hash + (Hash Side) + (all product.hash + nat.hash + bit.hash + )) + +(def .public equivalence + (Equivalence Side) + (at ..hash equivalence)) diff --git a/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/simple.lux b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/simple.lux new file mode 100644 index 000000000..738ea9b76 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/language/lux/synthesis/simple.lux @@ -0,0 +1,74 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [control + ["[0]" pipe]] + [data + ["[0]" bit (.use "[1]#[0]" equivalence)] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format]]] + [math + [number + ["[0]" i64 (.use "[1]#[0]" equivalence)] + ["n" nat] + ["i" int] + ["f" frac]]] + [meta + [macro + ["^" pattern]]]]]) + +(type .public Simple + (Variant + {#Bit Bit} + {#I64 I64} + {#F64 Frac} + {#Text Text})) + +(def .public (format it) + (%.Format Simple) + (case it + (^.with_template [<pattern> <format>] + [{<pattern> value} + (<format> value)]) + ([#Bit %.bit] + [#F64 %.frac] + [#Text %.text]) + + {#I64 value} + (%.int (.int value)))) + +(def .public equivalence + (Equivalence Simple) + (implementation + (def (= reference sample) + (case [reference sample] + (^.with_template [<tag> <eq> <format>] + [[{<tag> reference'} {<tag> sample'}] + (<eq> reference' sample')]) + ([#Bit bit#= %.bit] + [#F64 f.= %.frac] + [#Text text#= %.text]) + + [{#I64 reference'} {#I64 sample'}] + (i64#= reference' sample') + + _ + false)))) + +(def .public hash + (Hash Simple) + (implementation + (def equivalence ..equivalence) + + (def hash + (|>> (pipe.case + (^.with_template [<factor> <tag> <hash>] + [{<tag> value'} + (n.* <factor> (at <hash> hash value'))]) + ([2 #Bit bit.hash] + [3 #F64 f.hash] + [5 #Text text.hash] + [7 #I64 i64.hash])))))) diff --git a/stdlib/source/library/lux/meta/compiler/meta.lux b/stdlib/source/library/lux/meta/compiler/meta.lux new file mode 100644 index 000000000..00e782b29 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta.lux @@ -0,0 +1,9 @@ +(.require + [library + [lux (.except)]] + [// + [version (.only Version)]]) + +(def .public version + Version + 00,02,00) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive.lux b/stdlib/source/library/lux/meta/compiler/meta/archive.lux new file mode 100644 index 000000000..75612d11a --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive.lux @@ -0,0 +1,267 @@ +(.require + [library + [lux (.except Module has) + [abstract + ["[0]" equivalence (.only Equivalence)] + ["[0]" monad (.only do)]] + [control + ["<>" parser] + ["[0]" maybe] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)] + ["[0]" function]] + [data + ["[0]" product] + ["[0]" binary (.only Binary) + ["[0]" \\format (.only Format)] + ["<[1]>" \\parser (.only Parser)]] + ["[0]" text (.only) + ["%" \\format]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" set] + ["[0]" sequence (.only Sequence)]]] + [math + [number + ["n" nat (.use "[1]#[0]" equivalence)]]] + [meta + [type + [primitive (.except)]]]]] + [/ + ["[0]" artifact] + ["[0]" registry (.only Registry)] + ["[0]" signature (.only Signature)] + ["[0]" key (.only Key)] + ["[0]" module (.only Module) + ["[0]" descriptor (.only Descriptor)] + ["[0]" document (.only Document)]] + [/// + [version (.only Version)]]]) + +(type .public Output + (Sequence [artifact.ID (Maybe Text) Binary])) + +(exception .public (unknown_document [module descriptor.Module + known_modules (List descriptor.Module)]) + (exception.report + "Module" (%.text module) + "Known Modules" (exception.listing %.text known_modules))) + +(exception .public (cannot_replace_document [module descriptor.Module + old (Document Any) + new (Document Any)]) + (exception.report + "Module" (%.text module) + "Old key" (signature.description (document.signature old)) + "New key" (signature.description (document.signature new)))) + +(with_template [<name>] + [(exception .public (<name> [it descriptor.Module]) + (exception.report + "Module" (%.text it)))] + + [module_has_already_been_reserved] + [module_must_be_reserved_before_it_can_be_added] + [module_is_only_reserved] + ) + +(type .public (Entry a) + (Record + [#module (Module a) + #output Output + #registry Registry])) + +(primitive .public Archive + (Record + [#next module.ID + #resolver (Dictionary descriptor.Module [module.ID (Maybe (Entry Any))])]) + + (def next + (-> Archive module.ID) + (|>> representation (the #next))) + + (def .public empty + Archive + (abstraction [#next 0 + #resolver (dictionary.empty text.hash)])) + + (def .public (id module archive) + (-> descriptor.Module Archive (Try module.ID)) + (let [(open "/[0]") (representation archive)] + (case (dictionary.value module /#resolver) + {.#Some [id _]} + {try.#Success id} + + {.#None} + (exception.except ..unknown_document [module + (dictionary.keys /#resolver)])))) + + (def .public (reserve module archive) + (-> descriptor.Module Archive (Try [module.ID Archive])) + (let [(open "/[0]") (representation archive)] + (case (dictionary.value module /#resolver) + {.#Some _} + (exception.except ..module_has_already_been_reserved [module]) + + {.#None} + {try.#Success [/#next + (|> archive + representation + (revised #resolver (dictionary.has module [/#next (is (Maybe (Entry Any)) {.#None})])) + (revised #next ++) + abstraction)]}))) + + (def .public (has module entry archive) + (-> descriptor.Module (Entry Any) Archive (Try Archive)) + (let [(open "/[0]") (representation archive)] + (case (dictionary.value module /#resolver) + {.#Some [id {.#None}]} + {try.#Success (|> archive + representation + (revised ..#resolver (dictionary.has module [id {.#Some entry}])) + abstraction)} + + {.#Some [id {.#Some [existing_module existing_output existing_registry]}]} + (if (same? (the module.#document existing_module) + (the [#module module.#document] entry)) + ... TODO: Find out why this code allows for the same module to be added more than once. It looks fishy... + {try.#Success archive} + (exception.except ..cannot_replace_document [module (the module.#document existing_module) (the [#module module.#document] entry)])) + + {.#None} + (exception.except ..module_must_be_reserved_before_it_can_be_added [module])))) + + (def .public entries + (-> Archive (List [descriptor.Module [module.ID (Entry Any)]])) + (|>> representation + (the #resolver) + dictionary.entries + (list.all (function (_ [module [module_id entry]]) + (at maybe.monad each (|>> [module_id] [module]) entry))))) + + (def .public (find module archive) + (-> descriptor.Module Archive (Try (Entry Any))) + (let [(open "/[0]") (representation archive)] + (case (dictionary.value module /#resolver) + {.#Some [id {.#Some entry}]} + {try.#Success entry} + + {.#Some [id {.#None}]} + (exception.except ..module_is_only_reserved [module]) + + {.#None} + (exception.except ..unknown_document [module (dictionary.keys /#resolver)])))) + + (def .public (archived? archive module) + (-> Archive descriptor.Module Bit) + (case (..find module archive) + {try.#Success _} + true + + {try.#Failure _} + false)) + + (def .public archived + (-> Archive (List descriptor.Module)) + (|>> representation + (the #resolver) + dictionary.entries + (list.all (function (_ [module [id descriptor+document]]) + (case descriptor+document + {.#Some _} {.#Some module} + {.#None} {.#None}))))) + + (def .public (reserved? archive module) + (-> Archive descriptor.Module Bit) + (let [(open "/[0]") (representation archive)] + (case (dictionary.value module /#resolver) + {.#Some [id _]} + true + + {.#None} + false))) + + (def .public reserved + (-> Archive (List descriptor.Module)) + (|>> representation + (the #resolver) + dictionary.keys)) + + (def .public reservations + (-> Archive (List [descriptor.Module module.ID])) + (|>> representation + (the #resolver) + dictionary.entries + (list#each (function (_ [module [id _]]) + [module id])))) + + (def .public (composite additions archive) + (-> Archive Archive Archive) + (let [[+next +resolver] (representation additions)] + (|> archive + representation + (revised #next (n.max +next)) + (revised #resolver (function (_ resolver) + (list#mix (function (_ [module [id entry]] resolver) + (case entry + {.#Some _} + (dictionary.has module [id entry] resolver) + + {.#None} + resolver)) + resolver + (dictionary.entries +resolver)))) + abstraction))) + + (type Reservation + [descriptor.Module module.ID]) + + (type Frozen + [Version module.ID (List Reservation)]) + + (def reader + (Parser ..Frozen) + (all <>.and + <binary>.nat + <binary>.nat + (<binary>.list (<>.and <binary>.text <binary>.nat)))) + + (def format + (Format ..Frozen) + (all \\format.and + \\format.nat + \\format.nat + (\\format.list (\\format.and \\format.text \\format.nat)))) + + (def .public (export version archive) + (-> Version Archive Binary) + (let [(open "/[0]") (representation archive)] + (|> /#resolver + dictionary.entries + (list.all (function (_ [module [id descriptor+document]]) + (case descriptor+document + {.#Some _} {.#Some [module id]} + {.#None} {.#None}))) + [version /#next] + (\\format.result ..format)))) + + (exception .public (version_mismatch [expected Version + actual Version]) + (exception.report + "Expected" (%.nat expected) + "Actual" (%.nat actual))) + + (def .public (import expected binary) + (-> Version Binary (Try Archive)) + (do try.monad + [[actual next reservations] (<binary>.result ..reader binary) + _ (exception.assertion ..version_mismatch [expected actual] + (n#= expected actual))] + (in (abstraction + [#next next + #resolver (list#mix (function (_ [module id] archive) + (dictionary.has module [id (is (Maybe (Entry Any)) {.#None})] archive)) + (the #resolver (representation ..empty)) + reservations)])))) + ) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/artifact.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/artifact.lux new file mode 100644 index 000000000..f458691b5 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/artifact.lux @@ -0,0 +1,32 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)]] + [data + ["[0]" product] + ["[0]" bit] + [collection + ["[0]" set (.only Set)]]] + [math + [number + ["[0]" nat]]]]] + ["[0]" / + ["[1][0]" category (.only Category)]]) + +(type .public ID + Nat) + +(type .public Artifact + (Record + [#id ID + #category Category + #mandatory? Bit])) + +(def .public equivalence + (Equivalence Artifact) + (all product.equivalence + nat.equivalence + /category.equivalence + bit.equivalence + )) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/artifact/category.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/artifact/category.lux new file mode 100644 index 000000000..706ea16ae --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/artifact/category.lux @@ -0,0 +1,65 @@ +(.require + [library + [lux (.except Definition) + [abstract + [equivalence (.only Equivalence)]] + [control + ["[0]" maybe]] + [data + ["[0]" product] + ["[0]" text (.use "[1]#[0]" equivalence)]] + [math + [number + ["[0]" nat]]] + [meta + [macro + ["^" pattern]]]]] + [///// + [arity (.only Arity)]]) + +(type .public Definition + [Text (Maybe [Arity [Nat Nat]])]) + +(def .public definition_equivalence + (Equivalence Definition) + (all product.equivalence + text.equivalence + (maybe.equivalence (all product.equivalence + nat.equivalence + nat.equivalence + nat.equivalence + )) + )) + +(type .public Category + (Variant + {#Anonymous} + {#Definition Definition} + {#Analyser Text} + {#Synthesizer Text} + {#Generator Text} + {#Declaration Text} + {#Custom Text})) + +(def .public equivalence + (Equivalence Category) + (implementation + (def (= left right) + (case [left right] + [{#Anonymous} {#Anonymous}] + true + + [{#Definition left} {#Definition right}] + (at definition_equivalence = left right) + + (^.with_template [<tag>] + [[{<tag> left} {<tag> right}] + (text#= left right)]) + ([#Analyser] + [#Synthesizer] + [#Generator] + [#Declaration] + [#Custom]) + + _ + false)))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/key.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/key.lux new file mode 100644 index 000000000..24db1094f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/key.lux @@ -0,0 +1,20 @@ +(.require + [library + [lux (.except) + [meta + [type + [primitive (.except)]]]]] + [// + [signature (.only Signature)]]) + +(primitive .public (Key k) + Signature + + (def .public signature + (All (_ ?) (-> (Key ?) Signature)) + (|>> representation)) + + (def .public (key signature sample) + (All (_ d) (-> Signature d (Key d))) + (abstraction signature)) + ) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/module.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/module.lux new file mode 100644 index 000000000..6fbde6c03 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/module.lux @@ -0,0 +1,19 @@ +(.require + [library + [lux (.except Module)]] + [/ + [descriptor (.only Descriptor)] + [document (.only Document)]]) + +(type .public ID + Nat) + +(def .public runtime + ID + 0) + +(type .public (Module a) + (Record + [#id ID + #descriptor Descriptor + #document (Document a)])) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/module/descriptor.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/module/descriptor.lux new file mode 100644 index 000000000..057f72e6e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/module/descriptor.lux @@ -0,0 +1,83 @@ +(.require + [library + [lux (.except Module) + [abstract + [equivalence (.only Equivalence)]] + [control + ["<>" parser]] + [data + ["[0]" product] + ["[0]" text] + ["[0]" binary + ["[0]" \\format (.only Format)] + ["<[1]>" \\parser (.only Parser)]] + [collection + ["[0]" set (.only Set)]]] + [math + [number + ["[0]" nat]]] + [meta + [macro + ["^" pattern]]] + [world + [file (.only Path)]]]]) + +(type .public Module + Text) + +(def .public runtime + Module + "") + +(type .public Descriptor + (Record + [#name Module + #file Path + #hash Nat + #state Module_State + #references (Set Module)])) + +(def module_state_equivalence + (Equivalence Module_State) + (implementation + (def (= left right) + (case [left right] + (^.with_template [<tag>] + [[{<tag>} {<tag>}] + true]) + ([.#Active] + [.#Compiled] + [.#Cached]) + + _ + false)))) + +(def .public equivalence + (Equivalence Descriptor) + (all product.equivalence + text.equivalence + text.equivalence + nat.equivalence + ..module_state_equivalence + set.equivalence + )) + +(def .public format + (Format Descriptor) + (all \\format.and + \\format.text + \\format.text + \\format.nat + \\format.any + (\\format.set \\format.text) + )) + +(def .public parser + (Parser Descriptor) + (all <>.and + <binary>.text + <binary>.text + <binary>.nat + (at <>.monad in {.#Cached}) + (<binary>.set text.hash <binary>.text) + )) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/module/document.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/module/document.lux new file mode 100644 index 000000000..46f7e2d5e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/module/document.lux @@ -0,0 +1,80 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["<>" parser] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)]] + [data + [collection + ["[0]" dictionary (.only Dictionary)]] + ["[0]" binary + [\\parser (.only Parser)] + ["[1]" \\format (.only Format)]]] + [meta + [type (.only sharing) + [primitive (.except)]]]]] + [/// + ["[0]" signature (.only Signature) (.use "[1]#[0]" equivalence)] + ["[0]" key (.only Key)]]) + +(exception .public (invalid_signature [expected Signature + actual Signature]) + (exception.report + "Expected" (signature.description expected) + "Actual" (signature.description actual))) + +(primitive .public (Document d) + (Record + [#signature Signature + #content d]) + + (def .public (content key document) + (All (_ d) (-> (Key d) (Document Any) (Try d))) + (let [[document//signature document//content] (representation document)] + (if (at signature.equivalence = + (key.signature key) + document//signature) + {try.#Success (sharing [e] + (is (Key e) + key) + (is e + (as_expected document//content)))} + (exception.except ..invalid_signature [(key.signature key) + document//signature])))) + + (def .public (document key content) + (All (_ d) (-> (Key d) d (Document d))) + (abstraction [#signature (key.signature key) + #content content])) + + (def .public (marked? key document) + (All (_ d) (-> (Key d) (Document Any) (Try (Document d)))) + (do try.monad + [_ (..content key document)] + (in (as_expected document)))) + + (def .public signature + (-> (Document Any) Signature) + (|>> representation (the #signature))) + + (def .public (format content) + (All (_ d) (-> (Format d) (Format (Document d)))) + (let [format (all binary.and + signature.format + content)] + (|>> representation format))) + + (def .public (parser key it) + (All (_ d) (-> (Key d) (Parser d) (Parser (Document d)))) + (do <>.monad + [actual signature.parser + .let [expected (key.signature key)] + _ (if (signature#= expected actual) + (in []) + (<>.lifted (exception.except ..invalid_signature [expected actual]))) + it it] + (in (abstraction [actual it])))) + ) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/registry.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/registry.lux new file mode 100644 index 000000000..fa6493f90 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/registry.lux @@ -0,0 +1,203 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only do)]] + [control + ["<>" parser] + ["[0]" pipe] + ["[0]" maybe (.use "[1]#[0]" functor)] + ["[0]" exception (.only exception)]] + [data + ["[0]" product] + ["[0]" binary + ["[1]" \\format (.only Format)] + ["<[1]>" \\parser (.only Parser)]] + ["[0]" text (.only) + ["%" \\format]] + [collection + [set (.only Set)] + ["[0]" list] + ["[0]" sequence (.only Sequence) (.use "[1]#[0]" functor mix)] + ["[0]" dictionary (.only Dictionary)]]] + [meta + [macro + ["^" pattern]] + [type + [primitive (.except)]]]]] + ["[0]" // + ["[0]" unit] + ["[1]" artifact (.only Artifact ID) + ["[2][0]" category (.only Category)]]]) + +(primitive .public Registry + (Record + [#artifacts (Sequence [Artifact (Set unit.ID)]) + #resolver (Dictionary Text [ID (Maybe //category.Definition)])]) + + (def .public empty + Registry + (abstraction [#artifacts sequence.empty + #resolver (dictionary.empty text.hash)])) + + (def .public artifacts + (-> Registry (Sequence [Artifact (Set unit.ID)])) + (|>> representation (the #artifacts))) + + (def next + (-> Registry ID) + (|>> ..artifacts sequence.size)) + + (def .public (resource mandatory? dependencies registry) + (-> Bit (Set unit.ID) Registry [ID Registry]) + (let [id (..next registry)] + [id + (|> registry + representation + (revised #artifacts (sequence.suffix [[//.#id id + //.#category {//category.#Anonymous} + //.#mandatory? mandatory?] + dependencies])) + abstraction)])) + + (with_template [<tag> <create> <fetch> <type> <name> <+resolver>] + [(def .public (<create> it mandatory? dependencies registry) + (-> <type> Bit (Set unit.ID) Registry [ID Registry]) + (let [id (..next registry)] + [id + (|> registry + representation + (revised #artifacts (sequence.suffix [[//.#id id + //.#category {<tag> it} + //.#mandatory? mandatory?] + dependencies])) + (revised #resolver (dictionary.has (<name> it) [id (is (Maybe //category.Definition) <+resolver>)])) + abstraction)])) + + (def .public (<fetch> registry) + (-> Registry (List <type>)) + (|> registry + representation + (the #artifacts) + sequence.list + (list.all (|>> product.left + (the //.#category) + (pipe.case + {<tag> it} {.#Some it} + _ {.#None})))))] + + [//category.#Definition definition definitions //category.Definition + product.left {.#Some it}] + [//category.#Analyser analyser analysers Text |> {.#None}] + [//category.#Synthesizer synthesizer synthesizers Text |> {.#None}] + [//category.#Generator generator generators Text |> {.#None}] + [//category.#Declaration declaration declarations Text |> {.#None}] + [//category.#Custom custom customs Text |> {.#None}] + ) + + (def .public (find_definition name registry) + (-> Text Registry (Maybe [ID (Maybe //category.Definition)])) + (|> (representation registry) + (the #resolver) + (dictionary.value name))) + + (def .public (id name registry) + (-> Text Registry (Maybe ID)) + (maybe#each product.left (find_definition name registry))) + + (def .public format + (Format Registry) + (let [definition (is (Format //category.Definition) + (all binary.and + binary.text + (binary.maybe + (all binary.and + binary.nat + binary.nat + binary.nat + )) + )) + category (is (Format Category) + (function (_ value) + (case value + (^.with_template [<nat> <tag> <format>] + [{<tag> value} + ((binary.and binary.nat <format>) [<nat> value])]) + ([0 //category.#Anonymous binary.any] + [1 //category.#Definition definition] + [2 //category.#Analyser binary.text] + [3 //category.#Synthesizer binary.text] + [4 //category.#Generator binary.text] + [5 //category.#Declaration binary.text] + [6 //category.#Custom binary.text])))) + mandatory? binary.bit + dependency (is (Format unit.ID) + (binary.and binary.nat binary.nat)) + dependencies (is (Format (Set unit.ID)) + (binary.set dependency)) + artifacts (is (Format (Sequence [Category Bit (Set unit.ID)])) + (binary.sequence_64 (all binary.and category mandatory? dependencies)))] + (|>> representation + (the #artifacts) + (sequence#each (function (_ [it dependencies]) + [(the //.#category it) + (the //.#mandatory? it) + dependencies])) + artifacts))) + + (exception .public (invalid_category [tag Nat]) + (exception.report + "Tag" (%.nat tag))) + + (def .public parser + (Parser Registry) + (let [definition (is (Parser //category.Definition) + (all <>.and + <binary>.text + (<binary>.maybe + (all <>.and + <binary>.nat + <binary>.nat + <binary>.nat + )) + )) + category (is (Parser Category) + (do [! <>.monad] + [tag <binary>.nat] + (case tag + (^.with_template [<nat> <tag> <parser>] + [<nat> + (at ! each (|>> {<tag>}) <parser>)]) + ([0 //category.#Anonymous <binary>.any] + [1 //category.#Definition definition] + [2 //category.#Analyser <binary>.text] + [3 //category.#Synthesizer <binary>.text] + [4 //category.#Generator <binary>.text] + [5 //category.#Declaration <binary>.text] + [6 //category.#Custom <binary>.text]) + + _ (<>.failure (exception.error ..invalid_category [tag]))))) + mandatory? <binary>.bit + dependency (is (Parser unit.ID) + (<>.and <binary>.nat <binary>.nat)) + dependencies (is (Parser (Set unit.ID)) + (<binary>.set unit.hash dependency))] + (|> (<binary>.sequence_64 (all <>.and category mandatory? dependencies)) + (at <>.monad each (sequence#mix (function (_ [category mandatory? dependencies] registry) + (product.right + (case category + {//category.#Anonymous} + (..resource mandatory? dependencies registry) + + (^.with_template [<tag> <create>] + [{<tag> name} + (<create> name mandatory? dependencies registry)]) + ([//category.#Definition ..definition] + [//category.#Analyser ..analyser] + [//category.#Synthesizer ..synthesizer] + [//category.#Generator ..generator] + [//category.#Declaration ..declaration] + [//category.#Custom ..custom]) + ))) + ..empty))))) + ) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/signature.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/signature.lux new file mode 100644 index 000000000..e9220d028 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/signature.lux @@ -0,0 +1,48 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)]] + [control + ["<>" parser]] + [data + ["[0]" product] + ["[0]" binary + ["[1]" \\format (.only Format)] + ["<[1]>" \\parser (.only Parser)]] + ["[0]" text (.only) + ["%" \\format]]] + [math + [number + ["[0]" nat]]] + [meta + ["[0]" symbol]]]] + [//// + ["[0]" version (.only Version)]]) + +(type .public Signature + (Record + [#name Symbol + #version Version])) + +(def .public equivalence + (Equivalence Signature) + (all product.equivalence + symbol.equivalence + nat.equivalence)) + +(def .public (description signature) + (-> Signature Text) + (%.format (%.symbol (the #name signature)) " " (version.format (the #version signature)))) + +(def .public format + (Format Signature) + (all binary.and + (binary.and binary.text binary.text) + binary.nat)) + +(def .public parser + (Parser Signature) + (all <>.and + (<>.and <binary>.text <binary>.text) + <binary>.nat)) diff --git a/stdlib/source/library/lux/meta/compiler/meta/archive/unit.lux b/stdlib/source/library/lux/meta/compiler/meta/archive/unit.lux new file mode 100644 index 000000000..82d29c16b --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/archive/unit.lux @@ -0,0 +1,43 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [data + ["[0]" product] + [text + ["%" \\format]] + [collection + ["[0]" set (.only Set)]]] + [math + [number + ["[0]" nat]]]]] + [// + ["[0]" module] + ["[0]" artifact]]) + +(type .public ID + (Record + [#module module.ID + #artifact artifact.ID])) + +(def .public hash + (Hash ID) + (all product.hash + nat.hash + nat.hash)) + +(def .public equivalence + (Equivalence ID) + (at ..hash equivalence)) + +(def .public none + (Set ID) + (set.empty ..hash)) + +(def .public (format it) + (%.Format ID) + (%.format (%.nat (the #module it)) + "." + (%.nat (the #artifact it)))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cache.lux b/stdlib/source/library/lux/meta/compiler/meta/cache.lux new file mode 100644 index 000000000..fb4085f0e --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/cache.lux @@ -0,0 +1,35 @@ +(.require + [library + [lux (.except) + [abstract + [monad (.only Monad do)]] + [control + ["[0]" try (.only Try)]] + [data + [text + ["%" \\format (.only format)]]] + [world + ["[0]" file]]]] + ["[0]" // (.only) + ["[0]" context (.only Context)] + [// + ["[0]" version]]]) + +(def .public (path fs context) + (All (_ !) (-> (file.System !) Context file.Path)) + (let [/ (at fs separator)] + (format (the context.#target context) + / (the context.#host context) + / (version.format //.version)))) + +(def .public (enabled? fs context) + (All (_ !) (-> (file.System !) Context (! Bit))) + (at fs directory? (..path fs context))) + +(def .public (enable! ! fs context) + (All (_ !) (-> (Monad !) (file.System !) Context (! (Try Any)))) + (do ! + [? (..enabled? fs context)] + (if ? + (in {try.#Success []}) + (file.make_directories ! fs (..path fs context))))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cache/archive.lux b/stdlib/source/library/lux/meta/compiler/meta/cache/archive.lux new file mode 100644 index 000000000..4174ebbe6 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/cache/archive.lux @@ -0,0 +1,24 @@ +(.require + [library + [lux (.except) + [control + [try (.only Try)]] + [data + [text + ["%" \\format]]] + [world + ["[0]" file]]]] + ["[0]" // (.only) + ["/[1]" // (.only) + [context (.only Context)] + ["[0]" archive (.only Archive)]]]) + +(def .public (descriptor fs context) + (All (_ !) (-> (file.System !) Context file.Path)) + (%.format (//.path fs context) + (at fs separator) + "descriptor")) + +(def .public (cache! fs context it) + (All (_ !) (-> (file.System !) Context Archive (! (Try Any)))) + (at fs write (..descriptor fs context) (archive.export ///.version it))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cache/artifact.lux b/stdlib/source/library/lux/meta/compiler/meta/cache/artifact.lux new file mode 100644 index 000000000..7afeba197 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/cache/artifact.lux @@ -0,0 +1,40 @@ +(.require + [library + [lux (.except) + [control + [try (.only Try)] + [concurrency + ["[0]" async (.only Async)]]] + [data + [binary (.only Binary)] + [text + ["%" \\format (.only format)]]] + [meta + [target (.only Target)]] + [world + ["[0]" file]]]] + ["[0]" // + ["[1][0]" module] + [// + ["[0]" context (.only Context)] + [archive + ["[0]" module] + ["[0]" artifact]]]]) + +(def .public (path fs context @module @artifact) + (All (_ !) + (-> (file.System !) Context module.ID artifact.ID file.Path)) + (format (//module.path fs context @module) + (at fs separator) + (%.nat @artifact) + (the context.#artifact_extension context))) + +(def .public (cache fs context @module @artifact) + (All (_ !) + (-> (file.System !) Context module.ID artifact.ID (! (Try Binary)))) + (at fs read (..path fs context @module @artifact))) + +(def .public (cache! fs context @module @artifact content) + (All (_ !) + (-> (file.System !) Context module.ID artifact.ID Binary (! (Try Any)))) + (at fs write (..path fs context @module @artifact) content)) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/artifact.lux b/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/artifact.lux new file mode 100644 index 000000000..9f1d8bf22 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/artifact.lux @@ -0,0 +1,233 @@ +... https://en.wikipedia.org/wiki/Tree_shaking +(.require + [library + [lux (.except all) + [abstract + [hash (.only Hash)] + ["[0]" monad (.only do)]] + [data + ["[0]" product] + [collection + ["[0]" list (.use "[1]#[0]" monoid mix monad)] + ["[0]" set (.only Set)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" sequence]]] + [math + [number + ["[0]" nat]]] + [meta + ["[0]" symbol] + [macro + ["^" pattern]] + [compiler + ["[0]" phase] + ["[0]" reference (.only Constant)] + [language + [lux + ["[0]" synthesis (.only Synthesis Path)] + ["[0]" generation (.only Operation)] + ["[0]" analysis + ["[1]/[0]" complex]]]] + [meta + ["[0]" archive (.only Archive) + ["[0]" artifact] + ["[0]" registry (.only Registry)] + ["[0]" unit]]]]]]]) + +(def (path_references references) + (-> (-> Synthesis (List Constant)) + (-> Path (List Constant))) + (function (again path) + (case path + (^.or {synthesis.#Pop} + {synthesis.#Access _} + {synthesis.#Bind _}) + (list) + + (^.with_template [<tag>] + [{<tag> left right} + (.all list#composite + (again left) + (again right))]) + ([synthesis.#Alt] + [synthesis.#Seq]) + + {synthesis.#Bit_Fork when then else} + (case else + {.#Some else} + (.all list#composite + (again then) + (again else)) + + {.#None} + (again then)) + + (^.with_template [<tag>] + [{<tag> fork} + (|> {.#Item fork} + (list#each (|>> product.right again)) + list#conjoint)]) + ([synthesis.#I64_Fork] + [synthesis.#F64_Fork] + [synthesis.#Text_Fork]) + + {synthesis.#Then then} + (references then)))) + +(def (references value) + (-> Synthesis (List Constant)) + (case value + {synthesis.#Simple value} + (list) + + {synthesis.#Structure value} + (case value + {analysis/complex.#Variant value} + (|> value + (the analysis/complex.#value) + references) + + {analysis/complex.#Tuple value} + (|> value + (list#each references) + list#conjoint)) + + {synthesis.#Reference value} + (case value + {reference.#Variable _} + (list) + + {reference.#Constant value} + (list value)) + + {synthesis.#Control value} + (case value + {synthesis.#Branch value} + (case value + {synthesis.#Exec this that} + (.all list#composite + (references this) + (references that)) + + {synthesis.#Let input _ body} + (.all list#composite + (references input) + (references body)) + + {synthesis.#If test then else} + (.all list#composite + (references test) + (references then) + (references else)) + + {synthesis.#Get _ record} + (references record) + + {synthesis.#Case input path} + (.all list#composite + (references input) + (path_references references path))) + + {synthesis.#Loop value} + (case value + {synthesis.#Scope value} + (let [of_inits (|> value + (the synthesis.#inits) + (list#each references)) + of_iteration (|> value + (the synthesis.#iteration) + references)] + (list#conjoint (list.partial of_iteration of_inits))) + + {synthesis.#Again value} + (|> value + (list#each references) + list#conjoint)) + + {synthesis.#Function value} + (case value + {synthesis.#Abstraction value} + (|> value + (the synthesis.#body) + references) + + {synthesis.#Apply function arguments} + (|> (list.partial function arguments) + (list#each references) + list#conjoint))) + + {synthesis.#Extension [name parameters]} + (|> parameters + (list#each references) + list#conjoint))) + +(def .public (dependencies archive value) + (All (_ anchor expression declaration) + (-> Archive Synthesis (Operation anchor expression declaration (Set unit.ID)))) + (let [! phase.monad] + (|> value + ..references + (set.of_list symbol.hash) + set.list + (monad.each ! (generation.remember archive)) + (at ! each (set.of_list unit.hash))))) + +(def .public (path_dependencies archive value) + (All (_ anchor expression declaration) + (-> Archive Path (Operation anchor expression declaration (Set unit.ID)))) + (let [! phase.monad] + (|> value + (..path_references ..references) + (set.of_list symbol.hash) + set.list + (monad.each ! (generation.remember archive)) + (at ! each (set.of_list unit.hash))))) + +(def .public all + (-> (List (Set unit.ID)) + (Set unit.ID)) + (list#mix set.union unit.none)) + +(def (immediate_dependencies archive) + (-> Archive [(List unit.ID) + (Dictionary unit.ID (Set unit.ID))]) + (|> archive + archive.entries + (list#each (function (_ [module [module_id [_module output registry]]]) + (|> registry + registry.artifacts + sequence.list + (list#each (function (_ [artifact dependencies]) + [[module_id (the artifact.#id artifact)] + (the artifact.#mandatory? artifact) + dependencies]))))) + list.together + (list#mix (function (_ [artifact_id mandatory? dependencies] + [mandatory_dependencies + all_dependencies]) + [(if mandatory? + (list.partial artifact_id mandatory_dependencies) + mandatory_dependencies) + (dictionary.has artifact_id dependencies all_dependencies)]) + [(list) + (dictionary.empty unit.hash)]))) + +(def .public (necessary_dependencies archive) + (-> Archive (Set unit.ID)) + (let [[mandatory immediate] (immediate_dependencies archive)] + (loop (again [pending mandatory + minimum unit.none]) + (case pending + {.#Item head tail} + (if (set.member? minimum head) + (again tail minimum) + (again (case (dictionary.value head immediate) + {.#Some additional} + (list#composite (set.list additional) tail) + + {.#None} + tail) + (set.has head minimum))) + + {.#End} + minimum)))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/module.lux b/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/module.lux new file mode 100644 index 000000000..0a9b6028f --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/cache/dependency/module.lux @@ -0,0 +1,99 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" maybe (.use "[1]#[0]" functor)] + ["[0]" try (.only Try)] + ["[0]" state] + [function + ["[0]" memo (.only Memo)]]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" set (.only Set)]]]]] + [//// + ["[0]" archive (.only Output Archive) + [key (.only Key)] + ["[0]" module (.only) + ["[0]" descriptor (.only Descriptor)] + ["[0]" document (.only Document)]]]]) + +(type .public Ancestry + (Set descriptor.Module)) + +(def fresh + Ancestry + (set.empty text.hash)) + +(type .public Graph + (Dictionary descriptor.Module Ancestry)) + +(def empty + Graph + (dictionary.empty text.hash)) + +(def .public modules + (-> Graph (List descriptor.Module)) + dictionary.keys) + +(type .public Dependency + (Record + [#module descriptor.Module + #imports Ancestry])) + +(def .public graph + (-> (List Dependency) Graph) + (list#mix (function (_ [module imports] graph) + (dictionary.has module imports graph)) + ..empty)) + +(def (ancestry archive) + (-> Archive Graph) + (let [memo (is (Memo descriptor.Module Ancestry) + (function (_ again module) + (do [! state.monad] + [.let [parents (case (archive.find module archive) + {try.#Success [module output registry]} + (the [module.#descriptor descriptor.#references] module) + + {try.#Failure error} + ..fresh)] + ancestors (monad.each ! again (set.list parents))] + (in (list#mix set.union parents ancestors))))) + ancestry (memo.open memo)] + (list#mix (function (_ module memory) + (if (dictionary.key? memory module) + memory + (let [[memory _] (ancestry [memory module])] + memory))) + ..empty + (archive.archived archive)))) + +(def (dependency? ancestry target source) + (-> Graph descriptor.Module descriptor.Module Bit) + (let [target_ancestry (|> ancestry + (dictionary.value target) + (maybe.else ..fresh))] + (set.member? target_ancestry source))) + +(type .public (Order a) + (List [descriptor.Module [module.ID (archive.Entry a)]])) + +(def .public (load_order key archive) + (All (_ a) (-> (Key a) Archive (Try (Order a)))) + (let [ancestry (..ancestry archive)] + (|> ancestry + dictionary.keys + (list.sorted (..dependency? ancestry)) + (monad.each try.monad + (function (_ module) + (do try.monad + [module_id (archive.id module archive) + entry (archive.find module archive) + document (document.marked? key (the [archive.#module module.#document] entry))] + (in [module [module_id (has [archive.#module module.#document] document entry)]]))))))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cache/module.lux b/stdlib/source/library/lux/meta/compiler/meta/cache/module.lux new file mode 100644 index 000000000..0e605d2e6 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/cache/module.lux @@ -0,0 +1,103 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only Monad do)]] + [control + ["[0]" pipe] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)]] + [data + [binary (.only Binary)] + ["[0]" product] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" dictionary (.only Dictionary)]]] + [meta + ["@" target]] + [world + ["[0]" file]]]] + ["[0]" // (.only) + [// + [context (.only Context)] + [archive + ["[0]" module]]]]) + +(exception .public (cannot_enable [archive file.Path + @module module.ID + error Text]) + (exception.report + "Archive" archive + "Module ID" (%.nat @module) + "Error" error)) + +(def .public (path fs context @module) + (All (_ !) (-> (file.System !) Context module.ID file.Path)) + (format (//.path fs context) + (at fs separator) + (%.nat @module))) + +(def .public (enabled? fs context @module) + (All (_ !) (-> (file.System !) Context module.ID (! Bit))) + (at fs directory? (..path fs context @module))) + +(def .public (enable! ! fs context @module) + (All (_ !) (-> (Monad !) (file.System !) Context module.ID (! (Try Any)))) + (do ! + [.let [path (..path fs context @module)] + module_exists? (at fs directory? path)] + (if module_exists? + (in {try.#Success []}) + (with_expansions [<failure> (exception.except ..cannot_enable [(//.path fs context) + @module + error])] + (do ! + [? (//.enable! ! fs context)] + (case ? + {try.#Failure error} + (in <failure>) + + success + (|> path + (at fs make_directory) + (at ! each (|>> (pipe.case + {try.#Failure error} + <failure> + + success + success)))))))))) + +(def file + file.Path + "descriptor") + +(def .public (descriptor fs context @module) + (All (_ !) (-> (file.System !) Context module.ID file.Path)) + (format (..path fs context @module) + (at fs separator) + ..file)) + +(def .public (cache! fs context @module content) + (All (_ !) (-> (file.System !) Context module.ID Binary (! (Try Any)))) + (at fs write (..descriptor fs context @module) content)) + +(def .public (cache fs context @module) + (All (_ !) (-> (file.System !) Context module.ID (! (Try Binary)))) + (at fs read (..descriptor fs context @module))) + +(def .public (artifacts ! fs context @module) + (All (_ !) (-> (Monad !) (file.System !) Context module.ID (! (Try (Dictionary Text Binary))))) + (do [! (try.with !)] + [files (at fs directory_files (..path fs context @module)) + pairs (|> files + (list#each (function (_ file) + [(file.name fs file) file])) + (list.only (|>> product.left (text#= ..file) not)) + (monad.each ! (function (_ [name path]) + (|> path + (at fs read) + (at ! each (|>> [name]))))))] + (in (dictionary.of_list text.hash (for @.old (as (List [Text Binary]) pairs) + pairs))))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cache/purge.lux b/stdlib/source/library/lux/meta/compiler/meta/cache/purge.lux new file mode 100644 index 000000000..801be1619 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/cache/purge.lux @@ -0,0 +1,83 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only Monad do)]] + [control + ["[0]" try (.only Try) (.use "[1]#[0]" functor)] + [concurrency + ["[0]" async (.only Async)]] + [function + [predicate (.only Predicate)]]] + [data + ["[0]" text (.use "[1]#[0]" equivalence)] + [collection + ["[0]" list (.use "[1]#[0]" mix functor)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" set]]] + [math + [number + ["n" nat]]] + [world + ["[0]" file]]]] + ["[0]" // + ["[1][0]" module] + ["[0]" dependency + ["[1]" module]] + ["/[1]" // + [context (.only Context)] + ["/[1]" // (.only Input)] + ["[0]" archive (.only) + [registry (.only Registry)] + ["[0]" module (.only) + ["[0]" descriptor (.only Descriptor)]]]]]) + +(type .public Cache + [Bit descriptor.Module module.ID (module.Module Any) Registry]) + +(type .public Purge + (Dictionary descriptor.Module module.ID)) + +... TODO: Make the monad parameterizable. +(def .public (purge! fs context @module) + (-> (file.System Async) Context module.ID (Async (Try Any))) + (do [! (try.with async.monad)] + [.let [cache (//module.path fs context @module)] + _ (|> cache + (at fs directory_files) + (at ! each (monad.each ! (at fs delete))) + (at ! conjoint))] + (at fs delete cache))) + +(def .public (valid? expected actual) + (-> Descriptor Input Bit) + (and (text#= (the descriptor.#name expected) + (the ////.#module actual)) + (text#= (the descriptor.#file expected) + (the ////.#file actual)) + (n.= (the descriptor.#hash expected) + (the ////.#hash actual)))) + +(def initial + (-> (List Cache) Purge) + (|>> (list.all (function (_ [valid? module_name @module _]) + (if valid? + {.#None} + {.#Some [module_name @module]}))) + (dictionary.of_list text.hash))) + +(def .public (purge caches load_order) + (-> (List Cache) (dependency.Order Any) Purge) + (list#mix (function (_ [module_name [@module entry]] purge) + (let [purged? (is (Predicate descriptor.Module) + (dictionary.key? purge))] + (if (purged? module_name) + purge + (if (|> entry + (the [archive.#module module.#descriptor descriptor.#references]) + set.list + (list.any? purged?)) + (dictionary.has module_name @module purge) + purge)))) + (..initial caches) + load_order)) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cli.lux b/stdlib/source/library/lux/meta/compiler/meta/cli.lux new file mode 100644 index 000000000..72e8b7ef1 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/cli.lux @@ -0,0 +1,115 @@ +(.require + [library + [lux (.except Module Source) + [abstract + [monad (.only do)] + [equivalence (.only Equivalence)]] + [control + ["<>" parser] + ["[0]" pipe]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format] + ["<[1]>" \\parser]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [math + [number (.only hex)]] + [meta + ["[0]" symbol] + ["[0]" configuration (.only Configuration)] + [macro + ["^" pattern]] + [compiler + [meta + [archive + [module + ["[0]" descriptor]]]]]] + ["[0]" program + ["<[1]>" \\parser (.only Parser)]] + [world + [file (.only Path)]]]] + ["[0]" / + ["[1][0]" compiler (.only Compiler)]]) + +(type .public Host_Dependency + Path) + +(type .public Library + Path) + +(type .public Source + Path) + +(type .public Target + Path) + +(type .public Module + descriptor.Module) + +(type .public Compilation + (Record + [#host_dependencies (List Host_Dependency) + #libraries (List Library) + #compilers (List Compiler) + #sources (List Source) + #target Target + #module Module + #configuration Configuration])) + +(type .public Interpretation + ..Compilation) + +(type .public Export + [(List Source) Target]) + +(type .public Service + (Variant + {#Compilation Compilation} + {#Interpretation Interpretation} + {#Export Export})) + +(with_template [<name> <long> <type> <parser>] + [(def <name> + (Parser <type>) + (<program>.named <long> <parser>))] + + [host_dependency_parser "--host_dependency" Host_Dependency <program>.any] + [library_parser "--library" Library <program>.any] + [compiler_parser "--compiler" Compiler (<text>.then /compiler.parser <program>.any)] + [source_parser "--source" Source <program>.any] + [target_parser "--target" Target <program>.any] + [module_parser "--module" Module <program>.any] + [configuration_parser "--configuration" Configuration (<text>.then configuration.parser <program>.any)] + ) + +(def .public service + (Parser Service) + (let [compilation (is (Parser Compilation) + (all <>.and + (<>.some ..host_dependency_parser) + (<>.some ..library_parser) + (<>.some ..compiler_parser) + (<>.some ..source_parser) + ..target_parser + ..module_parser + (<>.else configuration.empty ..configuration_parser)))] + (all <>.or + (<>.after (<program>.this "build") + compilation) + (<>.after (<program>.this "repl") + compilation) + (<>.after (<program>.this "export") + (all <>.and + (<>.some ..source_parser) + ..target_parser)) + ))) + +(def .public target + (-> Service Target) + (|>> (pipe.case + (^.or {#Compilation [host_dependencies libraries compilers sources target module]} + {#Interpretation [host_dependencies libraries compilers sources target module]} + {#Export [sources target]}) + target))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cli/compiler.lux b/stdlib/source/library/lux/meta/compiler/meta/cli/compiler.lux new file mode 100644 index 000000000..3f29a43a4 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/cli/compiler.lux @@ -0,0 +1,61 @@ +(.require + [library + [lux (.except parameter) + [abstract + [monad (.only do)] + [equivalence (.only Equivalence)]] + [control + ["<>" parser (.only)]] + [data + ["[0]" product] + ["[0]" text (.only) + ["%" \\format] + ["<[1]>" \\parser (.only Parser)]] + [collection + ["[0]" list (.use "[1]#[0]" functor)]]] + [math + [number (.only hex)]] + [meta + ["[0]" symbol]]]]) + +(type .public Compiler + (Record + [#definition Symbol + #parameters (List Text)])) + +(def .public equivalence + (Equivalence Compiler) + (all product.equivalence + symbol.equivalence + (list.equivalence text.equivalence) + )) + +(with_template [<ascii> <name>] + [(def <name> + Text + (text.of_char (hex <ascii>)))] + + ["02" start] + ["03" end] + ) + +(def parameter + (-> Text Text) + (text.enclosed [..start ..end])) + +(def .public (format [[module short] parameters]) + (%.Format Compiler) + (%.format (..parameter module) (..parameter short) + (text.together (list#each ..parameter parameters)))) + +(def .public parser + (Parser Compiler) + (let [parameter (is (Parser Text) + (<| (<>.after (<text>.this ..start)) + (<>.before (<text>.this ..end)) + (<text>.slice (<text>.many! (<text>.none_of! ..end)))))] + (do <>.monad + [module parameter + short parameter + parameters (<>.some parameter)] + (in [[module short] parameters])))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/context.lux b/stdlib/source/library/lux/meta/compiler/meta/context.lux new file mode 100644 index 000000000..668d828e2 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/context.lux @@ -0,0 +1,32 @@ +(.require + [library + [lux (.except) + [meta + ["@" target (.only Target)]] + [world + [file (.only Path)]]]]) + +(type .public Extension + Text) + +(type .public Context + (Record + [#host Target + #host_module_extension Extension + #target Path + #artifact_extension Extension])) + +(with_template [<name> <host> <host_module_extension> <artifact_extension>] + [(def .public (<name> target) + (-> Path Context) + [#host <host> + #host_module_extension <host_module_extension> + #target target + #artifact_extension <artifact_extension>])] + + [jvm @.jvm ".jvm" ".class"] + [js @.js ".js" ".js"] + [lua @.lua ".lua" ".lua"] + [python @.python ".py" ".py"] + [ruby @.ruby ".rb" ".rb"] + ) diff --git a/stdlib/source/library/lux/meta/compiler/meta/export.lux b/stdlib/source/library/lux/meta/compiler/meta/export.lux new file mode 100644 index 000000000..20a0bd0cd --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/export.lux @@ -0,0 +1,75 @@ +(.require + [library + [lux (.except Source) + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" try (.only Try) (.use "[1]#[0]" monad)] + [concurrency + ["[0]" async (.only Async) (.use "[1]#[0]" functor)]]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + ["[0]" binary + ["[1]" \\format]] + [collection + ["[0]" dictionary] + ["[0]" sequence]] + [format + ["[0]" tar]]] + [meta + [compiler + [meta + [cli (.only Source Export)] + ["[0]" io + ["[1]" context]]]]] + [time + ["[0]" instant]] + [world + ["[0]" file]]]]) + +(def .public file + "library.tar") + +(def .public mode + (all tar.and + tar.read_by_owner tar.write_by_owner + tar.read_by_group tar.write_by_group + tar.read_by_other)) + +(def .public ownership + tar.Ownership + (let [commons (is tar.Owner + [tar.#name tar.anonymous + tar.#id tar.no_id])] + [tar.#user commons + tar.#group commons])) + +(def .public (library fs sources) + (-> (file.System Async) (List Source) (Async (Try tar.Tar))) + (|> sources + (io.listing fs) + (async#each (|>> (try#each (|>> dictionary.entries + (monad.each try.monad + (function (_ [path source_code]) + (do try.monad + [path (|> path + (text.replaced (at fs separator) .module_separator) + tar.path)] + (try#each (|>> [path + (instant.of_millis +0) + ..mode + ..ownership] + {tar.#Normal}) + (tar.content source_code))))) + (try#each sequence.of_list))) + try#conjoint)))) + +(def .public (export fs [sources target]) + (-> (file.System Async) Export (Async (Try Any))) + (do [! (try.with async.monad)] + [tar (|> sources + (..library fs) + (at ! each (binary.result tar.format))) + .let [/ (at fs separator)]] + (at fs write (format target / ..file) tar))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/import.lux b/stdlib/source/library/lux/meta/compiler/meta/import.lux new file mode 100644 index 000000000..bb28515a9 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/import.lux @@ -0,0 +1,74 @@ +(.require + [library + [lux (.except Module) + [abstract + ["[0]" monad (.only Monad do)]] + [control + ["<>" parser] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)] + [concurrency + ["[0]" async (.only Async)]]] + [data + ["[0]" binary (.only Binary) + ["<[1]>" \\parser]] + ["[0]" text (.only) + ["%" \\format]] + [collection + ["[0]" dictionary (.only Dictionary)] + ["[0]" sequence]] + [format + ["[0]" tar]]] + [meta + [compiler + [meta + [cli (.only Library Module)]]]] + [world + ["[0]" file]]]]) + +(def Action + (type_literal (All (_ a) (Async (Try a))))) + +(exception .public useless_tar_entry) + +(exception .public (duplicate [library Library + module Module]) + (exception.report + "Module" (%.text module) + "Library" (%.text library))) + +(type .public Import + (Dictionary file.Path Binary)) + +(def (import_library system library import) + (-> (file.System Async) Library Import (Action Import)) + (let [! async.monad] + (|> library + (at system read) + (at ! each (let [! try.monad] + (|>> (at ! each (<binary>.result tar.parser)) + (at ! conjoint) + (at ! each (|>> sequence.list + (monad.mix ! (function (_ entry import) + (case entry + {tar.#Normal [path instant mode ownership content]} + (let [path (tar.from_path path)] + (case (dictionary.has' path (tar.data content) import) + {try.#Failure error} + (exception.except ..duplicate [library path]) + + import' + import')) + + _ + (exception.except ..useless_tar_entry []))) + import))) + (at ! conjoint))))))) + +(def .public (import system libraries) + (-> (file.System Async) (List Library) (Action Import)) + (monad.mix (is (Monad Action) + (try.with async.monad)) + (..import_library system) + (dictionary.empty text.hash) + libraries)) diff --git a/stdlib/source/library/lux/meta/compiler/meta/io.lux b/stdlib/source/library/lux/meta/compiler/meta/io.lux new file mode 100644 index 000000000..a7eb7545b --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/io.lux @@ -0,0 +1,21 @@ +(.require + [library + [lux (.except Code) + [data + ["[0]" text]] + [world + [file (.only Path System)]]]]) + +(type .public Context + Path) + +(type .public Code + Text) + +(def .public (safe system) + (All (_ m) (-> (System m) Text Text)) + (text.replaced "/" (at system separator))) + +(def .public lux_context + Context + "lux") diff --git a/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux b/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux new file mode 100644 index 000000000..cf8d212f8 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux @@ -0,0 +1,392 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only Monad do)]] + [control + ["<>" parser] + ["[0]" try (.only Try)] + [concurrency + ["[0]" async (.only Async) (.use "[1]#[0]" monad)]]] + [data + ["[0]" product] + ["[0]" binary (.only Binary) + ["<[1]>" \\parser (.only Parser)]] + ["[0]" text (.use "[1]#[0]" equivalence) + ["%" \\format (.only format)]] + [collection + [set (.only Set)] + ["[0]" list (.use "[1]#[0]" mix)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" sequence (.only Sequence)]]] + [meta + ["@" target (.only Target)] + ["[0]" configuration (.only Configuration)] + ["[0]" version] + [macro + ["^" pattern]]] + [world + ["[0]" file]]]] + ["[0]" // (.only) + ["[1][0]" context] + ["/[1]" // (.only) + [import (.only Import)] + ["[0]" context (.only Context)] + ["[0]" archive (.only Output Archive) + [key (.only Key)] + ["[0]" registry (.only Registry)] + ["[0]" unit] + ["[0]" artifact (.only Artifact) + ["[0]" category (.only Category)]] + ["[0]" module (.only) + ["[0]" descriptor (.only Descriptor)] + ["[0]" document (.only Document)]]] + ["[0]" cache (.only) + ["[1]/[0]" archive] + ["[1]/[0]" module] + ["[1]/[0]" purge (.only Cache Purge)] + ["[0]" dependency + ["[1]" module]]] + [// (.only Custom) + [language + ["$" lux (.only) + ["[0]" analysis] + ["[0]" synthesis] + ["[0]" generation] + ["[0]" declaration] + ["[1]/[0]" program]]]]]]) + +(def (module_parser key parser) + (All (_ document) + (-> (Key document) (Parser document) (Parser (module.Module document)))) + (all <>.and + <binary>.nat + descriptor.parser + (document.parser key parser))) + +(def (parser key parser) + (All (_ document) + (-> (Key document) (Parser document) (Parser [(module.Module document) Registry]))) + (all <>.and + (..module_parser key parser) + registry.parser)) + +(def (fresh_analysis_state host configuration) + (-> Target Configuration .Lux) + (analysis.state (analysis.info version.latest host configuration))) + +(def (analysis_state host configuration archive) + (-> Target Configuration Archive (Try .Lux)) + (do [! try.monad] + [modules (is (Try (List [descriptor.Module .Module])) + (monad.each ! (function (_ module) + (do ! + [entry (archive.find module archive) + content (|> entry + (the [archive.#module module.#document]) + (document.content $.key))] + (in [module content]))) + (archive.archived archive)))] + (in (has .#modules modules (fresh_analysis_state host configuration))))) + +(type Definitions (Dictionary Text Any)) +(type Analysers (Dictionary Text analysis.Handler)) +(type Synthesizers (Dictionary Text synthesis.Handler)) +(type Generators (Dictionary Text generation.Handler)) +(type Declarations (Dictionary Text declaration.Handler)) + +(type Bundles + [Analysers + Synthesizers + Generators + Declarations]) + +(def empty_bundles + Bundles + [(dictionary.empty text.hash) + (dictionary.empty text.hash) + (dictionary.empty text.hash) + (dictionary.empty text.hash)]) + +(def (loaded_document extension host @module expected actual document) + (All (_ expression declaration) + (-> Text (generation.Host expression declaration) module.ID (Sequence [Artifact (Set unit.ID)]) (Dictionary Text Binary) (Document .Module) + (Try [(Document .Module) Bundles Output]))) + (do [! try.monad] + [[definitions bundles] (is (Try [Definitions Bundles Output]) + (loop (again [input (sequence.list expected) + definitions (is Definitions + (dictionary.empty text.hash)) + bundles ..empty_bundles + output (is Output sequence.empty)]) + (let [[analysers synthesizers generators declarations] bundles] + (case input + {.#Item [[[@artifact artifact_category mandatory_artifact?] artifact_dependencies] input']} + (case (do ! + [data (try.of_maybe (dictionary.value (format (%.nat @artifact) extension) actual)) + .let [context [@module @artifact] + declaration (at host ingest context data)]] + (case artifact_category + {category.#Anonymous} + (do ! + [.let [output (sequence.suffix [@artifact {.#None} data] output)] + _ (at host re_learn context {.#None} declaration)] + (in [definitions + [analysers + synthesizers + generators + declarations] + output])) + + {category.#Definition [name function_artifact]} + (let [output (sequence.suffix [@artifact {.#None} data] output)] + (if (text#= $/program.name name) + (in [definitions + [analysers + synthesizers + generators + declarations] + output]) + (do ! + [value (at host re_load context {.#None} declaration)] + (in [(dictionary.has name value definitions) + [analysers + synthesizers + generators + declarations] + output])))) + + {category.#Analyser extension} + (do ! + [.let [output (sequence.suffix [@artifact {.#None} data] output)] + value (at host re_load context {.#None} declaration)] + (in [definitions + [(dictionary.has extension (as analysis.Handler value) analysers) + synthesizers + generators + declarations] + output])) + + {category.#Synthesizer extension} + (do ! + [.let [output (sequence.suffix [@artifact {.#None} data] output)] + value (at host re_load context {.#None} declaration)] + (in [definitions + [analysers + (dictionary.has extension (as synthesis.Handler value) synthesizers) + generators + declarations] + output])) + + {category.#Generator extension} + (do ! + [.let [output (sequence.suffix [@artifact {.#None} data] output)] + value (at host re_load context {.#None} declaration)] + (in [definitions + [analysers + synthesizers + (dictionary.has extension (as generation.Handler value) generators) + declarations] + output])) + + {category.#Declaration extension} + (do ! + [.let [output (sequence.suffix [@artifact {.#None} data] output)] + value (at host re_load context {.#None} declaration)] + (in [definitions + [analysers + synthesizers + generators + (dictionary.has extension (as declaration.Handler value) declarations)] + output])) + + {category.#Custom name} + (do ! + [.let [output (sequence.suffix [@artifact {.#Some name} data] output)] + _ (at host re_learn context {.#Some name} declaration)] + (in [definitions + [analysers + synthesizers + generators + declarations] + output])))) + {try.#Success [definitions' bundles' output']} + (again input' definitions' bundles' output') + + failure + failure) + + {.#End} + {try.#Success [definitions bundles output]})))) + content (document.content $.key document) + definitions (monad.each ! (function (_ [def_name def_global]) + (case def_global + (^.with_template [<tag>] + [{<tag> payload} + (in [def_name {<tag> payload}])]) + ([.#Alias] + [.#Tag] + [.#Slot]) + + {.#Definition [exported? type _]} + (|> definitions + (dictionary.value def_name) + try.of_maybe + (at ! each (|>> [exported? type] + {.#Definition} + [def_name]))) + + {.#Type [exported? _ labels]} + (|> definitions + (dictionary.value def_name) + try.of_maybe + (at ! each (function (_ def_value) + [def_name {.#Type [exported? (as .Type def_value) labels]}]))))) + (the .#definitions content))] + (in [(document.document $.key (has .#definitions definitions content)) + bundles]))) + +(def (load_definitions fs context @module host_environment entry) + (All (_ expression declaration) + (-> (file.System Async) Context module.ID (generation.Host expression declaration) + (archive.Entry .Module) + (Async (Try [(archive.Entry .Module) Bundles])))) + (do (try.with async.monad) + [actual (is (Async (Try (Dictionary Text Binary))) + (cache/module.artifacts async.monad fs context @module)) + .let [expected (registry.artifacts (the archive.#registry entry))] + [document bundles output] (|> (the [archive.#module module.#document] entry) + (loaded_document (the context.#artifact_extension context) host_environment @module expected actual) + async#in)] + (in [(|> entry + (has [archive.#module module.#document] document) + (has archive.#output output)) + bundles]))) + +(def pseudo_module + Text + "(Lux Caching System)") + +(def (cache_parser customs) + (-> (List Custom) (Parser [(module.Module Any) Registry])) + (case (for @.old (as (List (Custom Any Any Any)) + customs) + customs) + {.#End} + (..parser $.key $.parser) + + {.#Item [custom_state custom_key custom_format custom_parser custom_compiler] tail} + (all <>.either + (..parser custom_key custom_parser) + (cache_parser tail) + ))) + +(def (valid_cache customs fs context import contexts [module_name @module]) + (-> (List Custom) (file.System Async) Context Import (List //.Context) + [descriptor.Module module.ID] + (Async (Try Cache))) + (with_expansions [<cache> (these module_name @module module registry)] + (do [! (try.with async.monad)] + [data (is (Async (Try Binary)) + (cache/module.cache fs context @module)) + [module registry] (async#in (<binary>.result (..cache_parser customs) data))] + (if (text#= descriptor.runtime module_name) + (in [true <cache>]) + (do ! + [input (//context.read fs ..pseudo_module import contexts (the context.#host_module_extension context) module_name)] + (in [(cache/purge.valid? (the module.#descriptor module) input) <cache>])))))) + +(def (pre_loaded_caches customs fs context import contexts archive) + (-> (List Custom) (file.System Async) Context Import (List //.Context) Archive + (Async (Try (List Cache)))) + (do [! (try.with async.monad)] + [... TODO: Stop needing to wrap this expression in an unnecessary "do" expression. + it (|> archive + archive.reservations + (monad.each ! (..valid_cache customs fs context import contexts)))] + (in it))) + +(def (load_order archive pre_loaded_caches) + (-> Archive (List Cache) + (Try (dependency.Order .Module))) + (|> pre_loaded_caches + (monad.mix try.monad + (function (_ [_ [module @module |module| registry]] archive) + (archive.has module + [archive.#module |module| + archive.#output (is Output sequence.empty) + archive.#registry registry] + archive)) + archive) + (at try.monad each (dependency.load_order $.key)) + (at try.monad conjoint))) + +(def (loaded_caches host_environment fs context purge load_order) + (All (_ expression declaration) + (-> (generation.Host expression declaration) (file.System Async) Context + Purge (dependency.Order .Module) + (Async (Try (List [[descriptor.Module (archive.Entry .Module)] Bundles]))))) + (do [! (try.with async.monad)] + [... TODO: Stop needing to wrap this expression in an unnecessary "do" expression. + it (|> load_order + (list.only (|>> product.left (dictionary.key? purge) not)) + (monad.each ! (function (_ [module_name [@module entry]]) + (do ! + [[entry bundles] (with_expansions [<it> (..load_definitions fs context @module host_environment entry)] + (for @.old (as (Async (Try [(archive.Entry .Module) Bundles])) + <it>) + <it>))] + (in (with_expansions [<it> [[module_name entry] + bundles]] + (for @.old (as [[descriptor.Module (archive.Entry .Module)] Bundles] + <it>) + <it>)))))))] + (in it))) + +(def (load_every_reserved_module customs configuration host_environment fs context import contexts archive) + (All (_ expression declaration) + (-> (List Custom) Configuration (generation.Host expression declaration) (file.System Async) Context Import (List //.Context) Archive + (Async (Try [Archive .Lux Bundles])))) + (do [! (try.with async.monad)] + [pre_loaded_caches (..pre_loaded_caches customs fs context import contexts archive) + load_order (async#in (load_order archive pre_loaded_caches)) + .let [purge (cache/purge.purge pre_loaded_caches load_order)] + _ (|> purge + dictionary.entries + (monad.each ! (|>> product.right (cache/purge.purge! fs context)))) + loaded_caches (..loaded_caches host_environment fs context purge load_order)] + (async#in + (do [! try.monad] + [archive (monad.mix ! + (function (_ [[module entry] _bundle] archive) + (archive.has module entry archive)) + archive + loaded_caches) + analysis_state (..analysis_state (the context.#host context) configuration archive)] + (in [archive + analysis_state + (list#mix (function (_ [_ [+analysers +synthesizers +generators +declarations]] + [analysers synthesizers generators declarations]) + [(dictionary.composite +analysers analysers) + (dictionary.composite +synthesizers synthesizers) + (dictionary.composite +generators generators) + (dictionary.composite +declarations declarations)]) + ..empty_bundles + loaded_caches)]))))) + +(def .public (thaw customs configuration host_environment fs context import contexts) + (All (_ expression declaration) + (-> (List Custom) Configuration (generation.Host expression declaration) (file.System Async) Context Import (List //.Context) + (Async (Try [Archive .Lux Bundles])))) + (do async.monad + [binary (at fs read (cache/archive.descriptor fs context))] + (case binary + {try.#Success binary} + (do (try.with async.monad) + [archive (async#in (archive.import ///.version binary))] + (..load_every_reserved_module customs configuration host_environment fs context import contexts archive)) + + {try.#Failure error} + (in {try.#Success [archive.empty + (fresh_analysis_state (the context.#host context) configuration) + ..empty_bundles]})))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/io/context.lux b/stdlib/source/library/lux/meta/compiler/meta/io/context.lux new file mode 100644 index 000000000..3bf9f0397 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/io/context.lux @@ -0,0 +1,190 @@ +(.require + [library + [lux (.except Module Code) + [abstract + ["[0]" monad (.only Monad do)]] + [control + ["[0]" maybe] + ["[0]" try (.only Try)] + ["[0]" exception (.only exception)] + [concurrency + ["[0]" async (.only Async) (.use "[1]#[0]" monad)]] + [function + [predicate (.only Predicate)]]] + [data + [binary (.only Binary)] + ["[0]" text (.use "[1]#[0]" hash) + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" dictionary (.only Dictionary)] + ["[0]" list]]] + [meta + ["@" target]] + [world + ["[0]" file]]]] + ["[0]" // (.only Context Code) + ["/[1]" // + [import (.only Import)] + ["/[1]" // (.only Input)] + [archive + [module + [descriptor (.only Module)]]]]]) + +(exception .public (cannot_find_module [importer Module + module Module]) + (exception.report + "Module" (%.text module) + "Importer" (%.text importer))) + +(exception .public (cannot_read_module [module Module]) + (exception.report + "Module" (%.text module))) + +(type .public Extension + Text) + +(def .public lux_extension + Extension + ".lux") + +(def .public (path fs context module) + (All (_ m) (-> (file.System m) Context Module file.Path)) + (|> module + (//.safe fs) + (format context (at fs separator)))) + +(def (find_source_file fs importer contexts module extension) + (-> (file.System Async) Module (List Context) Module Extension + (Async (Try file.Path))) + (case contexts + {.#End} + (async#in (exception.except ..cannot_find_module [importer module])) + + {.#Item context contexts'} + (let [path (format (..path fs context module) extension)] + (do async.monad + [? (at fs file? path)] + (if ? + (in {try.#Success path}) + (find_source_file fs importer contexts' module extension)))))) + +(def (full_host_extension partial_host_extension) + (-> Extension Extension) + (format partial_host_extension ..lux_extension)) + +(def (find_local_source_file fs importer import contexts partial_host_extension module) + (-> (file.System Async) Module Import (List Context) Extension Module + (Async (Try [file.Path Binary]))) + ... Preference is explicitly being given to Lux files that have a host extension. + ... Normal Lux files (i.e. without a host extension) are then picked as fallback files. + (do [! async.monad] + [outcome (..find_source_file fs importer contexts module (..full_host_extension partial_host_extension))] + (case outcome + {try.#Success path} + (|> path + (at fs read) + (at (try.with !) each (|>> [path]))) + + {try.#Failure _} + (do [! (try.with !)] + [path (..find_source_file fs importer contexts module ..lux_extension)] + (|> path + (at fs read) + (at ! each (|>> [path]))))))) + +(def (find_library_source_file importer import partial_host_extension module) + (-> Module Import Extension Module (Try [file.Path Binary])) + (let [path (format module (..full_host_extension partial_host_extension))] + (case (dictionary.value path import) + {.#Some data} + {try.#Success [path data]} + + {.#None} + (let [path (format module ..lux_extension)] + (case (dictionary.value path import) + {.#Some data} + {try.#Success [path data]} + + {.#None} + (exception.except ..cannot_find_module [importer module])))))) + +(def (find_any_source_file fs importer import contexts partial_host_extension module) + (-> (file.System Async) Module Import (List Context) Extension Module + (Async (Try [file.Path Binary]))) + ... Preference is explicitly being given to Lux files that have a host extension. + ... Normal Lux files (i.e. without a host extension) are then picked as fallback files. + (do [! async.monad] + [outcome (find_local_source_file fs importer import contexts partial_host_extension module)] + (case outcome + {try.#Success [path data]} + (in outcome) + + {try.#Failure _} + (in (..find_library_source_file importer import partial_host_extension module))))) + +(def .public (read fs importer import contexts partial_host_extension module) + (-> (file.System Async) Module Import (List Context) Extension Module + (Async (Try Input))) + (do (try.with async.monad) + [[path binary] (..find_any_source_file fs importer import contexts partial_host_extension module)] + (case (at utf8.codec decoded binary) + {try.#Success code} + (in [////.#module module + ////.#file path + ////.#hash (text#hash code) + ////.#code code]) + + {try.#Failure _} + (async#in (exception.except ..cannot_read_module [module]))))) + +(type .public Enumeration + (Dictionary file.Path Binary)) + +(def (context_listing fs context directory enumeration) + (-> (file.System Async) Context file.Path Enumeration (Async (Try Enumeration))) + (do [! (try.with async.monad)] + [enumeration (|> directory + (at fs directory_files) + (at ! each (monad.mix ! (function (_ file enumeration) + (if (text.ends_with? ..lux_extension file) + (do ! + [source_code (at fs read file)] + (async#in (dictionary.has' (text.replaced_once context "" file) source_code enumeration))) + (in enumeration))) + enumeration)) + (at ! conjoint))] + (|> directory + (at fs sub_directories) + (at ! each (monad.mix ! (context_listing fs context) enumeration)) + (at ! conjoint)))) + +(def Action + (type_literal (All (_ a) (Async (Try a))))) + +(def (canonical fs context) + (-> (file.System Async) Context (Action Context)) + (do (try.with async.monad) + [subs (at fs sub_directories context)] + (in (|> subs + list.head + (maybe.else context) + (file.parent fs) + (maybe.else context))))) + +(def .public (listing fs contexts) + (-> (file.System Async) (List Context) (Action Enumeration)) + (let [! (is (Monad Action) + (try.with async.monad))] + (monad.mix ! + (function (_ context enumeration) + (do ! + [context (..canonical fs context)] + (..context_listing fs + (format context (at fs separator)) + context + enumeration))) + (is Enumeration + (dictionary.empty text.hash)) + contexts))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/packager.lux b/stdlib/source/library/lux/meta/compiler/meta/packager.lux new file mode 100644 index 000000000..a7e8a095c --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/packager.lux @@ -0,0 +1,44 @@ +(.require + [library + [lux (.except) + [control + [try (.only Try)]] + [data + [binary (.only Binary)] + ["[0]" product] + [collection + [dictionary (.only Dictionary)] + ["[0]" sequence] + ["[0]" list (.use "[1]#[0]" functor)]]] + [world + ["[0]" file]]]] + [// + ["[0]" cache + [dependency + ["[1]/[0]" module]]] + ["[0]" archive (.only Archive) + ["[0]" artifact] + ["[0]" registry] + ["[0]" unit] + ["[0]" module (.only) + ["[0]" descriptor]]]]) + +(type .public Packager + (-> (Dictionary file.Path Binary) + Archive + (Maybe unit.ID) + (Try (Either Binary + (List [Text Binary]))))) + +(type .public Order + (List [module.ID (List artifact.ID)])) + +(def .public order + (-> (cache/module.Order Any) Order) + (list#each (function (_ [module [module_id entry]]) + (|> entry + (the archive.#registry) + registry.artifacts + sequence.list + (list#each (|>> product.left (the artifact.#id))) + [module_id])))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/packager/jvm.lux b/stdlib/source/library/lux/meta/compiler/meta/packager/jvm.lux new file mode 100644 index 000000000..b783f1262 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/packager/jvm.lux @@ -0,0 +1,294 @@ +(.require + [library + [lux (.except Module Definition) + ["[0]" ffi (.only import to)] + [abstract + ["[0]" monad (.only Monad do)]] + [control + ["[0]" maybe (.use "[1]#[0]" functor)] + ["[0]" try (.only Try)]] + [data + ["[0]" binary (.only Binary)] + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" sequence] + ["[0]" list (.use "[1]#[0]" functor)] + ["[0]" dictionary] + ["[0]" set (.only Set)]]] + [math + [number + ["n" nat] + ["i" int]]] + [meta + [target + [jvm + [encoding + ["[0]" name]]]]] + [world + ["[0]" file]]]] + ["[0]" // (.only Packager) + [// + ["[0]" context (.only Context)] + ["[0]" archive (.only Output) + ["[0]" artifact] + ["[0]" unit] + ["[0]" module (.only) + ["[0]" descriptor (.only Module)]]] + ["[0]" cache + [dependency + ["[1]/[0]" module] + ["[1]/[0]" artifact]]] + ["[0]" io + ["[1]" archive]] + [// + [language + ["$" lux (.only) + [phase + [generation + [jvm + ["[0]" runtime (.only Definition)]]]]]]]]]) + +(import java/lang/Object + "[1]::[0]") + +(import java/lang/String + "[1]::[0]") + +(import java/util/jar/Attributes + "[1]::[0]" + (put [java/lang/Object java/lang/Object] "?" java/lang/Object)) + +(import java/util/jar/Attributes$Name + "[1]::[0]" + ("read_only" "static" MAIN_CLASS java/util/jar/Attributes$Name) + ("read_only" "static" MANIFEST_VERSION java/util/jar/Attributes$Name)) + +(import java/util/jar/Manifest + "[1]::[0]" + (new []) + (getMainAttributes [] java/util/jar/Attributes)) + +(import java/io/Flushable + "[1]::[0]" + (flush [] void)) + +(import java/io/Closeable + "[1]::[0]" + (close [] void)) + +(import java/io/OutputStream + "[1]::[0]" + (write [[byte] int int] void)) + +(import java/io/ByteArrayOutputStream + "[1]::[0]" + (new [int]) + (toByteArray [] [byte])) + +(import java/util/zip/ZipEntry + "[1]::[0]" + (getName [] java/lang/String) + (isDirectory [] boolean) + (getSize [] long)) + +(import java/util/zip/ZipOutputStream + "[1]::[0]" + (write [[byte] int int] void) + (closeEntry [] void)) + +(import java/util/jar/JarEntry + "[1]::[0]" + (new [java/lang/String])) + +(import java/util/jar/JarOutputStream + "[1]::[0]" + (new [java/io/OutputStream java/util/jar/Manifest]) + (putNextEntry [java/util/zip/ZipEntry] "try" void)) + +(import java/io/ByteArrayInputStream + "[1]::[0]" + (new [[byte]])) + +(import java/io/InputStream + "[1]::[0]" + (read [[byte] int int] int)) + +(import java/util/jar/JarInputStream + "[1]::[0]" + (new [java/io/InputStream]) + (getNextJarEntry [] "try" "?" java/util/jar/JarEntry)) + +(def byte + 1) + +... https://en.wikipedia.org/wiki/Kibibyte +(def kibi_byte + (n.* 1,024 byte)) + +... https://en.wikipedia.org/wiki/Mebibyte +(def mebi_byte + (n.* 1,024 kibi_byte)) + +(def manifest_version + "1.0") + +(def (manifest program) + (-> (Maybe unit.ID) java/util/jar/Manifest) + (let [manifest (java/util/jar/Manifest::new) + attrs (to (java/util/jar/Manifest::getMainAttributes manifest) + (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) + (ffi.as_string ..manifest_version)))] + (exec + (case program + {.#Some program} + (to attrs + (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) + (|> program + runtime.class_name + name.internal + name.external + ffi.as_string))) + + {.#None} + attrs) + manifest))) + +(def (write_class static module artifact custom content sink) + (-> Context module.ID artifact.ID (Maybe Text) Binary java/util/jar/JarOutputStream + (Try java/util/jar/JarOutputStream)) + (let [class_path (|> custom + (maybe#each (|>> name.internal name.read)) + (maybe.else (runtime.class_name [module artifact])) + (text.replaced "." "/") + (text.suffix (the context.#artifact_extension static)))] + (do try.monad + [_ (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new (ffi.as_string class_path)) + sink)] + (in (to sink + (java/util/zip/ZipOutputStream::write content (ffi.as_int +0) (ffi.as_int (.int (binary.size content)))) + (java/io/Flushable::flush) + (java/util/zip/ZipOutputStream::closeEntry)))))) + +(def (write_module static necessary_dependencies [module output] sink) + (-> Context (Set unit.ID) [module.ID Output] java/util/jar/JarOutputStream + (Try java/util/jar/JarOutputStream)) + (let [! try.monad] + (monad.mix try.monad + (function (_ [artifact custom content] sink) + (if (set.member? necessary_dependencies [module artifact]) + (..write_class static module artifact custom content sink) + (at ! in sink))) + sink + (sequence.list output)))) + +(def (read_jar_entry_with_unknown_size input) + (-> java/util/jar/JarInputStream [Nat Binary]) + (let [chunk (binary.empty ..mebi_byte) + chunk_size (.int ..mebi_byte) + buffer (java/io/ByteArrayOutputStream::new (ffi.as_int chunk_size))] + (loop (again [so_far 0]) + (case (ffi.of_int (java/io/InputStream::read chunk (ffi.as_int +0) (ffi.as_int chunk_size) input)) + -1 + [so_far + (java/io/ByteArrayOutputStream::toByteArray buffer)] + + bytes_read + (exec + (java/io/OutputStream::write chunk (ffi.as_int +0) (ffi.as_int bytes_read) buffer) + (again (|> bytes_read .nat (n.+ so_far)))))))) + +(def (read_jar_entry_with_known_size expected_size input) + (-> Nat java/util/jar/JarInputStream [Nat Binary]) + (let [buffer (binary.empty expected_size)] + (loop (again [so_far 0]) + (let [so_far' (|> input + (java/io/InputStream::read buffer (ffi.as_int (.int so_far)) (ffi.as_int (.int (n.- so_far expected_size)))) + ffi.of_int + .nat + (n.+ so_far))] + (if (n.= expected_size so_far') + [expected_size buffer] + (again so_far')))))) + +(def (read_jar_entry entry input) + (-> java/util/jar/JarEntry java/util/jar/JarInputStream [Nat Binary]) + (case (ffi.of_long (java/util/zip/ZipEntry::getSize entry)) + -1 + (..read_jar_entry_with_unknown_size input) + + entry_size + (..read_jar_entry_with_known_size (.nat entry_size) input))) + +(def (write_host_dependency jar [entries duplicates sink]) + (-> Binary + [(Set file.Path) (Set file.Path) java/util/jar/JarOutputStream] + (Try [(Set file.Path) (Set file.Path) java/util/jar/JarOutputStream])) + (let [input (|> jar + java/io/ByteArrayInputStream::new + java/util/jar/JarInputStream::new)] + (loop (again [entries entries + duplicates duplicates + sink sink]) + (case (java/util/jar/JarInputStream::getNextJarEntry input) + {try.#Failure error} + {try.#Failure error} + + {try.#Success ?entry} + (case ?entry + {.#None} + (exec + (java/io/Closeable::close input) + {try.#Success [entries duplicates sink]}) + + {.#Some entry} + (let [entry_path (ffi.of_string (java/util/zip/ZipEntry::getName entry)) + entry_size (ffi.of_long (java/util/zip/ZipEntry::getSize entry))] + (if (not (or (ffi.of_boolean (java/util/zip/ZipEntry::isDirectory entry)) + (or (text.starts_with? "META-INF/maven/" entry_path) + (text.starts_with? "META-INF/leiningen/" entry_path)) + (or (text.ends_with? ".SF" entry_path) + (text.ends_with? ".DSA" entry_path)))) + (case (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new (ffi.as_string entry_path)) + sink) + {try.#Failure error} + (again entries + (set.has entry_path duplicates) + sink) + + {try.#Success _} + (let [[entry_size entry_data] (read_jar_entry entry input)] + (again (set.has entry_path entries) + duplicates + (to sink + (java/util/zip/ZipOutputStream::write entry_data (ffi.as_int +0) (ffi.as_int (.int entry_size))) + (java/io/Flushable::flush) + (java/util/zip/ZipOutputStream::closeEntry))))) + (again entries + duplicates + sink)))))))) + +(def .public (package static) + (-> Context Packager) + (function (_ host_dependencies archive program) + (do [! try.monad] + [.let [necessary_dependencies (cache/artifact.necessary_dependencies archive)] + order (cache/module.load_order $.key archive) + .let [buffer (java/io/ByteArrayOutputStream::new (ffi.as_int (.int ..mebi_byte)))] + sink (|> order + (list#each (function (_ [module [module_id entry]]) + [module_id (the archive.#output entry)])) + (monad.mix ! (..write_module static necessary_dependencies) + (java/util/jar/JarOutputStream::new buffer (..manifest program)))) + [entries duplicates sink] (|> host_dependencies + dictionary.values + (monad.mix ! ..write_host_dependency + [(set.empty text.hash) + (set.empty text.hash) + sink])) + .let [_ (to sink + (java/io/Flushable::flush) + (java/io/Closeable::close))]] + (in (|> buffer + java/io/ByteArrayOutputStream::toByteArray + {.#Left}))))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/packager/ruby.lux b/stdlib/source/library/lux/meta/compiler/meta/packager/ruby.lux new file mode 100644 index 000000000..39bc028af --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/packager/ruby.lux @@ -0,0 +1,140 @@ +(.require + [library + [lux (.except) + [type (.only sharing)] + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" try (.only Try)]] + [data + [binary (.only Binary)] + ["[0]" product] + ["[0]" text (.only) + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" sequence] + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" set (.only Set)]]] + [math + [number + ["[0]" nat]]] + [meta + [target + ["_" ruby]]] + [world + ["[0]" file]]]] + ["[0]" // (.only Packager) + [// + ["[0]" archive (.only Output) + [registry (.only Registry)] + ["[0]" artifact] + ["[0]" unit] + ["[0]" module (.only) + ["[0]" descriptor] + ["[0]" document (.only Document)]]] + ["[0]" cache + [dependency + ["[1]/[0]" module (.only Order)] + ["[1]/[0]" artifact]]] + ["[0]" io + ["[1]" archive]] + [// + [language + ["$" lux]]]]]) + +(def (bundle_module module module_id necessary_dependencies output) + (-> descriptor.Module module.ID (Set unit.ID) Output (Try (Maybe _.Statement))) + (do [! try.monad] + [] + (case (|> output + sequence.list + (list.only (function (_ [artifact_id custom content]) + (set.member? necessary_dependencies [module_id artifact_id])))) + {.#End} + (in {.#None}) + + artifacts + (do ! + [bundle (monad.mix ! + (function (_ [artifact custom_name content] so_far) + (|> content + (at utf8.codec decoded) + (at ! each + (|>> as_expected + (is declaration) + (sharing [declaration] + (is declaration + so_far)) + (_.then so_far))))) + (_.comment "Lux module" + (_.statement (_.string ""))) + artifacts)] + (in {.#Some bundle}))))) + +(def module_file + (-> module.ID file.Path) + (|>> %.nat (text.suffix ".rb"))) + +(def (write_module mapping necessary_dependencies [module [module_id entry]] sink) + (-> (Dictionary descriptor.Module module.ID) (Set unit.ID) + [descriptor.Module [module.ID (archive.Entry .Module)]] + (List [module.ID [Text Binary]]) + (Try (List [module.ID [Text Binary]]))) + (do [! try.monad] + [bundle (is (Try (Maybe _.Statement)) + (..bundle_module module module_id necessary_dependencies (the archive.#output entry)))] + (case bundle + {.#None} + (in sink) + + {.#Some bundle} + (let [entry_content (|> (list) + (list#mix _.then bundle) + (is _.Statement) + _.code + (at utf8.codec encoded))] + (in (list.partial [module_id [(..module_file module_id) entry_content]] + sink)))))) + +(def .public main_file + "main.rb") + +(def module_id_mapping + (-> (Order .Module) (Dictionary descriptor.Module module.ID)) + (|>> (list#each (function (_ [module [module_id entry]]) + [module module_id])) + (dictionary.of_list text.hash))) + +(def included_modules + (All (_ a) (-> (List [module.ID a]) (Set module.ID))) + (|>> (list#each product.left) + (list#mix set.has (set.empty nat.hash)))) + +(def .public (package host_dependencies archive program) + Packager + (do [! try.monad] + [.let [necessary_dependencies (cache/artifact.necessary_dependencies archive)] + order (cache/module.load_order $.key archive) + entries (monad.mix ! (..write_module (module_id_mapping order) necessary_dependencies) {.#End} order) + .let [included_modules (..included_modules entries) + imports (|> order + (list.only (|>> product.right product.left (set.member? included_modules))) + list.reversed + (list#each (function (_ [module [module_id entry]]) + (let [relative_path (_.do "gsub" (list (_.string main_file) + (_.string (..module_file module_id))) + {.#None} + (is _.CVar (_.manual "__FILE__")))] + (_.statement (_.require/1 relative_path))))) + (list#mix _.then (_.comment "Lux program" + (_.statement (_.string "")))) + (is _.Statement) + _.code + (at utf8.codec encoded))]] + (in (|> entries + (list#each product.right) + {.#Item [..main_file imports]} + {.#Right})))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/packager/scheme.lux b/stdlib/source/library/lux/meta/compiler/meta/packager/scheme.lux new file mode 100644 index 000000000..b98361ff0 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/packager/scheme.lux @@ -0,0 +1,132 @@ +(.require + [library + [lux (.except Module) + [type (.only sharing)] + [abstract + ["[0]" monad (.only do)]] + [control + ["[0]" try (.only Try)]] + [data + ["[0]" product] + ["[0]" binary (.only Binary) + ["[1]" \\format]] + ["[0]" text (.only) + ["%" \\format (.only format)] + ["[0]" encoding]] + [collection + ["[0]" sequence] + ["[0]" list (.use "[1]#[0]" functor mix)] + ["[0]" dictionary (.only Dictionary)] + ["[0]" set]] + [format + ["[0]" tar]]] + [meta + [target + ["_" scheme]]] + [time + ["[0]" instant (.only Instant)]] + [world + ["[0]" file]]]] + [program + [compositor + ["[0]" static (.only Static)]]] + ["[0]" // (.only Packager) + [// + ["[0]" archive (.only Output) + ["[0]" descriptor (.only Module Descriptor)] + ["[0]" artifact] + ["[0]" document (.only Document)]] + [cache + ["[0]" dependency]] + ["[0]" io + ["[1]" archive]] + [// + [language + ["$" lux (.only) + [generation (.only Context)]]]]]]) + +... TODO: Delete ASAP +(type (Action ! a) + (! (Try a))) + +(def (then pre post) + (-> _.Expression _.Expression _.Expression) + (_.manual (format (_.code pre) + text.new_line + (_.code post)))) + +(def bundle_module + (-> Output (Try _.Expression)) + (|>> sequence.list + (list#each product.right) + (monad.mix try.monad + (function (_ content so_far) + (|> content + (at encoding.utf8 decoded) + (at try.monad each + (|>> as_expected + (is declaration) + (sharing [declaration] + (is declaration + so_far)) + (..then so_far))))) + (is _.Expression (_.manual ""))))) + +(def module_file + (-> archive.ID file.Path) + (|>> %.nat (text.suffix ".scm"))) + +(def mode + tar.Mode + (all tar.and + tar.read_by_group + tar.read_by_owner + + tar.write_by_other + tar.write_by_group + tar.write_by_owner)) + +(def owner + tar.Owner + [tar.#name tar.anonymous + tar.#id tar.no_id]) + +(def ownership + [tar.#user ..owner + tar.#group ..owner]) + +(def (write_module now mapping [module [module_id [descriptor document output]]]) + (-> Instant (Dictionary Module archive.ID) + [Module [archive.ID [Descriptor (Document .Module) Output]]] + (Try tar.Entry)) + (do [! try.monad] + [bundle (is (Try _.Expression) + (..bundle_module output)) + entry_content (is (Try tar.Content) + (|> descriptor + (the descriptor.#references) + set.list + (list.all (function (_ module) (dictionary.value module mapping))) + (list#each (|>> ..module_file _.string _.load_relative/1)) + (list#mix ..then bundle) + (is _.Expression) + _.code + (at encoding.utf8 encoded) + tar.content)) + module_file (tar.path (..module_file module_id))] + (in {tar.#Normal [module_file now ..mode ..ownership entry_content]}))) + +(def .public (package now) + (-> Instant Packager) + (function (package host_dependencies archive program) + (do [! try.monad] + [order (dependency.load_order $.key archive) + .let [mapping (|> order + (list#each (function (_ [module [module_id [descriptor document output]]]) + [module module_id])) + (dictionary.of_list text.hash) + (is (Dictionary Module archive.ID)))] + entries (monad.each ! (..write_module now mapping) order)] + (in (|> entries + sequence.of_list + (binary.result tar.format)))))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/packager/script.lux b/stdlib/source/library/lux/meta/compiler/meta/packager/script.lux new file mode 100644 index 000000000..84f1d9a42 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/meta/packager/script.lux @@ -0,0 +1,79 @@ +(.require + [library + [lux (.except) + [abstract + ["[0]" monad (.only Monad do)]] + [control + ["[0]" try (.only Try)]] + [data + [binary (.only Binary)] + ["[0]" product] + [text + ["%" \\format (.only format)] + [encoding + ["[0]" utf8]]] + [collection + ["[0]" sequence] + ["[0]" set (.only Set)] + ["[0]" list (.use "[1]#[0]" functor)]]] + [meta + [type (.only sharing)]]]] + ["[0]" // (.only Packager) + [// + ["[0]" archive (.only Output) + ["[0]" artifact] + ["[0]" unit] + ["[0]" module (.only) + ["[0]" descriptor]]] + ["[0]" cache + [dependency + ["[1]/[0]" module] + ["[1]/[0]" artifact]]] + ["[0]" io + ["[1]" archive]] + [// + [language + ["$" lux]]]]]) + +(def (write_module necessary_dependencies sequence [module_id output] so_far) + (All (_ declaration) + (-> (Set unit.ID) (-> declaration declaration declaration) [module.ID Output] declaration + (Try declaration))) + (|> output + sequence.list + (list.all (function (_ [artifact_id custom content]) + (if (set.member? necessary_dependencies [module_id artifact_id]) + {.#Some content} + {.#None}))) + (monad.mix try.monad + (function (_ content so_far) + (|> content + (at utf8.codec decoded) + (at try.monad each + (|>> as_expected + (is declaration) + (sharing [declaration] + (is declaration + so_far)) + (sequence so_far))))) + so_far))) + +(def .public (package header code sequence scope) + (All (_ declaration) + (-> declaration + (-> declaration Text) + (-> declaration declaration declaration) + (-> declaration declaration) + Packager)) + (function (package host_dependencies archive program) + (do [! try.monad] + [.let [necessary_dependencies (cache/artifact.necessary_dependencies archive)] + order (cache/module.load_order $.key archive)] + (|> order + (list#each (function (_ [module [module_id entry]]) + [module_id (the archive.#output entry)])) + (monad.mix ! (..write_module necessary_dependencies sequence) header) + (at ! each (|>> scope + code + (at utf8.codec encoded) + {.#Left})))))) diff --git a/stdlib/source/library/lux/meta/compiler/phase.lux b/stdlib/source/library/lux/meta/compiler/phase.lux new file mode 100644 index 000000000..a0b4df481 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/phase.lux @@ -0,0 +1,129 @@ +(.require + [library + [lux (.except except with) + [abstract + [functor (.only Functor)] + [monad (.only Monad do)]] + [control + ["[0]" state] + ["[0]" try (.only Try) (.use "[1]#[0]" functor)] + ["[0]" exception (.only Exception)] + ["[0]" io]] + [data + ["[0]" product] + [text + ["%" \\format (.only format)]]] + [time + ["[0]" instant] + ["[0]" duration]]]] + [// + [meta + [archive (.only Archive)]]]) + +(type .public (Operation s o) + (state.+State Try s o)) + +(def .public functor + (All (_ s) (Functor (Operation s))) + (implementation + (def (each f it) + (function (_ state) + (case (it state) + {try.#Success [state' output]} + {try.#Success [state' (f output)]} + + {try.#Failure error} + {try.#Failure error}))))) + +(def .public monad + (All (_ s) (Monad (Operation s))) + (implementation + (def functor ..functor) + + (def (in it) + (function (_ state) + {try.#Success [state it]})) + + (def (conjoint it) + (function (_ state) + (case (it state) + {try.#Success [state' it']} + (it' state') + + {try.#Failure error} + {try.#Failure error}))))) + +(type .public (Phase s i o) + (-> Archive i (Operation s o))) + +(type .public Wrapper + (All (_ s i o) (-> (Phase s i o) Any))) + +(def .public (result' state operation) + (All (_ s o) + (-> s (Operation s o) (Try [s o]))) + (operation state)) + +(def .public (result state operation) + (All (_ s o) + (-> s (Operation s o) (Try o))) + (|> state + operation + (at try.monad each product.right))) + +(def .public state + (All (_ s o) + (Operation s s)) + (function (_ state) + {try.#Success [state state]})) + +(def .public (with state) + (All (_ s o) + (-> s (Operation s Any))) + (function (_ _) + {try.#Success [state []]})) + +(def .public (sub [get set] operation) + (All (_ s s' o) + (-> [(-> s s') (-> s' s s)] + (Operation s' o) + (Operation s o))) + (function (_ state) + (do try.monad + [[state' output] (operation (get state))] + (in [(set state' state) output])))) + +(def .public failure + (-> Text Operation) + (|>> {try.#Failure} (state.lifted try.monad))) + +(def .public (except exception parameters) + (All (_ e) (-> (Exception e) e Operation)) + (..failure (exception.error exception parameters))) + +(def .public (lifted error) + (All (_ s a) (-> (Try a) (Operation s a))) + (function (_ state) + (try#each (|>> [state]) error))) + +(def .public assertion + (template (assertion exception message test) + [(if test + (at ..monad in []) + (..except exception message))])) + +(def .public identity + (All (_ s a) (Phase s a a)) + (function (_ archive input state) + {try.#Success [state input]})) + +(def .public (composite pre post) + (All (_ s0 s1 i t o) + (-> (Phase s0 i t) + (Phase s1 t o) + (Phase [s0 s1] i o))) + (function (_ archive input [pre/state post/state]) + (do try.monad + [[pre/state' temp] (pre archive input pre/state) + [post/state' output] (post archive temp post/state)] + (in [[pre/state' post/state'] output])))) diff --git a/stdlib/source/library/lux/meta/compiler/reference.lux b/stdlib/source/library/lux/meta/compiler/reference.lux new file mode 100644 index 000000000..340cf1a0d --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/reference.lux @@ -0,0 +1,93 @@ +(.require + [library + [lux (.except local) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [control + ["[0]" pipe]] + [data + [text + ["%" \\format (.only Format)]]] + [math + [number + ["n" nat]]] + [meta + ["[0]" symbol] + [macro + ["^" pattern]]]]] + ["[0]" / + ["[1][0]" variable (.only Variable)]]) + +(type .public Constant + Symbol) + +(type .public Reference + (Variant + {#Variable Variable} + {#Constant Constant})) + +(def .public equivalence + (Equivalence Reference) + (implementation + (def (= reference sample) + (case [reference sample] + (^.with_template [<tag> <equivalence>] + [[{<tag> reference} {<tag> sample}] + (at <equivalence> = reference sample)]) + ([#Variable /variable.equivalence] + [#Constant symbol.equivalence]) + + _ + false)))) + +(def .public hash + (Hash Reference) + (implementation + (def equivalence + ..equivalence) + + (def (hash value) + (case value + (^.with_template [<factor> <tag> <hash>] + [{<tag> value} + (|> value + (at <hash> hash) + (n.* <factor>))]) + ([2 #Variable /variable.hash] + [3 #Constant symbol.hash]) + )))) + +(with_template [<name> <family> <tag>] + [(def .public <name> + (template (<name> content) + [(<| {<family>} + {<tag>} + content)]))] + + [local ..#Variable /variable.#Local] + [foreign ..#Variable /variable.#Foreign] + ) + +(with_template [<name> <tag>] + [(def .public <name> + (template (<name> content) + [(<| {<tag>} + content)]))] + + [variable ..#Variable] + [constant ..#Constant] + ) + +(`` (def .public self + (template (self) + [(..variable (,, (/variable.self)))]))) + +(def .public format + (Format Reference) + (|>> (pipe.case + {#Variable variable} + (/variable.format variable) + + {#Constant constant} + (%.symbol constant)))) diff --git a/stdlib/source/library/lux/meta/compiler/reference/variable.lux b/stdlib/source/library/lux/meta/compiler/reference/variable.lux new file mode 100644 index 000000000..80b01b5b8 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/reference/variable.lux @@ -0,0 +1,77 @@ +(.require + [library + [lux (.except) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [control + ["[0]" pipe]] + [data + [text + ["%" \\format (.only Format)]]] + [math + [number + ["n" nat] + ["i" int]]] + [meta + [macro + ["^" pattern]]]]]) + +(type .public Register + Nat) + +(type .public Variable + (Variant + {#Local Register} + {#Foreign Register})) + +(def .public equivalence + (Equivalence Variable) + (implementation + (def (= reference sample) + (case [reference sample] + (^.with_template [<tag>] + [[{<tag> reference'} {<tag> sample'}] + (n.= reference' sample')]) + ([#Local] [#Foreign]) + + _ + #0)))) + +(def .public hash + (Hash Variable) + (implementation + (def equivalence + ..equivalence) + + (def hash + (|>> (pipe.case + (^.with_template [<factor> <tag>] + [{<tag> register} + (|> register + (at n.hash hash) + (n.* <factor>))]) + ([2 #Local] + [3 #Foreign])))))) + +(def .public self + (template (self) + [{..#Local 0}])) + +(def .public self? + (-> Variable Bit) + (|>> (pipe.case + (..self) + true + + _ + false))) + +(def .public format + (Format Variable) + (|>> (pipe.case + {#Local local} + (%.format "+" (%.nat local)) + + {#Foreign foreign} + (%.format "-" (%.nat foreign))))) diff --git a/stdlib/source/library/lux/meta/compiler/version.lux b/stdlib/source/library/lux/meta/compiler/version.lux new file mode 100644 index 000000000..fa67df166 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/version.lux @@ -0,0 +1,49 @@ +(.require + [library + [lux (.except) + [data + [text + ["%" \\format]]] + [math + [number + ["n" nat]]]]]) + +(type .public Version + Nat) + +(def range + 100) + +(def level + (n.% ..range)) + +(def next + (n./ ..range)) + +(def .public patch + (-> Version Nat) + (|>> ..level)) + +(def .public minor + (-> Version Nat) + (|>> ..next ..level)) + +(def .public major + (-> Version Nat) + (|>> ..next ..next ..level)) + +(def separator ".") + +(def (padded value) + (-> Nat Text) + (if (n.< 10 value) + (%.format "0" (%.nat value)) + (%.nat value))) + +(def .public (format version) + (%.Format Version) + (%.format (%.nat (..major version)) + ..separator + (..padded (..minor version)) + ..separator + (..padded (..patch version)))) |