diff options
| author | Eduardo Julián | 2021-07-14 14:44:53 -0400 |
|---|---|---|
| committer | GitHub | 2021-07-14 14:44:53 -0400 |
| commit | 89ca40f2f101b2b38187eab5cf905371cd47eb57 (patch) | |
| tree | f05fd1677a70988c6b39c07e52d031d86eff28f1 /stdlib/source/lux/tool | |
| parent | 2431e767a09894c2f685911ba7f1ba0b7de2a165 (diff) | |
| parent | 8252bdb938a0284dd12e7365b4eb84b5357bacac (diff) | |
Merge pull request #58 from LuxLang/hierarchy_normalization
Hierarchy normalization
Diffstat (limited to '')
195 files changed, 0 insertions, 31460 deletions
diff --git a/stdlib/source/lux/tool/compiler.lux b/stdlib/source/lux/tool/compiler.lux deleted file mode 100644 index eda74d121..000000000 --- a/stdlib/source/lux/tool/compiler.lux +++ /dev/null @@ -1,46 +0,0 @@ -(.module: - [lux (#- Module Code) - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [binary (#+ Binary)] - ["." text] - [collection - ["." row (#+ Row)]]] - [world - ["." file (#+ Path)]]] - [/ - [meta - ["." archive (#+ Output Archive) - [key (#+ Key)] - [descriptor (#+ Descriptor Module)] - [document (#+ Document)]]]]) - -(type: #export Code - Text) - -(type: #export Parameter - Text) - -(type: #export Input - {#module Module - #file Path - #hash Nat - #code Code}) - -(type: #export (Compilation s d o) - {#dependencies (List Module) - #process (-> s Archive - (Try [s (Either (Compilation s d o) - [Descriptor (Document d) Output])]))}) - -(type: #export (Compiler s d o) - (-> Input (Compilation s d o))) - -(type: #export (Instancer s d o) - (-> (Key d) (List Parameter) (Compiler s d o))) - -(exception: #export (cannot_compile {module Module}) - (exception.report - ["Module" module])) diff --git a/stdlib/source/lux/tool/compiler/arity.lux b/stdlib/source/lux/tool/compiler/arity.lux deleted file mode 100644 index 72140b6c6..000000000 --- a/stdlib/source/lux/tool/compiler/arity.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux #* - [math - [number - ["n" nat]]]]) - -(type: #export Arity Nat) - -(template [<comparison> <name>] - [(def: #export <name> (-> Arity Bit) (<comparison> 1))] - - [n.< nullary?] - [n.= unary?] - [n.> multiary?] - ) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux deleted file mode 100644 index 2803398e0..000000000 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ /dev/null @@ -1,286 +0,0 @@ -(.module: - [lux (#- Module) - ["@" target (#+ Target)] - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - [binary (#+ Binary)] - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary] - ["." set] - ["." row ("#\." functor)]]] - ["." meta] - [world - ["." file]]] - ["." // #_ - ["/#" // (#+ Instancer) - ["#." phase] - [language - [lux - [program (#+ Program)] - ["#." version] - ["#." syntax (#+ Aliases)] - ["#." synthesis] - ["#." directive (#+ Requirements)] - ["#." generation] - ["#." analysis - [macro (#+ Expander)] - ["#/." evaluation]] - [phase - [".P" synthesis] - [".P" directive] - [".P" analysis - ["." module]] - ["." extension (#+ Extender) - [".E" analysis] - [".E" synthesis] - [directive - [".D" lux]]]]]] - [meta - ["." archive (#+ Archive) - ["." descriptor (#+ Module)] - ["." artifact] - ["." document]]]]]) - -(def: #export (state target module expander host_analysis host generate generation_bundle) - (All [anchor expression directive] - (-> Target - Module - Expander - ///analysis.Bundle - (///generation.Host expression directive) - (///generation.Phase anchor expression directive) - (///generation.Bundle anchor expression directive) - (///directive.State+ anchor expression directive))) - (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.version target))]] - [extension.empty - {#///directive.analysis {#///directive.state analysis_state - #///directive.phase (analysisP.phase expander)} - #///directive.synthesis {#///directive.state synthesis_state - #///directive.phase synthesisP.phase} - #///directive.generation {#///directive.state generation_state - #///directive.phase generate}}])) - -(def: #export (with_default_directives expander host_analysis program anchorT,expressionT,directiveT extender) - (All [anchor expression directive] - (-> Expander - ///analysis.Bundle - (Program expression directive) - [Type Type Type] - Extender - (-> (///directive.State+ anchor expression directive) - (///directive.State+ anchor expression directive)))) - (function (_ [directive_extensions sub_state]) - [(dictionary.merge directive_extensions - (luxD.bundle expander host_analysis program anchorT,expressionT,directiveT extender)) - sub_state])) - -(type: Reader - (-> Source (Either [Source Text] [Source Code]))) - -(def: (reader current_module aliases [location offset source_code]) - (-> 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 - (set@ #.source source') - (set@ #.location location))] - [source' output]]))))) - -(type: (Operation a) - (All [anchor expression directive] - (///directive.Operation anchor expression directive a))) - -(type: (Payload directive) - [(///generation.Buffer directive) - artifact.Registry]) - -(def: (begin dependencies hash input) - (-> (List Module) Nat ///.Input - (All [anchor expression directive] - (///directive.Operation anchor expression directive - [Source (Payload directive)]))) - (do ///phase.monad - [#let [module (get@ #///.module input)] - _ (///directive.set_current_module module)] - (///directive.lift_analysis - (do {! ///phase.monad} - [_ (module.create hash module) - _ (monad.map ! module.import dependencies) - #let [source (///analysis.source (get@ #///.module input) (get@ #///.code input))] - _ (///analysis.set_source_code source)] - (wrap [source [///generation.empty_buffer - artifact.empty]]))))) - -(def: (end module) - (-> Module - (All [anchor expression directive] - (///directive.Operation anchor expression directive [.Module (Payload directive)]))) - (do ///phase.monad - [_ (///directive.lift_analysis - (module.set_compiled module)) - analysis_module (<| (: (Operation .Module)) - ///directive.lift_analysis - extension.lift - meta.current_module) - final_buffer (///directive.lift_generation - ///generation.buffer) - final_registry (///directive.lift_generation - ///generation.get_registry)] - (wrap [analysis_module [final_buffer - final_registry]]))) - -## TODO: Inline ASAP -(def: (get_current_payload _) - (All [directive] - (-> (Payload directive) - (All [anchor expression] - (///directive.Operation anchor expression directive - (Payload directive))))) - (do ///phase.monad - [buffer (///directive.lift_generation - ///generation.buffer) - registry (///directive.lift_generation - ///generation.get_registry)] - (wrap [buffer registry]))) - -## TODO: Inline ASAP -(def: (process_directive archive expander pre_payoad code) - (All [directive] - (-> Archive Expander (Payload directive) Code - (All [anchor expression] - (///directive.Operation anchor expression directive - [Requirements (Payload directive)])))) - (do ///phase.monad - [#let [[pre_buffer pre_registry] pre_payoad] - _ (///directive.lift_generation - (///generation.set_buffer pre_buffer)) - _ (///directive.lift_generation - (///generation.set_registry pre_registry)) - requirements (let [execute! (directiveP.phase expander)] - (execute! archive code)) - post_payload (..get_current_payload pre_payoad)] - (wrap [requirements post_payload]))) - -(def: (iteration archive expander reader source pre_payload) - (All [directive] - (-> Archive Expander Reader Source (Payload directive) - (All [anchor expression] - (///directive.Operation anchor expression directive - [Source Requirements (Payload directive)])))) - (do ///phase.monad - [[source code] (///directive.lift_analysis - (..read source reader)) - [requirements post_payload] (process_directive archive expander pre_payload code)] - (wrap [source requirements post_payload]))) - -(def: (iterate archive expander module source pre_payload aliases) - (All [directive] - (-> Archive Expander Module Source (Payload directive) Aliases - (All [anchor expression] - (///directive.Operation anchor expression directive - (Maybe [Source Requirements (Payload directive)]))))) - (do ///phase.monad - [reader (///directive.lift_analysis - (..reader module aliases source))] - (function (_ state) - (case (///phase.run' state (..iteration 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) - (-> Module ///.Input (List Module)) - (list& archive.runtime_module - (if (text\= prelude (get@ #///.module input)) - (list) - (list prelude)))) - -(def: module_aliases - (-> .Module Aliases) - (|>> (get@ #.module_aliases) (dictionary.from_list text.hash))) - -(def: #export (compiler expander prelude write_directive) - (All [anchor expression directive] - (-> Expander Module (-> directive Binary) - (Instancer (///directive.State+ anchor expression directive) .Module))) - (let [execute! (directiveP.phase expander)] - (function (_ key parameters input) - (let [dependencies (default_dependencies prelude input)] - {#///.dependencies dependencies - #///.process (function (_ state archive) - (do {! try.monad} - [#let [hash (text\hash (get@ #///.code input))] - [state [source buffer]] (<| (///phase.run' state) - (..begin dependencies hash input)) - #let [module (get@ #///.module input)]] - (loop [iteration (<| (///phase.run' state) - (..iterate 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.run' state (..end module)) - #let [descriptor {#descriptor.hash hash - #descriptor.name module - #descriptor.file (get@ #///.file input) - #descriptor.references (set.from_list text.hash dependencies) - #descriptor.state #.Compiled - #descriptor.registry final_registry}]] - (wrap [state - (#.Right [descriptor - (document.write key analysis_module) - (row\map (function (_ [artifact_id directive]) - [artifact_id (write_directive directive)]) - final_buffer)])])) - - (#.Some [source requirements temporary_payload]) - (let [[temporary_buffer temporary_registry] temporary_payload] - (wrap [state - (#.Left {#///.dependencies (|> requirements - (get@ #///directive.imports) - (list\map product.left)) - #///.process (function (_ state archive) - (recur (<| (///phase.run' state) - (do {! ///phase.monad} - [analysis_module (<| (: (Operation .Module)) - ///directive.lift_analysis - extension.lift - meta.current_module) - _ (///directive.lift_generation - (///generation.set_buffer temporary_buffer)) - _ (///directive.lift_generation - (///generation.set_registry temporary_registry)) - _ (|> requirements - (get@ #///directive.referrals) - (monad.map ! (execute! archive))) - temporary_payload (..get_current_payload temporary_payload)] - (..iterate archive expander module source temporary_payload (..module_aliases analysis_module))))))})])) - )))))})))) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux deleted file mode 100644 index 605f1d1e2..000000000 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ /dev/null @@ -1,601 +0,0 @@ -(.module: - [lux (#- Module) - [type (#+ :share)] - ["." debug] - ["@" target] - [abstract - ["." monad (#+ Monad do)]] - [control - ["." function] - ["." try (#+ Try) ("#\." functor)] - ["." exception (#+ exception:)] - [concurrency - ["." promise (#+ Promise Resolver) ("#\." monad)] - ["." stm (#+ Var STM)]]] - [data - ["." binary (#+ Binary)] - ["." bit] - ["." product] - ["." maybe] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." dictionary (#+ Dictionary)] - ["." row (#+ Row) ("#\." fold)] - ["." set (#+ Set)] - ["." list ("#\." monoid functor fold)]] - [format - ["_" binary (#+ Writer)]]] - [world - ["." file (#+ Path)]]] - ["." // #_ - ["#." init] - ["/#" // - ["#." phase (#+ Phase)] - [language - [lux - [program (#+ Program)] - ["$" /] - ["#." version] - ["." syntax] - ["#." analysis - [macro (#+ Expander)]] - ["#." synthesis] - ["#." generation (#+ Buffer)] - ["#." directive] - [phase - ["." extension (#+ Extender)] - [analysis - ["." module]]]]] - [meta - ["." archive (#+ Output Archive) - ["." artifact (#+ Registry)] - ["." descriptor (#+ Descriptor Module)] - ["." document (#+ Document)]] - [io (#+ Context) - ["." context] - ["ioW" archive]]]]] - [program - [compositor - ["." cli (#+ Compilation Library)] - ["." static (#+ Static)] - ["." import (#+ Import)]]]) - -(with_expansions [<type_vars> (as_is anchor expression directive) - <Operation> (as_is ///generation.Operation <type_vars>)] - (type: #export Phase_Wrapper - (All [s i o] (-> (Phase s i o) Any))) - - (type: #export (Platform <type_vars>) - {#&file_system (file.System Promise) - #host (///generation.Host expression directive) - #phase (///generation.Phase <type_vars>) - #runtime (<Operation> [Registry Output]) - #phase_wrapper (-> Archive (<Operation> Phase_Wrapper)) - #write (-> directive Binary)}) - - ## TODO: Get rid of this - (type: (Action a) - (Promise (Try a))) - - ## TODO: Get rid of this - (def: monad - (:as (Monad Action) - (try.with promise.monad))) - - (with_expansions [<Platform> (as_is (Platform <type_vars>)) - <State+> (as_is (///directive.State+ <type_vars>)) - <Bundle> (as_is (///generation.Bundle <type_vars>))] - - (def: writer - (Writer [Descriptor (Document .Module)]) - (_.and descriptor.writer - (document.writer $.writer))) - - (def: (cache_module static platform module_id [descriptor document output]) - (All [<type_vars>] - (-> Static <Platform> archive.ID [Descriptor (Document Any) Output] - (Promise (Try Any)))) - (let [system (get@ #&file_system platform) - write_artifact! (: (-> [artifact.ID Binary] (Action Any)) - (function (_ [artifact_id content]) - (ioW.write system static module_id artifact_id content)))] - (do {! ..monad} - [_ (ioW.prepare system static module_id) - _ (for {@.python (|> output - row.to_list - (list.chunk 128) - (monad.map ! (monad.map ! write_artifact!)) - (: (Action (List (List Any)))))} - (|> output - row.to_list - (monad.map ..monad write_artifact!) - (: (Action (List Any))))) - document (\ promise.monad wrap - (document.check $.key document))] - (ioW.cache system static module_id - (_.run ..writer [descriptor document]))))) - - ## 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!] - (get@ #runtime platform))) - - (def: (runtime_descriptor registry) - (-> Registry Descriptor) - {#descriptor.hash 0 - #descriptor.name archive.runtime_module - #descriptor.file "" - #descriptor.references (set.new text.hash) - #descriptor.state #.Compiled - #descriptor.registry registry}) - - (def: runtime_document - (Document .Module) - (document.write $.key (module.new 0))) - - (def: (process_runtime archive platform) - (All [<type_vars>] - (-> Archive <Platform> - (///directive.Operation <type_vars> - [Archive [Descriptor (Document .Module) Output]]))) - (do ///phase.monad - [[registry payload] (///directive.lift_generation - (..compile_runtime! platform)) - #let [[descriptor document] [(..runtime_descriptor registry) ..runtime_document]] - archive (///phase.lift (if (archive.reserved? archive archive.runtime_module) - (archive.add archive.runtime_module [descriptor document payload] archive) - (do try.monad - [[_ archive] (archive.reserve archive.runtime_module archive)] - (archive.add archive.runtime_module [descriptor document payload] archive))))] - (wrap [archive [descriptor document payload]]))) - - (def: (initialize_state extender - [analysers - synthesizers - generators - directives] - analysis_state - state) - (All [<type_vars>] - (-> Extender - [(Dictionary Text ///analysis.Handler) - (Dictionary Text ///synthesis.Handler) - (Dictionary Text (///generation.Handler <type_vars>)) - (Dictionary Text (///directive.Handler <type_vars>))] - .Lux - <State+> - (Try <State+>))) - (|> (:share [<type_vars>] - <State+> - state - - (///directive.Operation <type_vars> Any) - (do ///phase.monad - [_ (///directive.lift_analysis - (///analysis.install analysis_state)) - _ (///directive.lift_analysis - (extension.with extender analysers)) - _ (///directive.lift_synthesis - (extension.with extender synthesizers)) - _ (///directive.lift_generation - (extension.with extender (:assume generators))) - _ (extension.with extender (:assume directives))] - (wrap []))) - (///phase.run' state) - (\ try.monad map product.left))) - - (def: (phase_wrapper archive platform state) - (All [<type_vars>] - (-> Archive <Platform> <State+> (Try [<State+> Phase_Wrapper]))) - (let [phase_wrapper (get@ #phase_wrapper platform)] - (|> archive - phase_wrapper - ///directive.lift_generation - (///phase.run' state)))) - - (def: (complete_extensions host_directive_bundle phase_wrapper [analysers synthesizers generators directives]) - (All [<type_vars>] - (-> (-> Phase_Wrapper (///directive.Bundle <type_vars>)) - Phase_Wrapper - [(Dictionary Text ///analysis.Handler) - (Dictionary Text ///synthesis.Handler) - (Dictionary Text (///generation.Handler <type_vars>)) - (Dictionary Text (///directive.Handler <type_vars>))] - [(Dictionary Text ///analysis.Handler) - (Dictionary Text ///synthesis.Handler) - (Dictionary Text (///generation.Handler <type_vars>)) - (Dictionary Text (///directive.Handler <type_vars>))])) - [analysers - synthesizers - generators - (dictionary.merge directives (host_directive_bundle phase_wrapper))]) - - (def: #export (initialize static module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender - import compilation_sources) - (All [<type_vars>] - (-> Static - Module - Expander - ///analysis.Bundle - <Platform> - <Bundle> - (-> Phase_Wrapper (///directive.Bundle <type_vars>)) - (Program expression directive) - [Type Type Type] (-> Phase_Wrapper Extender) - Import (List Context) - (Promise (Try [<State+> Archive])))) - (do {! (try.with promise.monad)} - [#let [state (//init.state (get@ #static.host static) - module - expander - host_analysis - (get@ #host platform) - (get@ #phase platform) - generation_bundle)] - _ (ioW.enable (get@ #&file_system platform) static) - [archive analysis_state bundles] (ioW.thaw (get@ #host platform) (get@ #&file_system platform) static import compilation_sources) - #let [with_missing_extensions - (: (All [<type_vars>] - (-> <Platform> (Program expression directive) <State+> (Promise (Try <State+>)))) - (function (_ platform program state) - (promise\wrap - (do try.monad - [[state phase_wrapper] (..phase_wrapper archive platform state)] - (|> state - (initialize_state (extender phase_wrapper) - (:assume (..complete_extensions host_directive_bundle phase_wrapper (:assume bundles))) - analysis_state) - (try\map (//init.with_default_directives expander host_analysis program anchorT,expressionT,directiveT (extender phase_wrapper))))))))]] - (if (archive.archived? archive archive.runtime_module) - (do ! - [state (with_missing_extensions platform program state)] - (wrap [state archive])) - (do ! - [[state [archive payload]] (|> (..process_runtime archive platform) - (///phase.run' state) - promise\wrap) - _ (..cache_module static platform 0 payload) - - state (with_missing_extensions platform program state)] - (wrap [state archive]))))) - - (def: compilation_log_separator - (format text.new_line text.tab)) - - (def: (module_compilation_log module) - (All [<type_vars>] - (-> Module <State+> Text)) - (|>> (get@ [#extension.state - #///directive.generation - #///directive.state - #extension.state - #///generation.log]) - (row\fold (function (_ right left) - (format left ..compilation_log_separator right)) - module))) - - (def: with_reset_log - (All [<type_vars>] - (-> <State+> <State+>)) - (set@ [#extension.state - #///directive.generation - #///directive.state - #extension.state - #///generation.log] - row.empty)) - - (def: empty - (Set Module) - (set.new text.hash)) - - (type: Mapping - (Dictionary Module (Set Module))) - - (type: Dependence - {#depends_on Mapping - #depended_by Mapping}) - - (def: independence - Dependence - (let [empty (dictionary.new text.hash)] - {#depends_on empty - #depended_by empty})) - - (def: (depend module import dependence) - (-> Module Module Dependence Dependence) - (let [transitive_dependency (: (-> (-> Dependence Mapping) Module (Set Module)) - (function (_ lens module) - (|> dependence - lens - (dictionary.get module) - (maybe.default ..empty)))) - transitive_depends_on (transitive_dependency (get@ #depends_on) import) - transitive_depended_by (transitive_dependency (get@ #depended_by) module) - update_dependence (: (-> [Module (Set Module)] [Module (Set Module)] - (-> Mapping Mapping)) - (function (_ [source forward] [target backward]) - (function (_ mapping) - (let [with_dependence+transitives - (|> mapping - (dictionary.upsert source ..empty (set.add target)) - (dictionary.update source (set.union forward)))] - (list\fold (function (_ previous) - (dictionary.upsert previous ..empty (set.add target))) - with_dependence+transitives - (set.to_list backward))))))] - (|> dependence - (update@ #depends_on - (update_dependence - [module transitive_depends_on] - [import transitive_depended_by])) - (update@ #depended_by - ((function.flip update_dependence) - [module transitive_depends_on] - [import transitive_depended_by]))))) - - (def: (circular_dependency? module import dependence) - (-> Module Module Dependence Bit) - (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit) - (function (_ from relationship to) - (let [targets (|> dependence - relationship - (dictionary.get from) - (maybe.default ..empty))] - (set.member? targets to))))] - (or (dependence? import (get@ #depends_on) module) - (dependence? module (get@ #depended_by) import)))) - - (exception: #export (module_cannot_import_itself {module Module}) - (exception.report - ["Module" (%.text module)])) - - (exception: #export (cannot_import_circular_dependency {importer Module} - {importee Module}) - (exception.report - ["Importer" (%.text importer)] - ["importee" (%.text importee)])) - - (def: (verify_dependencies importer importee dependence) - (-> Module Module Dependence (Try Any)) - (cond (text\= importer importee) - (exception.throw ..module_cannot_import_itself [importer]) - - (..circular_dependency? importer importee dependence) - (exception.throw ..cannot_import_circular_dependency [importer importee]) - - ## else - (#try.Success []))) - - (with_expansions [<Context> (as_is [Archive <State+>]) - <Result> (as_is (Try <Context>)) - <Return> (as_is (Promise <Result>)) - <Signal> (as_is (Resolver <Result>)) - <Pending> (as_is [<Return> <Signal>]) - <Importer> (as_is (-> Module Module <Return>)) - <Compiler> (as_is (-> Module <Importer> archive.ID <Context> Module <Return>))] - (def: (parallel initial) - (All [<type_vars>] - (-> <Context> - (-> <Compiler> <Importer>))) - (let [current (stm.var initial) - pending (:share [<type_vars>] - <Context> - initial - - (Var (Dictionary Module <Pending>)) - (:assume (stm.var (dictionary.new text.hash)))) - dependence (: (Var Dependence) - (stm.var ..independence))] - (function (_ compile) - (function (import! importer module) - (do {! promise.monad} - [[return signal] (:share [<type_vars>] - <Context> - initial - - (Promise [<Return> (Maybe [<Context> - archive.ID - <Signal>])]) - (:assume - (stm.commit - (do {! stm.monad} - [dependence (if (text\= archive.runtime_module importer) - (stm.read dependence) - (do ! - [[_ dependence] (stm.update (..depend importer module) dependence)] - (wrap dependence)))] - (case (..verify_dependencies importer module dependence) - (#try.Failure error) - (wrap [(promise.resolved (#try.Failure error)) - #.None]) - - (#try.Success _) - (do ! - [[archive state] (stm.read current)] - (if (archive.archived? archive module) - (wrap [(promise\wrap (#try.Success [archive state])) - #.None]) - (do ! - [@pending (stm.read pending)] - (case (dictionary.get module @pending) - (#.Some [return signal]) - (wrap [return - #.None]) - - #.None - (case (if (archive.reserved? archive module) - (do try.monad - [module_id (archive.id module archive)] - (wrap [module_id archive])) - (archive.reserve module archive)) - (#try.Success [module_id archive]) - (do ! - [_ (stm.write [archive state] current) - #let [[return signal] (:share [<type_vars>] - <Context> - initial - - <Pending> - (promise.promise []))] - _ (stm.update (dictionary.put module [return signal]) pending)] - (wrap [return - (#.Some [[archive state] - module_id - signal])])) - - (#try.Failure error) - (wrap [(promise\wrap (#try.Failure error)) - #.None]))))))))))) - _ (case signal - #.None - (wrap []) - - (#.Some [context module_id resolver]) - (do ! - [result (compile importer import! module_id context module) - result (case result - (#try.Failure error) - (wrap result) - - (#try.Success [resulting_archive resulting_state]) - (stm.commit (do stm.monad - [[_ [merged_archive _]] (stm.update (function (_ [archive state]) - [(archive.merge resulting_archive archive) - state]) - current)] - (wrap (#try.Success [merged_archive resulting_state]))))) - _ (promise.future (resolver result))] - (wrap [])))] - return))))) - - ## TODO: Find a better way, as this only works for the Lux compiler. - (def: (updated_state archive state) - (All [<type_vars>] - (-> Archive <State+> (Try <State+>))) - (do {! try.monad} - [modules (monad.map ! (function (_ module) - (do ! - [[descriptor document output] (archive.find module archive) - lux_module (document.read $.key document)] - (wrap [module lux_module]))) - (archive.archived archive)) - #let [additions (|> modules - (list\map product.left) - (set.from_list text.hash))]] - (wrap (update@ [#extension.state - #///directive.analysis - #///directive.state - #extension.state] - (function (_ analysis_state) - (|> analysis_state - (:as .Lux) - (update@ #.modules (function (_ current) - (list\compose (list.filter (|>> product.left - (set.member? additions) - not) - current) - modules))) - :assume)) - state)))) - - (def: (set_current_module module state) - (All [<type_vars>] - (-> Module <State+> <State+>)) - (|> (///directive.set_current_module module) - (///phase.run' state) - try.assume - product.left)) - - (def: #export (compile import static expander platform compilation context) - (All [<type_vars>] - (-> Import Static Expander <Platform> Compilation <Context> <Return>)) - (let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation - base_compiler (:share [<type_vars>] - <Context> - context - - (///.Compiler <State+> .Module Any) - (:assume - ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))) - compiler (..parallel - context - (function (_ importer import! module_id [archive state] module) - (do {! (try.with promise.monad)} - [#let [state (..set_current_module module state)] - input (context.read (get@ #&file_system platform) - importer - import - compilation_sources - (get@ #static.host_module_extension static) - module)] - (loop [[archive state] [archive state] - compilation (base_compiler (:as ///.Input input)) - all_dependencies (: (List Module) - (list))] - (let [new_dependencies (get@ #///.dependencies compilation) - all_dependencies (list\compose new_dependencies all_dependencies) - continue! (:share [<type_vars>] - <Platform> - platform - - (-> <Context> (///.Compilation <State+> .Module Any) (List Module) - (Action [Archive <State+>])) - (:assume - recur))] - (do ! - [[archive state] (case new_dependencies - #.Nil - (wrap [archive state]) - - (#.Cons _) - (do ! - [archive,document+ (|> new_dependencies - (list\map (import! module)) - (monad.seq ..monad)) - #let [archive (|> archive,document+ - (list\map product.left) - (list\fold archive.merge archive))]] - (wrap [archive (try.assume - (..updated_state archive state))])))] - (case ((get@ #///.process compilation) - ## TODO: The "///directive.set_current_module" below shouldn't be necessary. Remove it ASAP. - ## TODO: The context shouldn't need to be re-set either. - (|> (///directive.set_current_module module) - (///phase.run' state) - try.assume - product.left) - archive) - (#try.Success [state more|done]) - (case more|done - (#.Left more) - (continue! [archive state] more all_dependencies) - - (#.Right [descriptor document output]) - (do ! - [#let [_ (debug.log! (..module_compilation_log module state)) - descriptor (set@ #descriptor.references (set.from_list text.hash all_dependencies) descriptor)] - _ (..cache_module static platform module_id [descriptor document output])] - (case (archive.add module [descriptor document output] archive) - (#try.Success archive) - (wrap [archive - (..with_reset_log state)]) - - (#try.Failure error) - (promise\wrap (#try.Failure error))))) - - (#try.Failure error) - (do ! - [_ (ioW.freeze (get@ #&file_system platform) static archive)] - (promise\wrap (#try.Failure error))))))))))] - (compiler archive.runtime_module compilation_module))) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux.lux b/stdlib/source/lux/tool/compiler/language/lux.lux deleted file mode 100644 index 1d507b52f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux.lux +++ /dev/null @@ -1,106 +0,0 @@ -(.module: - [lux #* - [control - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - [format - ["_" binary (#+ Writer)]]]] - ["." / #_ - ["#." version] - [phase - [analysis - ["." module]]] - [/// - [meta - [archive - ["." signature] - ["." key (#+ Key)]]]]]) - -## TODO: Remove #module_hash, #imports & #module_state ASAP. -## TODO: Not just from this parser, but from the lux.Module type. -(def: #export writer - (Writer .Module) - (let [definition (: (Writer Definition) - ($_ _.and _.bit _.type _.code _.any)) - name (: (Writer Name) - (_.and _.text _.text)) - alias (: (Writer Alias) - (_.and _.text _.text)) - global (: (Writer Global) - (_.or alias - definition)) - tag (: (Writer [Nat (List Name) Bit Type]) - ($_ _.and - _.nat - (_.list name) - _.bit - _.type)) - type (: (Writer [(List Name) Bit Type]) - ($_ _.and - (_.list name) - _.bit - _.type))] - ($_ _.and - ## #module_hash - _.nat - ## #module_aliases - (_.list alias) - ## #definitions - (_.list (_.and _.text global)) - ## #imports - (_.list _.text) - ## #tags - (_.list (_.and _.text tag)) - ## #types - (_.list (_.and _.text type)) - ## #module_annotations - (_.maybe _.code) - ## #module_state - _.any))) - -(def: #export parser - (Parser .Module) - (let [definition (: (Parser Definition) - ($_ <>.and <b>.bit <b>.type <b>.code <b>.any)) - name (: (Parser Name) - (<>.and <b>.text <b>.text)) - alias (: (Parser Alias) - (<>.and <b>.text <b>.text)) - global (: (Parser Global) - (<b>.or alias - definition)) - tag (: (Parser [Nat (List Name) Bit Type]) - ($_ <>.and - <b>.nat - (<b>.list name) - <b>.bit - <b>.type)) - type (: (Parser [(List Name) Bit Type]) - ($_ <>.and - (<b>.list name) - <b>.bit - <b>.type))] - ($_ <>.and - ## #module_hash - <b>.nat - ## #module_aliases - (<b>.list alias) - ## #definitions - (<b>.list (<>.and <b>.text global)) - ## #imports - (<b>.list <b>.text) - ## #tags - (<b>.list (<>.and <b>.text tag)) - ## #types - (<b>.list (<>.and <b>.text type)) - ## #module_annotations - (<b>.maybe <b>.code) - ## #module_state - (\ <>.monad wrap #.Cached)))) - -(def: #export key - (Key .Module) - (key.key {#signature.name (name_of ..compiler) - #signature.version /version.version} - (module.new 0))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux deleted file mode 100644 index bbbe43b27..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux +++ /dev/null @@ -1,555 +0,0 @@ -(.module: - [lux (#- nat int rev) - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - [monad (#+ do)]] - [control - ["." function] - ["." try] - ["." exception (#+ Exception)]] - [data - ["." product] - ["." maybe] - ["." bit ("#\." equivalence)] - ["." text ("#\." equivalence) - ["%" format (#+ Format format)]] - [collection - ["." list ("#\." functor fold)]]] - [math - [number - ["n" nat] - ["i" int] - ["r" rev] - ["f" frac]]] - [meta - ["." location]]] - [// - [phase - ["." extension (#+ Extension)]] - [/// - [arity (#+ Arity)] - [version (#+ Version)] - ["." phase] - ["." reference (#+ Reference) - ["." variable (#+ Register Variable)]]]]) - -(type: #export #rec Primitive - #Unit - (#Bit Bit) - (#Nat Nat) - (#Int Int) - (#Rev Rev) - (#Frac Frac) - (#Text Text)) - -(type: #export Tag - Nat) - -(type: #export (Variant a) - {#lefts Nat - #right? Bit - #value a}) - -(def: #export (tag lefts right?) - (-> Nat Bit Nat) - (if right? - (inc lefts) - lefts)) - -(def: (lefts tag right?) - (-> Nat Bit Nat) - (if right? - (dec tag) - tag)) - -(def: #export (choice options pick) - (-> Nat Nat [Nat Bit]) - (let [right? (n.= (dec options) pick)] - [(..lefts pick right?) - right?])) - -(type: #export (Tuple a) - (List a)) - -(type: #export (Composite a) - (#Variant (Variant a)) - (#Tuple (Tuple a))) - -(type: #export #rec Pattern - (#Simple Primitive) - (#Complex (Composite Pattern)) - (#Bind Register)) - -(type: #export (Branch' e) - {#when Pattern - #then e}) - -(type: #export (Match' e) - [(Branch' e) (List (Branch' e))]) - -(type: #export (Environment a) - (List a)) - -(type: #export #rec Analysis - (#Primitive Primitive) - (#Structure (Composite Analysis)) - (#Reference Reference) - (#Case Analysis (Match' Analysis)) - (#Function (Environment Analysis) Analysis) - (#Apply Analysis Analysis) - (#Extension (Extension Analysis))) - -(type: #export Branch - (Branch' Analysis)) - -(type: #export Match - (Match' Analysis)) - -(implementation: primitive_equivalence - (Equivalence Primitive) - - (def: (= reference sample) - (case [reference sample] - [#Unit #Unit] - true - - (^template [<tag> <=>] - [[(<tag> reference) (<tag> sample)] - (<=> reference sample)]) - ([#Bit bit\=] - [#Nat n.=] - [#Int i.=] - [#Rev r.=] - [#Frac f.=] - [#Text text\=]) - - _ - false))) - -(implementation: #export (composite_equivalence (^open "/\.")) - (All [a] (-> (Equivalence a) (Equivalence (Composite a)))) - - (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)] - (\ (list.equivalence /\=) = reference sample) - - _ - false))) - -(implementation: #export (composite_hash super) - (All [a] (-> (Hash a) (Hash (Composite a)))) - - (def: &equivalence - (..composite_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (#Variant [lefts right? value]) - ($_ n.* 2 - (\ n.hash hash lefts) - (\ bit.hash hash right?) - (\ super hash value)) - - (#Tuple members) - ($_ n.* 3 - (\ (list.hash super) hash members)) - ))) - -(implementation: pattern_equivalence - (Equivalence Pattern) - - (def: (= reference sample) - (case [reference sample] - [(#Simple reference) (#Simple sample)] - (\ primitive_equivalence = reference sample) - - [(#Complex reference) (#Complex sample)] - (\ (composite_equivalence =) = reference sample) - - [(#Bind reference) (#Bind sample)] - (n.= reference sample) - - _ - false))) - -(implementation: (branch_equivalence equivalence) - (-> (Equivalence Analysis) (Equivalence Branch)) - - (def: (= [reference_pattern reference_body] [sample_pattern sample_body]) - (and (\ pattern_equivalence = reference_pattern sample_pattern) - (\ equivalence = reference_body sample_body)))) - -(implementation: #export equivalence - (Equivalence Analysis) - - (def: (= reference sample) - (case [reference sample] - [(#Primitive reference) (#Primitive sample)] - (\ primitive_equivalence = reference sample) - - [(#Structure reference) (#Structure sample)] - (\ (composite_equivalence =) = reference sample) - - [(#Reference reference) (#Reference sample)] - (\ reference.equivalence = reference sample) - - [(#Case [reference_analysis reference_match]) - (#Case [sample_analysis sample_match])] - (and (= reference_analysis sample_analysis) - (\ (list.equivalence (branch_equivalence =)) = (#.Cons reference_match) (#.Cons sample_match))) - - [(#Function [reference_environment reference_analysis]) - (#Function [sample_environment sample_analysis])] - (and (= reference_analysis sample_analysis) - (\ (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)] - (\ (extension.equivalence =) = reference sample) - - _ - false))) - -(template [<name> <tag>] - [(template: #export (<name> content) - (<tag> content))] - - [control/case #..Case] - ) - -(template: #export (unit) - (#..Primitive #..Unit)) - -(template [<name> <tag>] - [(template: #export (<name> value) - (#..Primitive (<tag> value)))] - - [bit #..Bit] - [nat #..Nat] - [int #..Int] - [rev #..Rev] - [frac #..Frac] - [text #..Text] - ) - -(type: #export (Abstraction c) - [(Environment c) Arity c]) - -(type: #export (Application c) - [c (List c)]) - -(def: (last? size tag) - (-> Nat Tag Bit) - (n.= (dec size) tag)) - -(template: #export (no_op value) - (|> 1 #variable.Local #reference.Variable #..Reference - (#..Function (list)) - (#..Apply value))) - -(def: #export (apply [abstraction inputs]) - (-> (Application Analysis) Analysis) - (list\fold (function (_ input abstraction') - (#Apply input abstraction')) - abstraction - inputs)) - -(def: #export (application analysis) - (-> Analysis (Application Analysis)) - (loop [abstraction analysis - inputs (list)] - (case abstraction - (#Apply input next) - (recur next (#.Cons input inputs)) - - _ - [abstraction inputs]))) - -(template [<name> <tag>] - [(template: #export (<name> content) - (.<| #..Reference - <tag> - content))] - - [variable #reference.Variable] - [constant #reference.Constant] - - [variable/local reference.local] - [variable/foreign reference.foreign] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (.<| #..Complex - <tag> - content))] - - [pattern/variant #..Variant] - [pattern/tuple #..Tuple] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (.<| #..Structure - <tag> - content))] - - [variant #..Variant] - [tuple #..Tuple] - ) - -(template: #export (pattern/unit) - (#..Simple #..Unit)) - -(template [<name> <tag>] - [(template: #export (<name> content) - (#..Simple (<tag> content)))] - - [pattern/bit #..Bit] - [pattern/nat #..Nat] - [pattern/int #..Int] - [pattern/rev #..Rev] - [pattern/frac #..Frac] - [pattern/text #..Text] - ) - -(template: #export (pattern/bind register) - (#..Bind register)) - -(def: #export (%analysis analysis) - (Format Analysis) - (case analysis - (#Primitive primitive) - (case primitive - #Unit - "[]" - - (^template [<tag> <format>] - [(<tag> value) - (<format> value)]) - ([#Bit %.bit] - [#Nat %.nat] - [#Int %.int] - [#Rev %.rev] - [#Frac %.frac] - [#Text %.text])) - - (#Structure structure) - (case structure - (#Variant [lefts right? value]) - (format "(" (%.nat lefts) " " (%.bit right?) " " (%analysis value) ")") - - (#Tuple members) - (|> members - (list\map %analysis) - (text.join_with " ") - (text.enclose ["[" "]"]))) - - (#Reference reference) - (reference.format reference) - - (#Case analysis match) - "{?}" - - (#Function environment body) - (|> (%analysis body) - (format " ") - (format (|> environment - (list\map %analysis) - (text.join_with " ") - (text.enclose ["[" "]"]))) - (text.enclose ["(" ")"])) - - (#Apply _) - (|> analysis - ..application - #.Cons - (list\map %analysis) - (text.join_with " ") - (text.enclose ["(" ")"])) - - (#Extension name parameters) - (|> parameters - (list\map %analysis) - (text.join_with " ") - (format (%.text name) " ") - (text.enclose ["(" ")"])))) - -(template [<special> <general>] - [(type: #export <special> - (<general> .Lux Code Analysis))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(def: #export (with_source_code source action) - (All [a] (-> Source (Operation a) (Operation a))) - (function (_ [bundle state]) - (let [old_source (get@ #.source state)] - (case (action [bundle (set@ #.source source state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ #.source old_source state')] - output]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: fresh_bindings - (All [k v] (Bindings k v)) - {#.counter 0 - #.mappings (list)}) - -(def: fresh_scope - Scope - {#.name (list) - #.inner 0 - #.locals fresh_bindings - #.captured fresh_bindings}) - -(def: #export (with_scope action) - (All [a] (-> (Operation a) (Operation [Scope a]))) - (function (_ [bundle state]) - (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh_scope)) state)]) - (#try.Success [[bundle' state'] output]) - (case (get@ #.scopes state') - (#.Cons head tail) - (#try.Success [[bundle' (set@ #.scopes tail state')] - [head output]]) - - #.Nil - (#try.Failure "Impossible error: Drained scopes!")) - - (#try.Failure error) - (#try.Failure error)))) - -(def: #export (with_current_module name) - (All [a] (-> Text (Operation a) (Operation a))) - (extension.localized (get@ #.current_module) - (set@ #.current_module) - (function.constant (#.Some name)))) - -(def: #export (with_location location action) - (All [a] (-> Location (Operation a) (Operation a))) - (if (text\= "" (product.left location)) - action - (function (_ [bundle state]) - (let [old_location (get@ #.location state)] - (case (action [bundle (set@ #.location location state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ #.location old_location state')] - output]) - - (#try.Failure error) - (#try.Failure error)))))) - -(def: (locate_error location error) - (-> Location Text Text) - (format (%.location location) text.new_line - error)) - -(def: #export (fail error) - (-> Text Operation) - (function (_ [bundle state]) - (#try.Failure (locate_error (get@ #.location state) error)))) - -(def: #export (throw exception parameters) - (All [e] (-> (Exception e) e Operation)) - (..fail (exception.construct exception parameters))) - -(def: #export (assert exception parameters condition) - (All [e] (-> (Exception e) e Bit (Operation Any))) - (if condition - (\ phase.monad wrap []) - (..throw exception parameters))) - -(def: #export (fail' error) - (-> Text (phase.Operation Lux)) - (function (_ state) - (#try.Failure (locate_error (get@ #.location state) error)))) - -(def: #export (throw' exception parameters) - (All [e] (-> (Exception e) e (phase.Operation Lux))) - (..fail' (exception.construct exception parameters))) - -(def: #export (with_stack 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.Success output) - (#try.Success output) - - (#try.Failure error) - (let [[bundle state] bundle,state] - (#try.Failure (locate_error (get@ #.location state) error)))))) - -(def: #export (install state) - (-> .Lux (Operation Any)) - (function (_ [bundle _]) - (#try.Success [[bundle state] - []]))) - -(template [<name> <type> <field> <value>] - [(def: #export (<name> value) - (-> <type> (Operation Any)) - (extension.update (set@ <field> <value>)))] - - [set_source_code Source #.source value] - [set_current_module Text #.current_module (#.Some value)] - [set_location Location #.location value] - ) - -(def: #export (location file) - (-> Text Location) - [file 1 0]) - -(def: #export (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: #export (info version host) - (-> Version Text Info) - {#.target host - #.version (%.nat version) - #.mode #.Build}) - -(def: #export (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 [] - #.host []}) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux deleted file mode 100644 index 521c88a23..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux +++ /dev/null @@ -1,56 +0,0 @@ -(.module: - [lux (#- Module) - ["." meta] - [abstract - [monad (#+ do)]] - [control - ["." try]] - [math - [number - ["n" nat]]]] - [// (#+ Operation) - [macro (#+ Expander)] - [// - [phase - [".P" extension] - [".P" synthesis] - [".P" analysis - ["." type]] - [// - ["." synthesis] - ["." generation (#+ Context)] - [/// - ["." phase] - [meta - [archive (#+ Archive) - [descriptor (#+ Module)]]]]]]]]) - -(type: #export Eval - (-> Archive Nat Type Code (Operation Any))) - -(def: (context [module_id artifact_id]) - (-> Context Context) - ## TODO: Find a better way that doesn't rely on clever tricks. - [(n.- module_id 0) artifact_id]) - -(def: #export (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 count type exprC) - (do phase.monad - [exprA (type.with_type type - (analyze archive exprC)) - module (extensionP.lift - meta.current_module_name)] - (phase.lift (do try.monad - [exprS (|> exprA (synthesisP.phase archive) (phase.run synthesis_state))] - (phase.run generation_state - (do phase.monad - [exprO (generate archive exprS) - module_id (generation.module_id module archive)] - (generation.evaluate! (..context [module_id count]) exprO))))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux deleted file mode 100644 index 9a84c0259..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis/macro.lux +++ /dev/null @@ -1,51 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." text - ["%" format (#+ format)]]] - ["." meta]] - [///// - ["." phase]]) - -(exception: #export (expansion_failed {macro Name} {inputs (List Code)} {error Text}) - (exception.report - ["Macro" (%.name macro)] - ["Inputs" (exception.enumerate %.code inputs)] - ["Error" error])) - -(exception: #export (must_have_single_expansion {macro Name} {inputs (List Code)} {outputs (List Code)}) - (exception.report - ["Macro" (%.name macro)] - ["Inputs" (exception.enumerate %.code inputs)] - ["Outputs" (exception.enumerate %.code outputs)])) - -(type: #export Expander - (-> Macro (List Code) Lux (Try (Try [Lux (List Code)])))) - -(def: #export (expand expander name macro inputs) - (-> Expander Name Macro (List Code) (Meta (List Code))) - (function (_ state) - (do try.monad - [output (expander macro inputs state)] - (case output - (#try.Success output) - (#try.Success output) - - (#try.Failure error) - ((meta.fail (exception.construct ..expansion_failed [name inputs error])) state))))) - -(def: #export (expand_one expander name macro inputs) - (-> Expander Name Macro (List Code) (Meta Code)) - (do meta.monad - [expansion (expand expander name macro inputs)] - (case expansion - (^ (list single)) - (wrap single) - - _ - (meta.fail (exception.construct ..must_have_single_expansion [name inputs expansion]))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/lux/tool/compiler/language/lux/directive.lux deleted file mode 100644 index 896a9a1cb..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/directive.lux +++ /dev/null @@ -1,82 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - [monad (#+ do)]] - [data - [collection - ["." list ("#\." monoid)]]]] - [// - ["." analysis] - ["." synthesis] - ["." generation] - [phase - ["." extension]] - [/// - ["." phase] - [meta - [archive - [descriptor (#+ Module)]]]]]) - -(type: #export (Component state phase) - {#state state - #phase phase}) - -(type: #export (State anchor expression directive) - {#analysis (Component analysis.State+ - analysis.Phase) - #synthesis (Component synthesis.State+ - synthesis.Phase) - #generation (Component (generation.State+ anchor expression directive) - (generation.Phase anchor expression directive))}) - -(type: #export Import - {#module Module - #alias Text}) - -(type: #export Requirements - {#imports (List Import) - #referrals (List Code)}) - -(def: #export no_requirements - Requirements - {#imports (list) - #referrals (list)}) - -(def: #export (merge_requirements left right) - (-> Requirements Requirements Requirements) - {#imports (list\compose (get@ #imports left) (get@ #imports right)) - #referrals (list\compose (get@ #referrals left) (get@ #referrals right))}) - -(template [<special> <general>] - [(type: #export (<special> anchor expression directive) - (<general> (..State anchor expression directive) Code Requirements))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(template [<name> <component> <operation>] - [(def: #export <name> - (All [anchor expression directive output] - (-> (<operation> output) - (Operation anchor expression directive output))) - (|>> (phase.sub [(get@ [<component> #..state]) - (set@ [<component> #..state])]) - extension.lift))] - - [lift_analysis #..analysis analysis.Operation] - [lift_synthesis #..synthesis synthesis.Operation] - [lift_generation #..generation (generation.Operation anchor expression directive)] - ) - -(def: #export (set_current_module module) - (All [anchor expression directive] - (-> Module (Operation anchor expression directive Any))) - (do phase.monad - [_ (..lift_analysis - (analysis.set_current_module module))] - (..lift_generation - (generation.enter_module module)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux deleted file mode 100644 index 372ed2c17..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux +++ /dev/null @@ -1,335 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." function]] - [data - [binary (#+ Binary)] - ["." product] - ["." name] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." row (#+ Row)] - ["." list ("#\." functor)]]] - [math - [number - ["n" nat]]]] - [// - [synthesis (#+ Synthesis)] - [phase - ["." extension]] - [/// - ["." phase] - [meta - ["." archive (#+ Archive) - ["." descriptor (#+ Module)] - ["." artifact]]]]]) - -(type: #export Context - [archive.ID artifact.ID]) - -(type: #export (Buffer directive) - (Row [artifact.ID directive])) - -(exception: #export (cannot_interpret {error Text}) - (exception.report - ["Error" error])) - -(template [<name>] - [(exception: #export (<name> {artifact_id artifact.ID}) - (exception.report - ["Artifact ID" (%.nat artifact_id)]))] - - [cannot_overwrite_output] - [no_buffer_for_saving_code] - ) - -(interface: #export (Host expression directive) - (: (-> Context expression (Try Any)) - evaluate!) - (: (-> directive (Try Any)) - execute!) - (: (-> Context expression (Try [Text Any directive])) - define!) - - (: (-> Context Binary directive) - ingest) - (: (-> Context directive (Try Any)) - re_learn) - (: (-> Context directive (Try Any)) - re_load)) - -(type: #export (State anchor expression directive) - {#module Module - #anchor (Maybe anchor) - #host (Host expression directive) - #buffer (Maybe (Buffer directive)) - #registry artifact.Registry - #counter Nat - #context (Maybe artifact.ID) - #log (Row Text)}) - -(template [<special> <general>] - [(type: #export (<special> anchor expression directive) - (<general> (State anchor expression directive) Synthesis expression))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - [Extender extension.Extender] - ) - -(def: #export (state host module) - (All [anchor expression directive] - (-> (Host expression directive) - Module - (..State anchor expression directive))) - {#module module - #anchor #.None - #host host - #buffer #.None - #registry artifact.empty - #counter 0 - #context #.None - #log row.empty}) - -(def: #export empty_buffer Buffer row.empty) - -(template [<tag> - <with_declaration> <with_type> <with_value> - <set> <get> <get_type> <exception>] - [(exception: #export <exception>) - - (def: #export <with_declaration> - (All [anchor expression directive output] <with_type>) - (function (_ body) - (function (_ [bundle state]) - (case (body [bundle (set@ <tag> (#.Some <with_value>) state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set@ <tag> (get@ <tag> state) state')] - output]) - - (#try.Failure error) - (#try.Failure error))))) - - (def: #export <get> - (All [anchor expression directive] - (Operation anchor expression directive <get_type>)) - (function (_ (^@ stateE [bundle state])) - (case (get@ <tag> state) - (#.Some output) - (#try.Success [stateE output]) - - #.None - (exception.throw <exception> [])))) - - (def: #export (<set> value) - (All [anchor expression directive] - (-> <get_type> (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (#try.Success [[bundle (set@ <tag> (#.Some value) state)] - []])))] - - [#anchor - (with_anchor anchor) - (-> anchor (Operation anchor expression directive output) - (Operation anchor expression directive output)) - anchor - set_anchor anchor anchor no_anchor] - - [#buffer - with_buffer - (-> (Operation anchor expression directive output) - (Operation anchor expression directive output)) - ..empty_buffer - set_buffer buffer (Buffer directive) no_active_buffer] - ) - -(def: #export get_registry - (All [anchor expression directive] - (Operation anchor expression directive artifact.Registry)) - (function (_ (^@ stateE [bundle state])) - (#try.Success [stateE (get@ #registry state)]))) - -(def: #export (set_registry value) - (All [anchor expression directive] - (-> artifact.Registry (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (#try.Success [[bundle (set@ #registry value state)] - []]))) - -(def: #export next - (All [anchor expression directive] - (Operation anchor expression directive Nat)) - (do phase.monad - [count (extension.read (get@ #counter)) - _ (extension.update (update@ #counter inc))] - (wrap count))) - -(def: #export (gensym prefix) - (All [anchor expression directive] - (-> Text (Operation anchor expression directive Text))) - (\ phase.monad map (|>> %.nat (format prefix)) ..next)) - -(def: #export (enter_module module) - (All [anchor expression directive] - (-> Module (Operation anchor expression directive Any))) - (extension.update (set@ #module module))) - -(def: #export module - (All [anchor expression directive] - (Operation anchor expression directive Module)) - (extension.read (get@ #module))) - -(def: #export (evaluate! label code) - (All [anchor expression directive] - (-> Context expression (Operation anchor expression directive Any))) - (function (_ (^@ state+ [bundle state])) - (case (\ (get@ #host state) evaluate! label code) - (#try.Success output) - (#try.Success [state+ output]) - - (#try.Failure error) - (exception.throw ..cannot_interpret error)))) - -(def: #export (execute! code) - (All [anchor expression directive] - (-> directive (Operation anchor expression directive Any))) - (function (_ (^@ state+ [bundle state])) - (case (\ (get@ #host state) execute! code) - (#try.Success output) - (#try.Success [state+ output]) - - (#try.Failure error) - (exception.throw ..cannot_interpret error)))) - -(def: #export (define! context code) - (All [anchor expression directive] - (-> Context expression (Operation anchor expression directive [Text Any directive]))) - (function (_ (^@ stateE [bundle state])) - (case (\ (get@ #host state) define! context code) - (#try.Success output) - (#try.Success [stateE output]) - - (#try.Failure error) - (exception.throw ..cannot_interpret error)))) - -(def: #export (save! artifact_id code) - (All [anchor expression directive] - (-> artifact.ID directive (Operation anchor expression directive Any))) - (do {! phase.monad} - [?buffer (extension.read (get@ #buffer))] - (case ?buffer - (#.Some buffer) - ## TODO: Optimize by no longer checking for overwrites... - (if (row.any? (|>> product.left (n.= artifact_id)) buffer) - (phase.throw ..cannot_overwrite_output [artifact_id]) - (extension.update (set@ #buffer (#.Some (row.add [artifact_id code] buffer))))) - - #.None - (phase.throw ..no_buffer_for_saving_code [artifact_id])))) - -(template [<name> <artifact>] - [(def: #export (<name> name) - (All [anchor expression directive] - (-> Text (Operation anchor expression directive artifact.ID))) - (function (_ (^@ stateE [bundle state])) - (let [[id registry'] (<artifact> name (get@ #registry state))] - (#try.Success [[bundle (set@ #registry registry' state)] - id]))))] - - [learn artifact.definition] - [learn_analyser artifact.analyser] - [learn_synthesizer artifact.synthesizer] - [learn_generator artifact.generator] - [learn_directive artifact.directive] - ) - -(exception: #export (unknown_definition {name Name} - {known_definitions (List Text)}) - (exception.report - ["Definition" (name.short name)] - ["Module" (name.module name)] - ["Known Definitions" (exception.enumerate function.identity known_definitions)])) - -(def: #export (remember archive name) - (All [anchor expression directive] - (-> Archive Name (Operation anchor expression directive Context))) - (function (_ (^@ stateE [bundle state])) - (let [[_module _name] name] - (do try.monad - [module_id (archive.id _module archive) - registry (if (text\= (get@ #module state) _module) - (#try.Success (get@ #registry state)) - (do try.monad - [[descriptor document] (archive.find _module archive)] - (#try.Success (get@ #descriptor.registry descriptor))))] - (case (artifact.remember _name registry) - #.None - (exception.throw ..unknown_definition [name (artifact.definitions registry)]) - - (#.Some id) - (#try.Success [stateE [module_id id]])))))) - -(exception: #export no_context) - -(def: #export (module_id module archive) - (All [anchor expression directive] - (-> Module Archive (Operation anchor expression directive archive.ID))) - (function (_ (^@ stateE [bundle state])) - (do try.monad - [module_id (archive.id module archive)] - (wrap [stateE module_id])))) - -(def: #export (context archive) - (All [anchor expression directive] - (-> Archive (Operation anchor expression directive Context))) - (function (_ (^@ stateE [bundle state])) - (case (get@ #context state) - #.None - (exception.throw ..no_context []) - - (#.Some id) - (do try.monad - [module_id (archive.id (get@ #module state) archive)] - (wrap [stateE [module_id id]]))))) - -(def: #export (with_context id body) - (All [anchor expression directive a] - (-> artifact.ID - (Operation anchor expression directive a) - (Operation anchor expression directive a))) - (function (_ [bundle state]) - (do try.monad - [[[bundle' state'] output] (body [bundle (set@ #context (#.Some id) state)])] - (wrap [[bundle' (set@ #context (get@ #context state) state')] - output])))) - -(def: #export (with_new_context archive body) - (All [anchor expression directive a] - (-> Archive (Operation anchor expression directive a) - (Operation anchor expression directive [Context a]))) - (function (_ (^@ stateE [bundle state])) - (let [[id registry'] (artifact.resource (get@ #registry state))] - (do try.monad - [[[bundle' state'] output] (body [bundle (|> state - (set@ #registry registry') - (set@ #context (#.Some id)))]) - module_id (archive.id (get@ #module state) archive)] - (wrap [[bundle' (set@ #context (get@ #context state) state')] - [[module_id id] - output]]))))) - -(def: #export (log! message) - (All [anchor expression directive a] - (-> Text (Operation anchor expression directive Any))) - (function (_ [bundle state]) - (#try.Success [[bundle - (update@ #log (row.add message) state)] - []]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux deleted file mode 100644 index 9e0748422..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux +++ /dev/null @@ -1,143 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [data - [text - ["%" format (#+ format)]]] - ["." meta - ["." location]]] - ["." / #_ - ["#." type] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." function] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - ["/" analysis (#+ Analysis Operation Phase) - ["#." macro (#+ Expander)]] - [/// - ["//" phase] - ["." reference] - [meta - [archive (#+ Archive)]]]]]]) - -(exception: #export (unrecognized_syntax {code Code}) - (exception.report ["Code" (%.code code)])) - -## TODO: Had to split the 'compile' function due to compilation issues -## with old-luxc. Must re-combine all the code ASAP - -(type: (Fix a) - (-> a a)) - -(def: (compile|primitive else code') - (Fix (-> (Code' (Ann Location)) (Operation Analysis))) - (case code' - (^template [<tag> <analyser>] - [(<tag> value) - (<analyser> value)]) - ([#.Bit /primitive.bit] - [#.Nat /primitive.nat] - [#.Int /primitive.int] - [#.Rev /primitive.rev] - [#.Frac /primitive.frac] - [#.Text /primitive.text]) - - _ - (else code'))) - -(def: (compile|structure archive compile else code') - (-> Archive Phase (Fix (-> (Code' (Ann Location)) (Operation Analysis)))) - (case code' - (^ (#.Form (list& [_ (#.Tag tag)] - values))) - (case values - (#.Cons value #.Nil) - (/structure.tagged_sum compile tag archive value) - - _ - (/structure.tagged_sum compile tag archive (` [(~+ values)]))) - - (^ (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)] - values))) - (case values - (#.Cons value #.Nil) - (/structure.sum compile lefts right? archive value) - - _ - (/structure.sum compile lefts right? archive (` [(~+ values)]))) - - (#.Tag tag) - (/structure.tagged_sum compile tag archive (' [])) - - (^ (#.Tuple (list))) - /primitive.unit - - (^ (#.Tuple (list singleton))) - (compile archive singleton) - - (^ (#.Tuple elems)) - (/structure.product archive compile elems) - - (^ (#.Record pairs)) - (/structure.record archive compile pairs) - - _ - (else code'))) - -(def: (compile|others expander archive compile code') - (-> Expander Archive Phase (-> (Code' (Ann Location)) (Operation Analysis))) - (case code' - (#.Identifier reference) - (/reference.reference reference) - - (^ (#.Form (list [_ (#.Record branches)] input))) - (/case.case compile branches archive input) - - (^ (#.Form (list& [_ (#.Text extension_name)] extension_args))) - (//extension.apply archive compile [extension_name extension_args]) - - (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function_name])] - [_ (#.Identifier ["" arg_name])]))] - body))) - (/function.function compile function_name arg_name archive body) - - (^ (#.Form (list& functionC argsC+))) - (do {! //.monad} - [[functionT functionA] (/type.with_inference - (compile archive functionC))] - (case functionA - (#/.Reference (#reference.Constant def_name)) - (do ! - [?macro (//extension.lift (meta.find_macro def_name))] - (case ?macro - (#.Some macro) - (do ! - [expansion (//extension.lift (/macro.expand_one expander def_name macro argsC+))] - (compile archive expansion)) - - _ - (/function.apply compile argsC+ functionT functionA archive functionC))) - - _ - (/function.apply compile argsC+ functionT functionA archive functionC))) - - _ - (//.throw ..unrecognized_syntax [location.dummy code']))) - -(def: #export (phase expander) - (-> Expander Phase) - (function (compile 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 - (compile|primitive (compile|structure archive compile - (compile|others expander archive compile)) - code'))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux deleted file mode 100644 index 41fad7934..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case.lux +++ /dev/null @@ -1,324 +0,0 @@ -(.module: - [lux (#- case) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." maybe] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold monoid functor)]]] - [math - [number - ["n" nat]]] - [macro - ["." code]] - ["." type - ["." check]]] - ["." / #_ - ["#." coverage (#+ Coverage)] - ["/#" // #_ - ["#." scope] - ["#." type] - ["#." structure] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Pattern Analysis Operation Phase)] - [/// - ["#" phase]]]]]]) - -(exception: #export (cannot_match_with_pattern {type Type} {pattern Code}) - (exception.report - ["Type" (%.type type)] - ["Pattern" (%.code pattern)])) - -(exception: #export (sum_has_no_case {case Nat} {type Type}) - (exception.report - ["Case" (%.nat case)] - ["Type" (%.type type)])) - -(exception: #export (not_a_pattern {code Code}) - (exception.report ["Code" (%.code code)])) - -(exception: #export (cannot_simplify_for_pattern_matching {type Type}) - (exception.report ["Type" (%.type type)])) - -(exception: #export (non_exhaustive_pattern_matching {input Code} {branches (List [Code Code])} {coverage Coverage}) - (exception.report - ["Input" (%.code input)] - ["Branches" (%.code (code.record branches))] - ["Coverage" (/coverage.%coverage coverage)])) - -(exception: #export (cannot_have_empty_branches {message Text}) - message) - -(def: (re_quantify envs baseT) - (-> (List (List Type)) Type Type) - (.case envs - #.Nil - baseT - - (#.Cons head tail) - (re_quantify tail (#.UnivQ head baseT)))) - -## Type-checking on the input value is done during the analysis of a -## "case" expression, to ensure that the patterns being used make -## sense for the type of the input value. -## Sometimes, that input value is complex, by depending on -## type-variables or quantifications. -## This function makes it easier for "case" analysis to properly -## type-check the input with respect to the patterns. -(def: (simplify_case caseT) - (-> Type (Operation Type)) - (loop [envs (: (List (List Type)) - (list)) - caseT caseT] - (.case caseT - (#.Var id) - (do ///.monad - [?caseT' (//type.with_env - (check.read id))] - (.case ?caseT' - (#.Some caseT') - (recur envs caseT') - - _ - (/.throw ..cannot_simplify_for_pattern_matching caseT))) - - (#.Named name unnamedT) - (recur envs unnamedT) - - (#.UnivQ env unquantifiedT) - (recur (#.Cons env envs) unquantifiedT) - - (#.ExQ _) - (do ///.monad - [[var_id varT] (//type.with_env - check.var)] - (recur envs (maybe.assume (type.apply (list varT) caseT)))) - - (#.Apply inputT funcT) - (.case funcT - (#.Var funcT_id) - (do ///.monad - [funcT' (//type.with_env - (do check.monad - [?funct' (check.read funcT_id)] - (.case ?funct' - (#.Some funct') - (wrap funct') - - _ - (check.throw ..cannot_simplify_for_pattern_matching caseT))))] - (recur envs (#.Apply inputT funcT'))) - - _ - (.case (type.apply (list inputT) funcT) - (#.Some outputT) - (recur envs outputT) - - #.None - (/.throw ..cannot_simplify_for_pattern_matching caseT))) - - (#.Product _) - (|> caseT - type.flatten_tuple - (list\map (re_quantify envs)) - type.tuple - (\ ///.monad wrap)) - - _ - (\ ///.monad wrap (re_quantify envs caseT))))) - -(def: (analyse_primitive type inputT location output next) - (All [a] (-> Type Type Location Pattern (Operation a) (Operation [Pattern a]))) - (/.with_location location - (do ///.monad - [_ (//type.with_env - (check.check inputT type)) - outputA next] - (wrap [output outputA])))) - -## This function handles several concerns at once, but it must be that -## way because those concerns are interleaved when doing -## pattern-matching and they cannot be separated. -## The pattern is analysed in order to get a general feel for what is -## expected of the input value. This, in turn, informs the -## type-checking of the input. -## A kind of "continuation" value is passed around which signifies -## what needs to be done _after_ analysing a pattern. -## In general, this is done to analyse the "body" expression -## associated to a particular pattern _in the context of_ said -## pattern. -## The reason why *context* is important is because patterns may bind -## values to local variables, which may in turn be referenced in the -## body expressions. -## That is why the body must be analysed in the context of the -## pattern, and not separately. -(def: (analyse_pattern num_tags inputT pattern next) - (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) - (.case pattern - [location (#.Identifier ["" name])] - (/.with_location location - (do ///.monad - [outputA (//scope.with_local [name inputT] - next) - idx //scope.next_local] - (wrap [(#/.Bind idx) outputA]))) - - (^template [<type> <input> <output>] - [[location <input>] - (analyse_primitive <type> inputT location (#/.Simple <output>) next)]) - ([Bit (#.Bit pattern_value) (#/.Bit pattern_value)] - [Nat (#.Nat pattern_value) (#/.Nat pattern_value)] - [Int (#.Int pattern_value) (#/.Int pattern_value)] - [Rev (#.Rev pattern_value) (#/.Rev pattern_value)] - [Frac (#.Frac pattern_value) (#/.Frac pattern_value)] - [Text (#.Text pattern_value) (#/.Text pattern_value)] - [Any (#.Tuple #.Nil) #/.Unit]) - - (^ [location (#.Tuple (list singleton))]) - (analyse_pattern #.None inputT singleton next) - - [location (#.Tuple sub_patterns)] - (/.with_location location - (do {! ///.monad} - [inputT' (simplify_case inputT)] - (.case inputT' - (#.Product _) - (let [subs (type.flatten_tuple inputT') - num_subs (maybe.default (list.size subs) - num_tags) - num_sub_patterns (list.size sub_patterns) - matches (cond (n.< num_subs num_sub_patterns) - (let [[prefix suffix] (list.split (dec num_sub_patterns) subs)] - (list.zip/2 (list\compose prefix (list (type.tuple suffix))) sub_patterns)) - - (n.> num_subs num_sub_patterns) - (let [[prefix suffix] (list.split (dec num_subs) sub_patterns)] - (list.zip/2 subs (list\compose prefix (list (code.tuple suffix))))) - - ## (n.= num_subs num_sub_patterns) - (list.zip/2 subs sub_patterns))] - (do ! - [[memberP+ thenA] (list\fold (: (All [a] - (-> [Type Code] (Operation [(List Pattern) a]) - (Operation [(List Pattern) a]))) - (function (_ [memberT memberC] then) - (do ! - [[memberP [memberP+ thenA]] ((:as (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) - analyse_pattern) - #.None memberT memberC then)] - (wrap [(list& memberP memberP+) thenA])))) - (do ! - [nextA next] - (wrap [(list) nextA])) - (list.reverse matches))] - (wrap [(/.pattern/tuple memberP+) - thenA]))) - - _ - (/.throw ..cannot_match_with_pattern [inputT' pattern]) - ))) - - [location (#.Record record)] - (do ///.monad - [record (//structure.normalize record) - [members recordT] (//structure.order record) - _ (.case inputT - (#.Var _id) - (//type.with_env - (check.check inputT recordT)) - - _ - (wrap []))] - (analyse_pattern (#.Some (list.size members)) inputT [location (#.Tuple members)] next)) - - [location (#.Tag tag)] - (/.with_location location - (analyse_pattern #.None inputT (` ((~ pattern))) next)) - - (^ [location (#.Form (list& [_ (#.Nat lefts)] [_ (#.Bit right?)] values))]) - (/.with_location location - (do ///.monad - [inputT' (simplify_case inputT)] - (.case inputT' - (#.Sum _) - (let [flat_sum (type.flatten_variant inputT') - size_sum (list.size flat_sum) - num_cases (maybe.default size_sum num_tags) - idx (/.tag lefts right?)] - (.case (list.nth idx flat_sum) - (^multi (#.Some caseT) - (n.< num_cases idx)) - (do ///.monad - [[testP nextA] (if (and (n.> num_cases size_sum) - (n.= (dec num_cases) idx)) - (analyse_pattern #.None - (type.variant (list.drop (dec num_cases) flat_sum)) - (` [(~+ values)]) - next) - (analyse_pattern #.None caseT (` [(~+ values)]) next))] - (wrap [(/.pattern/variant [lefts right? testP]) - nextA])) - - _ - (/.throw ..sum_has_no_case [idx inputT]))) - - (#.UnivQ _) - (do ///.monad - [[ex_id exT] (//type.with_env - check.existential)] - (analyse_pattern num_tags - (maybe.assume (type.apply (list exT) inputT')) - pattern - next)) - - _ - (/.throw ..cannot_match_with_pattern [inputT' pattern])))) - - (^ [location (#.Form (list& [_ (#.Tag tag)] values))]) - (/.with_location location - (do ///.monad - [tag (///extension.lift (meta.normalize tag)) - [idx group variantT] (///extension.lift (meta.resolve_tag tag)) - _ (//type.with_env - (check.check inputT variantT)) - #let [[lefts right?] (/.choice (list.size group) idx)]] - (analyse_pattern (#.Some (list.size group)) inputT (` ((~ (code.nat lefts)) (~ (code.bit right?)) (~+ values))) next))) - - _ - (/.throw ..not_a_pattern pattern) - )) - -(def: #export (case analyse branches archive inputC) - (-> Phase (List [Code Code]) Phase) - (.case branches - (#.Cons [patternH bodyH] branchesT) - (do {! ///.monad} - [[inputT inputA] (//type.with_inference - (analyse archive inputC)) - outputH (analyse_pattern #.None inputT patternH (analyse archive bodyH)) - outputT (monad.map ! - (function (_ [patternT bodyT]) - (analyse_pattern #.None inputT patternT (analyse archive bodyT))) - branchesT) - outputHC (|> outputH product.left /coverage.determine) - outputTC (monad.map ! (|>> product.left /coverage.determine) outputT) - _ (.case (monad.fold try.monad /coverage.merge outputHC outputTC) - (#try.Success coverage) - (///.assert non_exhaustive_pattern_matching [inputC branches coverage] - (/coverage.exhaustive? coverage)) - - (#try.Failure error) - (/.fail error))] - (wrap (#/.Case inputA [outputH outputT]))) - - #.Nil - (/.throw ..cannot_have_empty_branches ""))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux deleted file mode 100644 index 4a3afc3f5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux +++ /dev/null @@ -1,372 +0,0 @@ -(.module: - [lux #* - [abstract - equivalence - ["." monad (#+ do)]] - [control - ["." try (#+ Try) ("#\." monad)] - ["ex" exception (#+ exception:)]] - [data - ["." bit ("#\." equivalence)] - ["." maybe] - ["." text - ["%" format (#+ Format format)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["n" nat]]]] - ["." //// #_ - [// - ["/" analysis (#+ Pattern Variant Operation)] - [/// - ["#" phase ("#\." monad)]]]]) - -(exception: #export (invalid_tuple_pattern) - "Tuple size must be >= 2") - -(def: cases - (-> (Maybe Nat) Nat) - (|>> (maybe.default 0))) - -(def: known_cases? - (-> Nat Bit) - (n.> 0)) - -## The coverage of a pattern-matching expression summarizes how well -## all the possible values of an input are being covered by the -## different patterns involved. -## Ideally, the pattern-matching has "exhaustive" coverage, which just -## means that every possible value can be matched by at least 1 -## pattern. -## Every other coverage is considered partial, and it would be valued -## as insuficient (since it could lead to runtime errors due to values -## not being handled by any pattern). -## The #Partial tag covers arbitrary partial coverages in a general -## way, while the other tags cover more specific cases for bits -## and variants. -(type: #export #rec Coverage - #Partial - (#Bit Bit) - (#Variant (Maybe Nat) (Dictionary Nat Coverage)) - (#Seq Coverage Coverage) - (#Alt Coverage Coverage) - #Exhaustive) - -(def: #export (exhaustive? coverage) - (-> Coverage Bit) - (case coverage - (#Exhaustive _) - #1 - - _ - #0)) - -(def: #export (%coverage value) - (Format Coverage) - (case value - #Partial - "#Partial" - - (#Bit value') - (|> value' - %.bit - (text.enclose ["(#Bit " ")"])) - - (#Variant ?max_cases cases) - (|> cases - dictionary.entries - (list\map (function (_ [idx coverage]) - (format (%.nat idx) " " (%coverage coverage)))) - (text.join_with " ") - (text.enclose ["{" "}"]) - (format (%.nat (..cases ?max_cases)) " ") - (text.enclose ["(#Variant " ")"])) - - (#Seq left right) - (format "(#Seq " (%coverage left) " " (%coverage right) ")") - - (#Alt left right) - (format "(#Alt " (%coverage left) " " (%coverage right) ")") - - #Exhaustive - "#Exhaustive")) - -(def: #export (determine pattern) - (-> Pattern (Operation Coverage)) - (case pattern - (^or (#/.Simple #/.Unit) - (#/.Bind _)) - (////\wrap #Exhaustive) - - ## Primitive patterns always have partial coverage because there - ## are too many possibilities as far as values go. - (^template [<tag>] - [(#/.Simple (<tag> _)) - (////\wrap #Partial)]) - ([#/.Nat] - [#/.Int] - [#/.Rev] - [#/.Frac] - [#/.Text]) - - ## Bits are the exception, since there is only "#1" and - ## "#0", which means it is possible for bit - ## pattern-matching to become exhaustive if complementary parts meet. - (#/.Simple (#/.Bit value)) - (////\wrap (#Bit value)) - - ## Tuple patterns can be exhaustive if there is exhaustiveness for all of - ## their sub-patterns. - (#/.Complex (#/.Tuple membersP+)) - (case (list.reverse membersP+) - (^or #.Nil (#.Cons _ #.Nil)) - (/.throw ..invalid_tuple_pattern []) - - (#.Cons lastP prevsP+) - (do ////.monad - [lastC (determine lastP)] - (monad.fold ////.monad - (function (_ leftP rightC) - (do ////.monad - [leftC (determine leftP)] - (case rightC - #Exhaustive - (wrap leftC) - - _ - (wrap (#Seq leftC rightC))))) - lastC prevsP+))) - - ## Variant patterns can be shown to be exhaustive if all the possible - ## cases are handled exhaustively. - (#/.Complex (#/.Variant [lefts right? value])) - (do ////.monad - [value_coverage (determine value) - #let [idx (if right? - (inc lefts) - lefts)]] - (wrap (#Variant (if right? - (#.Some idx) - #.None) - (|> (dictionary.new n.hash) - (dictionary.put idx value_coverage))))))) - -(def: (xor left right) - (-> Bit Bit Bit) - (or (and left (not right)) - (and (not left) right))) - -## The coverage checker not only verifies that pattern-matching is -## exhaustive, but also that there are no redundant patterns. -## Redundant patterns will never be executed, since there will -## always be a pattern prior to them that would match the input. -## Because of that, the presence of redundant patterns is assumed to -## be a bug, likely due to programmer carelessness. -(exception: #export (redundant_pattern {so_far Coverage} {addition Coverage}) - (ex.report ["Coverage so-far" (%coverage so_far)] - ["Coverage addition" (%coverage addition)])) - -(def: (flatten_alt coverage) - (-> Coverage (List Coverage)) - (case coverage - (#Alt left right) - (list& left (flatten_alt right)) - - _ - (list coverage))) - -(implementation: equivalence (Equivalence Coverage) - (def: (= reference sample) - (case [reference sample] - [#Exhaustive #Exhaustive] - #1 - - [(#Bit sideR) (#Bit sideS)] - (bit\= sideR sideS) - - [(#Variant allR casesR) (#Variant allS casesS)] - (and (n.= (cases allR) - (cases allS)) - (\ (dictionary.equivalence =) = casesR casesS)) - - [(#Seq leftR rightR) (#Seq leftS rightS)] - (and (= leftR leftS) - (= rightR rightS)) - - [(#Alt _) (#Alt _)] - (let [flatR (flatten_alt reference) - flatS (flatten_alt sample)] - (and (n.= (list.size flatR) (list.size flatS)) - (list.every? (function (_ [coverageR coverageS]) - (= coverageR coverageS)) - (list.zip/2 flatR flatS)))) - - _ - #0))) - -(open: "coverage/." ..equivalence) - -(exception: #export (variants_do_not_match {addition_cases Nat} {so_far_cases Nat}) - (ex.report ["So-far Cases" (%.nat so_far_cases)] - ["Addition Cases" (%.nat addition_cases)])) - -## After determining the coverage of each individual pattern, it is -## necessary to merge them all to figure out if the entire -## pattern-matching expression is exhaustive and whether it contains -## redundant patterns. -(def: #export (merge addition so_far) - (-> Coverage Coverage (Try Coverage)) - (case [addition so_far] - [#Partial #Partial] - (try\wrap #Partial) - - ## 2 bit coverages are exhaustive if they complement one another. - (^multi [(#Bit sideA) (#Bit sideSF)] - (xor sideA sideSF)) - (try\wrap #Exhaustive) - - [(#Variant allA casesA) (#Variant allSF casesSF)] - (let [addition_cases (cases allSF) - so_far_cases (cases allA)] - (cond (and (known_cases? addition_cases) - (known_cases? so_far_cases) - (not (n.= addition_cases so_far_cases))) - (ex.throw ..variants_do_not_match [addition_cases so_far_cases]) - - (\ (dictionary.equivalence ..equivalence) = casesSF casesA) - (ex.throw ..redundant_pattern [so_far addition]) - - ## else - (do {! try.monad} - [casesM (monad.fold ! - (function (_ [tagA coverageA] casesSF') - (case (dictionary.get tagA casesSF') - (#.Some coverageSF) - (do ! - [coverageM (merge coverageA coverageSF)] - (wrap (dictionary.put tagA coverageM casesSF'))) - - #.None - (wrap (dictionary.put tagA coverageA casesSF')))) - casesSF (dictionary.entries casesA))] - (wrap (if (and (or (known_cases? addition_cases) - (known_cases? so_far_cases)) - (n.= (inc (n.max addition_cases so_far_cases)) - (dictionary.size casesM)) - (list.every? exhaustive? (dictionary.values casesM))) - #Exhaustive - (#Variant (case allSF - (#.Some _) - allSF - - _ - allA) - casesM)))))) - - [(#Seq leftA rightA) (#Seq leftSF rightSF)] - (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)] - ## Same prefix - [#1 #0] - (do try.monad - [rightM (merge rightA rightSF)] - (if (exhaustive? rightM) - ## If all that follows is exhaustive, then it can be safely dropped - ## (since only the "left" part would influence whether the - ## merged coverage is exhaustive or not). - (wrap leftSF) - (wrap (#Seq leftSF rightM)))) - - ## Same suffix - [#0 #1] - (do try.monad - [leftM (merge leftA leftSF)] - (wrap (#Seq leftM rightA))) - - ## The 2 sequences cannot possibly be merged. - [#0 #0] - (try\wrap (#Alt so_far addition)) - - ## There is nothing the addition adds to the coverage. - [#1 #1] - (ex.throw ..redundant_pattern [so_far addition])) - - ## The addition cannot possibly improve the coverage. - [_ #Exhaustive] - (ex.throw ..redundant_pattern [so_far addition]) - - ## The addition completes the coverage. - [#Exhaustive _] - (try\wrap #Exhaustive) - - ## The left part will always match, so the addition is redundant. - (^multi [(#Seq left right) single] - (coverage/= left single)) - (ex.throw ..redundant_pattern [so_far addition]) - - ## The right part is not necessary, since it can always match the left. - (^multi [single (#Seq left right)] - (coverage/= left single)) - (try\wrap single) - - ## When merging a new coverage against one based on Alt, it may be - ## that one of the many coverages in the Alt is complementary to - ## the new one, so effort must be made to fuse carefully, to match - ## the right coverages together. - ## If one of the Alt sub-coverages matches the new one, the cycle - ## must be repeated, in case the resulting coverage can now match - ## other ones in the original Alt. - ## This process must be repeated until no further productive - ## merges can be done. - [_ (#Alt leftS rightS)] - (do {! try.monad} - [#let [fuse_once (: (-> Coverage (List Coverage) - (Try [(Maybe Coverage) - (List Coverage)])) - (function (_ coverageA possibilitiesSF) - (loop [altsSF possibilitiesSF] - (case altsSF - #.Nil - (wrap [#.None (list coverageA)]) - - (#.Cons altSF altsSF') - (case (merge coverageA altSF) - (#try.Success altMSF) - (case altMSF - (#Alt _) - (do ! - [[success altsSF+] (recur altsSF')] - (wrap [success (#.Cons altSF altsSF+)])) - - _ - (wrap [(#.Some altMSF) altsSF'])) - - (#try.Failure error) - (try.fail error)) - ))))] - [successA possibilitiesSF] (fuse_once addition (flatten_alt so_far))] - (loop [successA successA - possibilitiesSF possibilitiesSF] - (case successA - (#.Some coverageA') - (do ! - [[successA' possibilitiesSF'] (fuse_once coverageA' possibilitiesSF)] - (recur successA' possibilitiesSF')) - - #.None - (case (list.reverse possibilitiesSF) - (#.Cons last prevs) - (wrap (list\fold (function (_ left right) (#Alt left right)) - last - prevs)) - - #.Nil - (undefined))))) - - _ - (if (coverage/= so_far addition) - ## The addition cannot possibly improve the coverage. - (ex.throw ..redundant_pattern [so_far addition]) - ## There are now 2 alternative paths. - (try\wrap (#Alt so_far addition))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux deleted file mode 100644 index 3b654fffd..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/function.lux +++ /dev/null @@ -1,112 +0,0 @@ -(.module: - [lux (#- function) - [abstract - monad] - [control - ["ex" exception (#+ exception:)]] - [data - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold monoid monad)]]] - ["." type - ["." check]] - ["." meta]] - ["." // #_ - ["#." scope] - ["#." type] - ["#." inference] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Analysis Operation Phase)] - [/// - ["#" phase] - [reference (#+) - [variable (#+)]]]]]]) - -(exception: #export (cannot_analyse {expected Type} {function Text} {argument Text} {body Code}) - (ex.report ["Type" (%.type expected)] - ["Function" function] - ["Argument" argument] - ["Body" (%.code body)])) - -(exception: #export (cannot_apply {functionT Type} {functionC Code} {arguments (List Code)}) - (ex.report ["Function type" (%.type functionT)] - ["Function" (%.code functionC)] - ["Arguments" (|> arguments - list.enumeration - (list\map (.function (_ [idx argC]) - (format (%.nat idx) " " (%.code argC)))) - (text.join_with text.new_line))])) - -(def: #export (function analyse function_name arg_name archive body) - (-> Phase Text Text Phase) - (do {! ///.monad} - [functionT (///extension.lift meta.expected_type)] - (loop [expectedT functionT] - (/.with_stack ..cannot_analyse [expectedT function_name arg_name body] - (case expectedT - (#.Named name unnamedT) - (recur unnamedT) - - (#.Apply argT funT) - (case (type.apply (list argT) funT) - (#.Some value) - (recur value) - - #.None - (/.fail (ex.construct cannot_analyse [expectedT function_name arg_name body]))) - - (^template [<tag> <instancer>] - [(<tag> _) - (do ! - [[_ instanceT] (//type.with_env <instancer>)] - (recur (maybe.assume (type.apply (list instanceT) expectedT))))]) - ([#.UnivQ check.existential] - [#.ExQ check.var]) - - (#.Var id) - (do ! - [?expectedT' (//type.with_env - (check.read id))] - (case ?expectedT' - (#.Some expectedT') - (recur expectedT') - - ## Inference - _ - (do ! - [[input_id inputT] (//type.with_env check.var) - [output_id outputT] (//type.with_env check.var) - #let [functionT (#.Function inputT outputT)] - functionA (recur functionT) - _ (//type.with_env - (check.check expectedT functionT))] - (wrap functionA)) - )) - - (#.Function inputT outputT) - (<| (\ ! map (.function (_ [scope bodyA]) - (#/.Function (list\map (|>> /.variable) - (//scope.environment scope)) - bodyA))) - /.with_scope - ## Functions have access not only to their argument, but - ## also to themselves, through a local variable. - (//scope.with_local [function_name expectedT]) - (//scope.with_local [arg_name inputT]) - (//type.with_type outputT) - (analyse archive body)) - - _ - (/.fail "") - ))))) - -(def: #export (apply analyse argsC+ functionT functionA archive functionC) - (-> Phase (List Code) Type Analysis Phase) - (<| (/.with_stack ..cannot_apply [functionT functionC argsC+]) - (do ///.monad - [[applyT argsA+] (//inference.general archive analyse functionT argsC+)]) - (wrap (/.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux deleted file mode 100644 index 31a5cb912..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux +++ /dev/null @@ -1,300 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [data - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [math - [number - ["n" nat]]] - ["." type - ["." check]] - ["." meta]] - ["." // #_ - ["#." type] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Tag Analysis Operation Phase)] - [/// - ["#" phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]) - -(exception: #export (variant_tag_out_of_bounds {size Nat} {tag Tag} {type Type}) - (exception.report - ["Tag" (%.nat tag)] - ["Variant size" (%.int (.int size))] - ["Variant type" (%.type type)])) - -(exception: #export (cannot_infer {type Type} {args (List Code)}) - (exception.report - ["Type" (%.type type)] - ["Arguments" (exception.enumerate %.code args)])) - -(exception: #export (cannot_infer_argument {inferred Type} {argument Code}) - (exception.report - ["Inferred Type" (%.type inferred)] - ["Argument" (%.code argument)])) - -(exception: #export (smaller_variant_than_expected {expected Nat} {actual Nat}) - (exception.report - ["Expected" (%.int (.int expected))] - ["Actual" (%.int (.int actual))])) - -(template [<name>] - [(exception: #export (<name> {type Type}) - (%.type type))] - - [not_a_variant_type] - [not_a_record_type] - [invalid_type_application] - ) - -(def: (replace parameter_idx replacement type) - (-> Nat Type Type Type) - (case type - (#.Primitive name params) - (#.Primitive name (list\map (replace parameter_idx replacement) params)) - - (^template [<tag>] - [(<tag> left right) - (<tag> (replace parameter_idx replacement left) - (replace parameter_idx replacement right))]) - ([#.Sum] - [#.Product] - [#.Function] - [#.Apply]) - - (#.Parameter idx) - (if (n.= parameter_idx idx) - replacement - type) - - (^template [<tag>] - [(<tag> env quantified) - (<tag> (list\map (replace parameter_idx replacement) env) - (replace (n.+ 2 parameter_idx) replacement quantified))]) - ([#.UnivQ] - [#.ExQ]) - - _ - type)) - -(def: (named_type location id) - (-> Location Nat Type) - (let [name (format "{New Type " (%.location location) " " (%.nat id) "}")] - (#.Primitive name (list)))) - -(def: new_named_type - (Operation Type) - (do ///.monad - [location (///extension.lift meta.location) - [ex_id _] (//type.with_env check.existential)] - (wrap (named_type location ex_id)))) - -## Type-inference works by applying some (potentially quantified) type -## to a sequence of values. -## Function types are used for this, although inference is not always -## done for function application (alternative uses may be records and -## tagged variants). -## But, so long as the type being used for the inference can be treated -## as a function type, this method of inference should work. -(def: #export (general archive analyse inferT args) - (-> Archive Phase Type (List Code) (Operation [Type (List Analysis)])) - (case args - #.Nil - (do ///.monad - [_ (//type.infer inferT)] - (wrap [inferT (list)])) - - (#.Cons argC args') - (case inferT - (#.Named name unnamedT) - (general archive analyse unnamedT args) - - (#.UnivQ _) - (do ///.monad - [[var_id varT] (//type.with_env check.var)] - (general archive analyse (maybe.assume (type.apply (list varT) inferT)) args)) - - (#.ExQ _) - (do {! ///.monad} - [[var_id varT] (//type.with_env check.var) - output (general archive analyse - (maybe.assume (type.apply (list varT) inferT)) - args) - bound? (//type.with_env - (check.bound? var_id)) - _ (if bound? - (wrap []) - (do ! - [newT new_named_type] - (//type.with_env - (check.check varT newT))))] - (wrap output)) - - (#.Apply inputT transT) - (case (type.apply (list inputT) transT) - (#.Some outputT) - (general archive analyse outputT args) - - #.None - (/.throw ..invalid_type_application inferT)) - - ## Arguments are inferred back-to-front because, by convention, - ## Lux functions take the most important arguments *last*, which - ## means that the most information for doing proper inference is - ## located in the last arguments to a function call. - ## By inferring back-to-front, a lot of type-annotations can be - ## avoided in Lux code, since the inference algorithm can piece - ## things together more easily. - (#.Function inputT outputT) - (do ///.monad - [[outputT' args'A] (general archive analyse outputT args') - argA (<| (/.with_stack ..cannot_infer_argument [inputT argC]) - (//type.with_type inputT) - (analyse archive argC))] - (wrap [outputT' (list& argA args'A)])) - - (#.Var infer_id) - (do ///.monad - [?inferT' (//type.with_env (check.read infer_id))] - (case ?inferT' - (#.Some inferT') - (general archive analyse inferT' args) - - _ - (/.throw ..cannot_infer [inferT args]))) - - _ - (/.throw ..cannot_infer [inferT args])) - )) - -(def: (substitute_bound target sub) - (-> Nat Type Type Type) - (function (recur base) - (case base - (#.Primitive name parameters) - (#.Primitive name (list\map recur parameters)) - - (^template [<tag>] - [(<tag> left right) - (<tag> (recur left) (recur right))]) - ([#.Sum] [#.Product] [#.Function] [#.Apply]) - - (#.Parameter index) - (if (n.= target index) - sub - base) - - (^template [<tag>] - [(<tag> environment quantified) - (<tag> (list\map recur environment) quantified)]) - ([#.UnivQ] [#.ExQ]) - - _ - base))) - -## Turns a record type into the kind of function type suitable for inference. -(def: (record' target originalT inferT) - (-> Nat Type Type (Operation Type)) - (case inferT - (#.Named name unnamedT) - (record' target originalT unnamedT) - - (^template [<tag>] - [(<tag> env bodyT) - (do ///.monad - [bodyT+ (record' (n.+ 2 target) originalT bodyT)] - (wrap (<tag> env bodyT+)))]) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (record' target originalT outputT) - - #.None - (/.throw ..invalid_type_application inferT)) - - (#.Product _) - (///\wrap (|> inferT - (type.function (type.flatten_tuple inferT)) - (substitute_bound target originalT))) - - _ - (/.throw ..not_a_record_type inferT))) - -(def: #export (record inferT) - (-> Type (Operation Type)) - (record' (n.- 2 0) inferT inferT)) - -## Turns a variant type into the kind of function type suitable for inference. -(def: #export (variant tag expected_size inferT) - (-> Nat Nat Type (Operation Type)) - (loop [depth 0 - currentT inferT] - (case currentT - (#.Named name unnamedT) - (do ///.monad - [unnamedT+ (recur depth unnamedT)] - (wrap unnamedT+)) - - (^template [<tag>] - [(<tag> env bodyT) - (do ///.monad - [bodyT+ (recur (inc depth) bodyT)] - (wrap (<tag> env bodyT+)))]) - ([#.UnivQ] - [#.ExQ]) - - (#.Sum _) - (let [cases (type.flatten_variant currentT) - actual_size (list.size cases) - boundary (dec expected_size)] - (cond (or (n.= expected_size actual_size) - (and (n.> expected_size actual_size) - (n.< boundary tag))) - (case (list.nth tag cases) - (#.Some caseT) - (///\wrap (if (n.= 0 depth) - (type.function (list caseT) currentT) - (let [replace' (replace (|> depth dec (n.* 2)) inferT)] - (type.function (list (replace' caseT)) - (replace' currentT))))) - - #.None - (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT])) - - (n.< expected_size actual_size) - (/.throw ..smaller_variant_than_expected [expected_size actual_size]) - - (n.= boundary tag) - (let [caseT (type.variant (list.drop boundary cases))] - (///\wrap (if (n.= 0 depth) - (type.function (list caseT) currentT) - (let [replace' (replace (|> depth dec (n.* 2)) inferT)] - (type.function (list (replace' caseT)) - (replace' currentT)))))) - - ## else - (/.throw ..variant_tag_out_of_bounds [expected_size tag inferT]))) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (variant tag expected_size outputT) - - #.None - (/.throw ..invalid_type_application inferT)) - - _ - (/.throw ..not_a_variant_type inferT)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux deleted file mode 100644 index 1d7e5dc27..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/module.lux +++ /dev/null @@ -1,274 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - pipe - ["." try] - ["." exception (#+ exception:)]] - [data - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold functor)] - [dictionary - ["." plist]]]] - ["." meta]] - ["." /// #_ - ["#." extension] - [// - ["/" analysis (#+ Operation)] - [/// - ["#" phase]]]]) - -(type: #export Tag Text) - -(exception: #export (unknown_module {module Text}) - (exception.report - ["Module" module])) - -(exception: #export (cannot_declare_tag_twice {module Text} {tag Text}) - (exception.report - ["Module" module] - ["Tag" tag])) - -(template [<name>] - [(exception: #export (<name> {tags (List Text)} {owner Type}) - (exception.report - ["Tags" (text.join_with " " tags)] - ["Type" (%.type owner)]))] - - [cannot_declare_tags_for_unnamed_type] - [cannot_declare_tags_for_foreign_type] - ) - -(exception: #export (cannot_define_more_than_once {name Name} {already_existing Global}) - (exception.report - ["Definition" (%.name name)] - ["Original" (case already_existing - (#.Alias alias) - (format "alias " (%.name alias)) - - (#.Definition definition) - (format "definition " (%.name name)))])) - -(exception: #export (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")])) - -(exception: #export (cannot_set_module_annotations_more_than_once {module Text} {old Code} {new Code}) - (exception.report - ["Module" module] - ["Old annotations" (%.code old)] - ["New annotations" (%.code new)])) - -(def: #export (new hash) - (-> Nat Module) - {#.module_hash hash - #.module_aliases (list) - #.definitions (list) - #.imports (list) - #.tags (list) - #.types (list) - #.module_annotations #.None - #.module_state #.Active}) - -(def: #export (set_annotations annotations) - (-> Code (Operation Any)) - (///extension.lift - (do ///.monad - [self_name meta.current_module_name - self meta.current_module] - (case (get@ #.module_annotations self) - #.None - (function (_ state) - (#try.Success [(update@ #.modules - (plist.put self_name (set@ #.module_annotations (#.Some annotations) self)) - state) - []])) - - (#.Some old) - (/.throw' cannot_set_module_annotations_more_than_once [self_name old annotations]))))) - -(def: #export (import module) - (-> Text (Operation Any)) - (///extension.lift - (do ///.monad - [self_name meta.current_module_name] - (function (_ state) - (#try.Success [(update@ #.modules - (plist.update self_name (update@ #.imports (function (_ current) - (if (list.any? (text\= module) - current) - current - (#.Cons module current))))) - state) - []]))))) - -(def: #export (alias alias module) - (-> Text Text (Operation Any)) - (///extension.lift - (do ///.monad - [self_name meta.current_module_name] - (function (_ state) - (#try.Success [(update@ #.modules - (plist.update self_name (update@ #.module_aliases (: (-> (List [Text Text]) (List [Text Text])) - (|>> (#.Cons [alias module]))))) - state) - []]))))) - -(def: #export (exists? module) - (-> Text (Operation Bit)) - (///extension.lift - (function (_ state) - (|> state - (get@ #.modules) - (plist.get module) - (case> (#.Some _) #1 #.None #0) - [state] #try.Success)))) - -(def: #export (define name definition) - (-> Text Global (Operation Any)) - (///extension.lift - (do ///.monad - [self_name meta.current_module_name - self meta.current_module] - (function (_ state) - (case (plist.get name (get@ #.definitions self)) - #.None - (#try.Success [(update@ #.modules - (plist.put self_name - (update@ #.definitions - (: (-> (List [Text Global]) (List [Text Global])) - (|>> (#.Cons [name definition]))) - self)) - state) - []]) - - (#.Some already_existing) - ((/.throw' ..cannot_define_more_than_once [[self_name name] already_existing]) state)))))) - -(def: #export (create hash name) - (-> Nat Text (Operation Any)) - (///extension.lift - (function (_ state) - (#try.Success [(update@ #.modules - (plist.put name (new hash)) - state) - []])))) - -(def: #export (with_module hash name action) - (All [a] (-> Nat Text (Operation a) (Operation [Module a]))) - (do ///.monad - [_ (create hash name) - output (/.with_current_module name - action) - module (///extension.lift (meta.find_module name))] - (wrap [module output]))) - -(template [<setter> <asker> <tag>] - [(def: #export (<setter> module_name) - (-> Text (Operation Any)) - (///extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get module_name)) - (#.Some module) - (let [active? (case (get@ #.module_state module) - #.Active #1 - _ #0)] - (if active? - (#try.Success [(update@ #.modules - (plist.put module_name (set@ #.module_state <tag> module)) - state) - []]) - ((/.throw' can_only_change_state_of_active_module [module_name <tag>]) - state))) - - #.None - ((/.throw' unknown_module module_name) state))))) - - (def: #export (<asker> module_name) - (-> Text (Operation Bit)) - (///extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get module_name)) - (#.Some module) - (#try.Success [state - (case (get@ #.module_state module) - <tag> #1 - _ #0)]) - - #.None - ((/.throw' unknown_module module_name) state)))))] - - [set_active active? #.Active] - [set_compiled compiled? #.Compiled] - [set_cached cached? #.Cached] - ) - -(template [<name> <tag> <type>] - [(def: (<name> module_name) - (-> Text (Operation <type>)) - (///extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get module_name)) - (#.Some module) - (#try.Success [state (get@ <tag> module)]) - - #.None - ((/.throw' unknown_module module_name) state)))))] - - [tags #.tags (List [Text [Nat (List Name) Bit Type]])] - [types #.types (List [Text [(List Name) Bit Type]])] - [hash #.module_hash Nat] - ) - -(def: (ensure_undeclared_tags module_name tags) - (-> Text (List Tag) (Operation Any)) - (do {! ///.monad} - [bindings (..tags module_name) - _ (monad.map ! - (function (_ tag) - (case (plist.get tag bindings) - #.None - (wrap []) - - (#.Some _) - (/.throw ..cannot_declare_tag_twice [module_name tag]))) - tags)] - (wrap []))) - -(def: #export (declare_tags tags exported? type) - (-> (List Tag) Bit Type (Operation Any)) - (do ///.monad - [self_name (///extension.lift meta.current_module_name) - [type_module type_name] (case type - (#.Named type_name _) - (wrap type_name) - - _ - (/.throw ..cannot_declare_tags_for_unnamed_type [tags type])) - _ (ensure_undeclared_tags self_name tags) - _ (///.assert cannot_declare_tags_for_foreign_type [tags type] - (text\= self_name type_module))] - (///extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get self_name)) - (#.Some module) - (let [namespaced_tags (list\map (|>> [self_name]) tags)] - (#try.Success [(update@ #.modules - (plist.update self_name - (|>> (update@ #.tags (function (_ tag_bindings) - (list\fold (function (_ [idx tag] table) - (plist.put tag [idx namespaced_tags exported? type] table)) - tag_bindings - (list.enumeration tags)))) - (update@ #.types (plist.put type_name [namespaced_tags exported? type])))) - state) - []])) - #.None - ((/.throw' unknown_module self_name) state)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux deleted file mode 100644 index dfdb7e314..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/primitive.lux +++ /dev/null @@ -1,32 +0,0 @@ -(.module: - [lux (#- nat int rev) - [abstract - monad]] - ["." // #_ - ["#." type] - ["/#" // #_ - [// - ["/" analysis (#+ Analysis Operation)] - [/// - ["#" phase]]]]]) - -(template [<name> <type> <tag>] - [(def: #export (<name> value) - (-> <type> (Operation Analysis)) - (do ///.monad - [_ (//type.infer <type>)] - (wrap (#/.Primitive (<tag> value)))))] - - [bit .Bit #/.Bit] - [nat .Nat #/.Nat] - [int .Int #/.Int] - [rev .Rev #/.Rev] - [frac .Frac #/.Frac] - [text .Text #/.Text] - ) - -(def: #export unit - (Operation Analysis) - (do ///.monad - [_ (//type.infer .Any)] - (wrap (#/.Primitive #/.Unit)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux deleted file mode 100644 index a3653935f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/reference.lux +++ /dev/null @@ -1,84 +0,0 @@ -(.module: - [lux #* - [abstract - monad] - [control - ["." exception (#+ exception:)]] - ["." meta] - [data - ["." text ("#\." equivalence) - ["%" format (#+ format)]]]] - ["." // #_ - ["#." scope] - ["#." type] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Analysis Operation)] - [/// - ["#." reference] - ["#" phase]]]]]) - -(exception: #export (foreign_module_has_not_been_imported {current Text} {foreign Text}) - (exception.report - ["Current" current] - ["Foreign" foreign])) - -(exception: #export (definition_has_not_been_exported {definition Name}) - (exception.report - ["Definition" (%.name definition)])) - -(def: (definition def_name) - (-> Name (Operation Analysis)) - (with_expansions [<return> (wrap (|> def_name ///reference.constant #/.Reference))] - (do {! ///.monad} - [constant (///extension.lift (meta.find_def def_name))] - (case constant - (#.Left real_def_name) - (definition real_def_name) - - (#.Right [exported? actualT def_anns _]) - (do ! - [_ (//type.infer actualT) - (^@ def_name [::module ::name]) (///extension.lift (meta.normalize def_name)) - current (///extension.lift meta.current_module_name)] - (if (text\= current ::module) - <return> - (if exported? - (do ! - [imported! (///extension.lift (meta.imported_by? ::module current))] - (if imported! - <return> - (/.throw foreign_module_has_not_been_imported [current ::module]))) - (/.throw definition_has_not_been_exported def_name)))))))) - -(def: (variable var_name) - (-> Text (Operation (Maybe Analysis))) - (do {! ///.monad} - [?var (//scope.find var_name)] - (case ?var - (#.Some [actualT ref]) - (do ! - [_ (//type.infer actualT)] - (wrap (#.Some (|> ref ///reference.variable #/.Reference)))) - - #.None - (wrap #.None)))) - -(def: #export (reference reference) - (-> Name (Operation Analysis)) - (case reference - ["" simple_name] - (do {! ///.monad} - [?var (variable simple_name)] - (case ?var - (#.Some varA) - (wrap varA) - - #.None - (do ! - [this_module (///extension.lift meta.current_module_name)] - (definition [this_module simple_name])))) - - _ - (definition reference))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux deleted file mode 100644 index beee6a1b7..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/scope.lux +++ /dev/null @@ -1,205 +0,0 @@ -(.module: - [lux #* - [abstract - monad] - [control - ["." try] - ["." exception (#+ exception:)]] - [data - ["." text ("#\." equivalence)] - ["." maybe ("#\." monad)] - ["." product] - [collection - ["." list ("#\." functor fold monoid)] - [dictionary - ["." plist]]]]] - ["." /// #_ - ["#." extension] - [// - ["/" analysis (#+ Operation Phase)] - [/// - [reference - ["." variable (#+ Register Variable)]] - ["#" phase]]]]) - -(type: Local (Bindings Text [Type Register])) -(type: Foreign (Bindings Text [Type Variable])) - -(def: (local? name scope) - (-> Text Scope Bit) - (|> scope - (get@ [#.locals #.mappings]) - (plist.contains? name))) - -(def: (local name scope) - (-> Text Scope (Maybe [Type Variable])) - (|> scope - (get@ [#.locals #.mappings]) - (plist.get name) - (maybe\map (function (_ [type value]) - [type (#variable.Local value)])))) - -(def: (captured? name scope) - (-> Text Scope Bit) - (|> scope - (get@ [#.captured #.mappings]) - (plist.contains? name))) - -(def: (captured name scope) - (-> Text Scope (Maybe [Type Variable])) - (loop [idx 0 - mappings (get@ [#.captured #.mappings] scope)] - (case mappings - (#.Cons [_name [_source_type _source_ref]] mappings') - (if (text\= name _name) - (#.Some [_source_type (#variable.Foreign idx)]) - (recur (inc idx) mappings')) - - #.Nil - #.None))) - -(def: (reference? name scope) - (-> Text Scope Bit) - (or (local? name scope) - (captured? name scope))) - -(def: (reference name scope) - (-> Text Scope (Maybe [Type Variable])) - (case (..local name scope) - (#.Some type) - (#.Some type) - - _ - (..captured name scope))) - -(def: #export (find name) - (-> Text (Operation (Maybe [Type Variable]))) - (///extension.lift - (function (_ state) - (let [[inner outer] (|> state - (get@ #.scopes) - (list.split_with (|>> (reference? name) not)))] - (case outer - #.Nil - (#.Right [state #.None]) - - (#.Cons top_outer _) - (let [[ref_type init_ref] (maybe.default (undefined) - (..reference name top_outer)) - [ref inner'] (list\fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) - (function (_ scope ref+inner) - [(#variable.Foreign (get@ [#.captured #.counter] scope)) - (#.Cons (update@ #.captured - (: (-> Foreign Foreign) - (|>> (update@ #.counter inc) - (update@ #.mappings (plist.put name [ref_type (product.left ref+inner)])))) - scope) - (product.right ref+inner))])) - [init_ref #.Nil] - (list.reverse inner)) - scopes (list\compose inner' outer)] - (#.Right [(set@ #.scopes scopes state) - (#.Some [ref_type ref])])) - ))))) - -(exception: #export cannot_create_local_binding_without_a_scope) -(exception: #export invalid_scope_alteration) - -(def: #export (with_local [name type] action) - (All [a] (-> [Text Type] (Operation a) (Operation a))) - (function (_ [bundle state]) - (case (get@ #.scopes state) - (#.Cons head tail) - (let [old_mappings (get@ [#.locals #.mappings] head) - new_var_id (get@ [#.locals #.counter] head) - new_head (update@ #.locals - (: (-> Local Local) - (|>> (update@ #.counter inc) - (update@ #.mappings (plist.put name [type new_var_id])))) - head)] - (case (///.run' [bundle (set@ #.scopes (#.Cons new_head tail) state)] - action) - (#try.Success [[bundle' state'] output]) - (case (get@ #.scopes state') - (#.Cons head' tail') - (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') - tail')] - (#try.Success [[bundle' (set@ #.scopes scopes' state')] - output])) - - _ - (exception.throw ..invalid_scope_alteration [])) - - (#try.Failure error) - (#try.Failure error))) - - _ - (exception.throw ..cannot_create_local_binding_without_a_scope [])) - )) - -(template [<name> <val_type>] - [(def: <name> - (Bindings Text [Type <val_type>]) - {#.counter 0 - #.mappings (list)})] - - [init_locals Nat] - [init_captured Variable] - ) - -(def: (scope parent_name child_name) - (-> (List Text) Text Scope) - {#.name (list& child_name parent_name) - #.inner 0 - #.locals init_locals - #.captured init_captured}) - -(def: #export (with_scope name action) - (All [a] (-> Text (Operation a) (Operation a))) - (function (_ [bundle state]) - (let [parent_name (case (get@ #.scopes state) - #.Nil - (list) - - (#.Cons top _) - (get@ #.name top))] - (case (action [bundle (update@ #.scopes - (|>> (#.Cons (scope parent_name name))) - state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (update@ #.scopes - (|>> list.tail (maybe.default (list))) - state')] - output]) - - (#try.Failure error) - (#try.Failure error))) - )) - -(exception: #export cannot_get_next_reference_when_there_is_no_scope) - -(def: #export next_local - (Operation Register) - (///extension.lift - (function (_ state) - (case (get@ #.scopes state) - (#.Cons top _) - (#try.Success [state (get@ [#.locals #.counter] top)]) - - #.Nil - (exception.throw ..cannot_get_next_reference_when_there_is_no_scope []))))) - -(def: (ref_to_variable ref) - (-> Ref Variable) - (case ref - (#.Local register) - (#variable.Local register) - - (#.Captured register) - (#variable.Foreign register))) - -(def: #export (environment scope) - (-> Scope (List Variable)) - (|> scope - (get@ [#.captured #.mappings]) - (list\map (function (_ [_ [_ ref]]) (ref_to_variable ref))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux deleted file mode 100644 index dadc61c2d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/structure.lux +++ /dev/null @@ -1,360 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["ex" exception (#+ exception:)] - ["." state]] - [data - ["." name] - ["." product] - ["." maybe] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]] - [macro - ["." code]] - [math - [number - ["n" nat]]] - ["." type - ["." check]]] - ["." // #_ - ["#." type] - ["#." primitive] - ["#." inference] - ["/#" // #_ - ["#." extension] - [// - ["/" analysis (#+ Tag Analysis Operation Phase)] - [/// - ["#" phase] - [meta - [archive (#+ Archive)]]]]]]) - -(exception: #export (invalid_variant_type {type Type} {tag Tag} {code Code}) - (ex.report ["Type" (%.type type)] - ["Tag" (%.nat tag)] - ["Expression" (%.code code)])) - -(template [<name>] - [(exception: #export (<name> {type Type} {members (List Code)}) - (ex.report ["Type" (%.type type)] - ["Expression" (%.code (` [(~+ members)]))]))] - - [invalid_tuple_type] - [cannot_analyse_tuple] - ) - -(exception: #export (not_a_quantified_type {type Type}) - (%.type type)) - -(template [<name>] - [(exception: #export (<name> {type Type} {tag Tag} {code Code}) - (ex.report ["Type" (%.type type)] - ["Tag" (%.nat tag)] - ["Expression" (%.code code)]))] - - [cannot_analyse_variant] - [cannot_infer_numeric_tag] - ) - -(exception: #export (record_keys_must_be_tags {key Code} {record (List [Code Code])}) - (ex.report ["Key" (%.code key)] - ["Record" (%.code (code.record record))])) - -(template [<name>] - [(exception: #export (<name> {key Name} {record (List [Name Code])}) - (ex.report ["Tag" (%.code (code.tag key))] - ["Record" (%.code (code.record (list\map (function (_ [keyI valC]) - [(code.tag keyI) valC]) - record)))]))] - - [cannot_repeat_tag] - ) - -(exception: #export (tag_does_not_belong_to_record {key Name} {type Type}) - (ex.report ["Tag" (%.code (code.tag key))] - ["Type" (%.type type)])) - -(exception: #export (record_size_mismatch {expected Nat} {actual Nat} {type Type} {record (List [Name Code])}) - (ex.report ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)] - ["Type" (%.type type)] - ["Expression" (%.code (|> record - (list\map (function (_ [keyI valueC]) - [(code.tag keyI) valueC])) - code.record))])) - -(def: #export (sum analyse lefts right? archive) - (-> Phase Nat Bit Phase) - (let [tag (/.tag lefts right?)] - (function (recur valueC) - (do {! ///.monad} - [expectedT (///extension.lift meta.expected_type) - expectedT' (//type.with_env - (check.clean expectedT))] - (/.with_stack ..cannot_analyse_variant [expectedT' tag valueC] - (case expectedT - (#.Sum _) - (let [flat (type.flatten_variant expectedT)] - (case (list.nth tag flat) - (#.Some variant_type) - (do ! - [valueA (//type.with_type variant_type - (analyse archive valueC))] - (wrap (/.variant [lefts right? valueA]))) - - #.None - (/.throw //inference.variant_tag_out_of_bounds [(list.size flat) tag expectedT]))) - - (#.Named name unnamedT) - (//type.with_type unnamedT - (recur valueC)) - - (#.Var id) - (do ! - [?expectedT' (//type.with_env - (check.read id))] - (case ?expectedT' - (#.Some expectedT') - (//type.with_type expectedT' - (recur valueC)) - - ## Cannot do inference when the tag is numeric. - ## This is because there is no way of knowing how many - ## cases the inferred sum type would have. - _ - (/.throw ..cannot_infer_numeric_tag [expectedT tag valueC]))) - - (^template [<tag> <instancer>] - [(<tag> _) - (do ! - [[instance_id instanceT] (//type.with_env <instancer>)] - (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT)) - (recur valueC)))]) - ([#.UnivQ check.existential] - [#.ExQ check.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT_id) - (do ! - [?funT' (//type.with_env (check.read funT_id))] - (case ?funT' - (#.Some funT') - (//type.with_type (#.Apply inputT funT') - (recur valueC)) - - _ - (/.throw ..invalid_variant_type [expectedT tag valueC]))) - - _ - (case (type.apply (list inputT) funT) - (#.Some outputT) - (//type.with_type outputT - (recur valueC)) - - #.None - (/.throw ..not_a_quantified_type funT))) - - _ - (/.throw ..invalid_variant_type [expectedT tag valueC]))))))) - -(def: (typed_product archive analyse members) - (-> Archive Phase (List Code) (Operation Analysis)) - (do {! ///.monad} - [expectedT (///extension.lift meta.expected_type) - membersA+ (: (Operation (List Analysis)) - (loop [membersT+ (type.flatten_tuple expectedT) - membersC+ members] - (case [membersT+ membersC+] - [(#.Cons memberT #.Nil) _] - (//type.with_type memberT - (\ ! map (|>> list) (analyse archive (code.tuple membersC+)))) - - [_ (#.Cons memberC #.Nil)] - (//type.with_type (type.tuple membersT+) - (\ ! map (|>> list) (analyse archive memberC))) - - [(#.Cons memberT membersT+') (#.Cons memberC membersC+')] - (do ! - [memberA (//type.with_type memberT - (analyse archive memberC)) - memberA+ (recur membersT+' membersC+')] - (wrap (#.Cons memberA memberA+))) - - _ - (/.throw ..cannot_analyse_tuple [expectedT members]))))] - (wrap (/.tuple membersA+)))) - -(def: #export (product archive analyse membersC) - (-> Archive Phase (List Code) (Operation Analysis)) - (do {! ///.monad} - [expectedT (///extension.lift meta.expected_type)] - (/.with_stack ..cannot_analyse_tuple [expectedT membersC] - (case expectedT - (#.Product _) - (..typed_product archive analyse membersC) - - (#.Named name unnamedT) - (//type.with_type unnamedT - (product archive analyse membersC)) - - (#.Var id) - (do ! - [?expectedT' (//type.with_env - (check.read id))] - (case ?expectedT' - (#.Some expectedT') - (//type.with_type expectedT' - (product archive analyse membersC)) - - _ - ## Must do inference... - (do ! - [membersTA (monad.map ! (|>> (analyse archive) //type.with_inference) - membersC) - _ (//type.with_env - (check.check expectedT - (type.tuple (list\map product.left membersTA))))] - (wrap (/.tuple (list\map product.right membersTA)))))) - - (^template [<tag> <instancer>] - [(<tag> _) - (do ! - [[instance_id instanceT] (//type.with_env <instancer>)] - (//type.with_type (maybe.assume (type.apply (list instanceT) expectedT)) - (product archive analyse membersC)))]) - ([#.UnivQ check.existential] - [#.ExQ check.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT_id) - (do ! - [?funT' (//type.with_env (check.read funT_id))] - (case ?funT' - (#.Some funT') - (//type.with_type (#.Apply inputT funT') - (product archive analyse membersC)) - - _ - (/.throw ..invalid_tuple_type [expectedT membersC]))) - - _ - (case (type.apply (list inputT) funT) - (#.Some outputT) - (//type.with_type outputT - (product archive analyse membersC)) - - #.None - (/.throw ..not_a_quantified_type funT))) - - _ - (/.throw ..invalid_tuple_type [expectedT membersC]) - )))) - -(def: #export (tagged_sum analyse tag archive valueC) - (-> Phase Name Phase) - (do {! ///.monad} - [tag (///extension.lift (meta.normalize tag)) - [idx group variantT] (///extension.lift (meta.resolve_tag tag)) - #let [case_size (list.size group) - [lefts right?] (/.choice case_size idx)] - expectedT (///extension.lift meta.expected_type)] - (case expectedT - (#.Var _) - (do ! - [inferenceT (//inference.variant idx case_size variantT) - [inferredT valueA+] (//inference.general archive analyse inferenceT (list valueC))] - (wrap (/.variant [lefts right? (|> valueA+ list.head maybe.assume)]))) - - _ - (..sum analyse lefts right? archive valueC)))) - -## There cannot be any ambiguity or improper syntax when analysing -## records, so they must be normalized for further analysis. -## Normalization just means that all the tags get resolved to their -## canonical form (with their corresponding module identified). -(def: #export (normalize record) - (-> (List [Code Code]) (Operation (List [Name Code]))) - (monad.map ///.monad - (function (_ [key val]) - (case key - [_ (#.Tag key)] - (do ///.monad - [key (///extension.lift (meta.normalize key))] - (wrap [key val])) - - _ - (/.throw ..record_keys_must_be_tags [key record]))) - record)) - -## Lux already possesses the means to analyse tuples, so -## re-implementing the same functionality for records makes no sense. -## Records, thus, get transformed into tuples by ordering the elements. -(def: #export (order record) - (-> (List [Name Code]) (Operation [(List Code) Type])) - (case record - ## empty_record = empty_tuple = unit = [] - #.Nil - (\ ///.monad wrap [(list) Any]) - - (#.Cons [head_k head_v] _) - (do {! ///.monad} - [head_k (///extension.lift (meta.normalize head_k)) - [_ tag_set recordT] (///extension.lift (meta.resolve_tag head_k)) - #let [size_record (list.size record) - size_ts (list.size tag_set)] - _ (if (n.= size_ts size_record) - (wrap []) - (/.throw ..record_size_mismatch [size_ts size_record recordT record])) - #let [tuple_range (list.indices size_ts) - tag->idx (dictionary.from_list name.hash (list.zip/2 tag_set tuple_range))] - idx->val (monad.fold ! - (function (_ [key val] idx->val) - (do ! - [key (///extension.lift (meta.normalize key))] - (case (dictionary.get key tag->idx) - (#.Some idx) - (if (dictionary.key? idx->val idx) - (/.throw ..cannot_repeat_tag [key record]) - (wrap (dictionary.put idx val idx->val))) - - #.None - (/.throw ..tag_does_not_belong_to_record [key recordT])))) - (: (Dictionary Nat Code) - (dictionary.new n.hash)) - record) - #let [ordered_tuple (list\map (function (_ idx) (maybe.assume (dictionary.get idx idx->val))) - tuple_range)]] - (wrap [ordered_tuple recordT])) - )) - -(def: #export (record archive analyse members) - (-> Archive Phase (List [Code Code]) (Operation Analysis)) - (case members - (^ (list)) - //primitive.unit - - (^ (list [_ singletonC])) - (analyse archive singletonC) - - _ - (do {! ///.monad} - [members (normalize members) - [membersC recordT] (order members) - expectedT (///extension.lift meta.expected_type)] - (case expectedT - (#.Var _) - (do ! - [inferenceT (//inference.record recordT) - [inferredT membersA] (//inference.general archive analyse inferenceT membersC)] - (wrap (/.tuple membersA))) - - _ - (..product archive analyse membersC))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux deleted file mode 100644 index f72ec593b..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/type.lux +++ /dev/null @@ -1,55 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." function] - ["." try]] - [type - ["." check (#+ Check)]] - ["." meta]] - ["." /// #_ - ["#." extension] - [// - ["/" analysis (#+ Operation)] - [/// - ["#" phase]]]]) - -(def: #export (with_type expected) - (All [a] (-> Type (Operation a) (Operation a))) - (///extension.localized (get@ #.expected) (set@ #.expected) - (function.constant (#.Some expected)))) - -(def: #export (with_env action) - (All [a] (-> (Check a) (Operation a))) - (function (_ (^@ stateE [bundle state])) - (case (action (get@ #.type_context state)) - (#try.Success [context' output]) - (#try.Success [[bundle (set@ #.type_context context' state)] - output]) - - (#try.Failure error) - ((/.fail error) stateE)))) - -(def: #export with_fresh_env - (All [a] (-> (Operation a) (Operation a))) - (///extension.localized (get@ #.type_context) (set@ #.type_context) - (function.constant check.fresh_context))) - -(def: #export (infer actualT) - (-> Type (Operation Any)) - (do ///.monad - [expectedT (///extension.lift meta.expected_type)] - (with_env - (check.check expectedT actualT)))) - -(def: #export (with_inference action) - (All [a] (-> (Operation a) (Operation [Type a]))) - (do ///.monad - [[_ varT] (..with_env - check.var) - output (with_type varT - action) - knownT (..with_env - (check.clean varT))] - (wrap [knownT output]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux deleted file mode 100644 index 088bed17a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/directive.lux +++ /dev/null @@ -1,78 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [data - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold monoid)]]] - ["." meta]] - ["." // #_ - ["#." extension] - ["#." analysis - ["#/." type]] - ["/#" // #_ - ["/" directive (#+ Phase)] - ["#." analysis - ["#/." macro (#+ Expander)]] - [/// - ["//" phase] - [reference (#+) - [variable (#+)]]]]]) - -(exception: #export (not_a_directive {code Code}) - (exception.report - ["Directive" (%.code code)])) - -(exception: #export (invalid_macro_call {code Code}) - (exception.report - ["Code" (%.code code)])) - -(exception: #export (macro_was_not_found {name Name}) - (exception.report - ["Name" (%.name name)])) - -(with_expansions [<lux_def_module> (as_is [|form_location| (#.Form (list& [|text_location| (#.Text "lux def module")] annotations))])] - (def: #export (phase expander) - (-> Expander Phase) - (let [analyze (//analysis.phase expander)] - (function (recur archive code) - (case code - (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) - (//extension.apply archive recur [name inputs]) - - (^ [_ (#.Form (list& macro inputs))]) - (do {! //.monad} - [expansion (/.lift_analysis - (do ! - [macroA (//analysis/type.with_type Macro - (analyze archive macro))] - (case macroA - (^ (///analysis.constant macro_name)) - (do ! - [?macro (//extension.lift (meta.find_macro macro_name)) - macro (case ?macro - (#.Some macro) - (wrap macro) - - #.None - (//.throw ..macro_was_not_found macro_name))] - (//extension.lift (///analysis/macro.expand expander macro_name macro inputs))) - - _ - (//.throw ..invalid_macro_call code))))] - (case expansion - (^ (list& <lux_def_module> referrals)) - (|> (recur archive <lux_def_module>) - (\ ! map (update@ #/.referrals (list\compose referrals)))) - - _ - (|> expansion - (monad.map ! (recur archive)) - (\ ! map (list\fold /.merge_requirements /.no_requirements))))) - - _ - (//.throw ..not_a_directive code)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux deleted file mode 100644 index 7004b8d1a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension.lux +++ /dev/null @@ -1,176 +0,0 @@ -(.module: - [lux (#- Name) - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - ["." monad (#+ do)]] - [control - ["." function] - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." text ("#\." order) - ["%" format (#+ Format format)]] - [collection - ["." list] - ["." dictionary (#+ Dictionary)]]]] - [///// - ["//" phase] - [meta - [archive (#+ Archive)]]]) - -(type: #export Name - Text) - -(type: #export (Extension a) - [Name (List a)]) - -(def: #export equivalence - (All [a] (-> (Equivalence a) (Equivalence (Extension a)))) - (|>> list.equivalence - (product.equivalence text.equivalence))) - -(def: #export hash - (All [a] (-> (Hash a) (Hash (Extension a)))) - (|>> list.hash - (product.hash text.hash))) - -(with_expansions [<Bundle> (as_is (Dictionary Name (Handler s i o)))] - (type: #export (Handler s i o) - (-> Name - (//.Phase [<Bundle> s] i o) - (//.Phase [<Bundle> s] (List i) o))) - - (type: #export (Bundle s i o) - <Bundle>)) - -(def: #export empty - Bundle - (dictionary.new text.hash)) - -(type: #export (State s i o) - {#bundle (Bundle s i o) - #state s}) - -(type: #export (Operation s i o v) - (//.Operation (State s i o) v)) - -(type: #export (Phase s i o) - (//.Phase (State s i o) i o)) - -(exception: #export (cannot_overwrite {name Name}) - (exception.report - ["Extension" (%.text name)])) - -(exception: #export (incorrect_arity {name Name} {arity Nat} {args Nat}) - (exception.report - ["Extension" (%.text name)] - ["Expected" (%.nat arity)] - ["Actual" (%.nat args)])) - -(exception: #export [a] (invalid_syntax {name Name} {%format (Format a)} {inputs (List a)}) - (exception.report - ["Extension" (%.text name)] - ["Inputs" (exception.enumerate %format inputs)])) - -(exception: #export [s i o] (unknown {name Name} {bundle (Bundle s i o)}) - (exception.report - ["Extension" (%.text name)] - ["Available" (|> bundle - dictionary.keys - (list.sort text\<) - (exception.enumerate %.text))])) - -(type: #export (Extender s i o) - (-> Any (Handler s i o))) - -(def: #export (install extender name handler) - (All [s i o] - (-> (Extender s i o) Text (Handler s i o) (Operation s i o Any))) - (function (_ [bundle state]) - (case (dictionary.get name bundle) - #.None - (#try.Success [[(dictionary.put name (extender handler) bundle) state] - []]) - - _ - (exception.throw ..cannot_overwrite name)))) - -(def: #export (with extender extensions) - (All [s i o] - (-> Extender (Bundle s i o) (Operation s i o Any))) - (|> extensions - dictionary.entries - (monad.fold //.monad - (function (_ [extension handle] output) - (..install extender extension handle)) - []))) - -(def: #export (apply archive phase [name parameters]) - (All [s i o] - (-> Archive (Phase s i o) (Extension i) (Operation s i o o))) - (function (_ (^@ stateE [bundle state])) - (case (dictionary.get name bundle) - (#.Some handler) - (((handler name phase) archive parameters) - stateE) - - #.None - (exception.throw ..unknown [name bundle])))) - -(def: #export (localized get set transform) - (All [s s' i o v] - (-> (-> s s') (-> s' s s) (-> s' s') - (-> (Operation s i o v) (Operation s i o v)))) - (function (_ operation) - (function (_ [bundle state]) - (let [old (get state)] - (case (operation [bundle (set (transform old) state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' (set old state')] output]) - - (#try.Failure error) - (#try.Failure error)))))) - -(def: #export (temporary transform) - (All [s i o v] - (-> (-> s s) - (-> (Operation s i o v) (Operation s i o v)))) - (function (_ operation) - (function (_ [bundle state]) - (case (operation [bundle (transform state)]) - (#try.Success [[bundle' state'] output]) - (#try.Success [[bundle' state] output]) - - (#try.Failure error) - (#try.Failure error))))) - -(def: #export (with_state state) - (All [s i o v] - (-> s (-> (Operation s i o v) (Operation s i o v)))) - (..temporary (function.constant state))) - -(def: #export (read get) - (All [s i o v] - (-> (-> s v) (Operation s i o v))) - (function (_ [bundle state]) - (#try.Success [[bundle state] (get state)]))) - -(def: #export (update transform) - (All [s i o] - (-> (-> s s) (Operation s i o Any))) - (function (_ [bundle state]) - (#try.Success [[bundle (transform state)] []]))) - -(def: #export (lift action) - (All [s i o v] - (-> (//.Operation s v) - (//.Operation [(Bundle s i o) s] v))) - (function (_ [bundle state]) - (case (action state) - (#try.Success [state' output]) - (#try.Success [[bundle state'] output]) - - (#try.Failure error) - (#try.Failure error)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux deleted file mode 100644 index 0f38bce97..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [//// - [analysis (#+ Bundle) - [evaluation (#+ Eval)]]] - ["." / #_ - ["#." lux]]) - -(def: #export (bundle eval host-specific) - (-> Eval Bundle Bundle) - (dictionary.merge host-specific - (/lux.bundle eval))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux deleted file mode 100644 index 887d639f1..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux +++ /dev/null @@ -1,34 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" common_lisp]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: #export bundle - Bundle - (<| (bundle.prefix "common_lisp") - (|> bundle.empty - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux deleted file mode 100644 index d36dcd1ef..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux +++ /dev/null @@ -1,217 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" js]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<c>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<c>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <c>.any <c>.any <c>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#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 - [($_ <>.and <c>.any (<c>.tuple (<>.some <c>.any))) - (function (_ extension phase archive [constructorC inputsC]) - (do {! phase.monad} - [constructorA (analysis/type.with_type Any - (phase archive constructorC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& constructorA inputsA)))))])) - -(def: object::get - Handler - (custom - [($_ <>.and <c>.text <c>.any) - (function (_ extension phase archive [fieldC objectC]) - (do phase.monad - [objectA (analysis/type.with_type Any - (phase archive objectC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <c>.text <c>.any (<c>.tuple (<>.some <c>.any))) - (function (_ extension phase archive [methodC objectC inputsC]) - (do {! phase.monad} - [objectA (analysis/type.with_type Any - (phase archive objectC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (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 - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: js::apply - Handler - (custom - [($_ <>.and <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type Any - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: js::type_of - Handler - (custom - [<c>.any - (function (_ extension phase archive objectC) - (do phase.monad - [objectA (analysis/type.with_type Any - (phase archive objectC)) - _ (analysis/type.infer .Text)] - (wrap (#analysis.Extension extension (list objectA)))))])) - -(def: js::function - Handler - (custom - [($_ <>.and <c>.nat <c>.any) - (function (_ extension phase archive [arity abstractionC]) - (do phase.monad - [#let [inputT (type.tuple (list.repeat arity Any))] - abstractionA (analysis/type.with_type (-> inputT Any) - (phase archive abstractionC)) - _ (analysis/type.infer (for {@.js ffi.Function} - Any))] - (wrap (#analysis.Extension extension (list (analysis.nat arity) - abstractionA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "js") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge 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/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux deleted file mode 100644 index 0d67b2224..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux +++ /dev/null @@ -1,2075 +0,0 @@ -(.module: - [lux (#- Type Module primitive type char int) - ["." ffi (#+ import:)] - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - pipe - ["." try (#+ Try) ("#\." monad)] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" code (#+ Parser)] - ["<.>" text]]] - [data - ["." maybe] - ["." product] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." fold monad monoid)] - ["." array] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["n" nat]]] - [target - ["." jvm #_ - [".!" reflection] - [encoding - [name (#+ External)]] - ["#" type (#+ Type Argument Typed) ("#\." equivalence) - ["." category (#+ Void Value' Value Return' Return Primitive Object Class Array Var Parameter Method)] - ["." box] - ["." reflection] - ["." descriptor] - ["." signature] - ["#_." parser] - ["#_." alias (#+ Aliasing)] - [".T" lux (#+ Mapping)]]]] - ["." type - ["." check (#+ Check) ("#\." monad)]]] - ["." // #_ - ["#." lux (#+ custom)] - ["/#" // - ["#." bundle] - ["/#" // #_ - [analysis - [".A" type] - [".A" inference] - ["." scope]] - ["/#" // #_ - ["#." analysis (#+ Analysis Operation Phase Handler Bundle)] - ["#." synthesis] - [/// - ["." phase ("#\." monad)] - [meta - [archive (#+ Archive) - [descriptor (#+ Module)]]]]]]]]) - -(import: java/lang/Object - ["#::." - (equals [java/lang/Object] boolean)]) - -(import: java/lang/reflect/Type) - -(import: (java/lang/reflect/TypeVariable d) - ["#::." - (getName [] java/lang/String) - (getBounds [] [java/lang/reflect/Type])]) - -(import: java/lang/reflect/Modifier - ["#::." - (#static isStatic [int] boolean) - (#static isFinal [int] boolean) - (#static isInterface [int] boolean) - (#static isAbstract [int] boolean)]) - -(import: java/lang/annotation/Annotation) - -(import: java/lang/reflect/Method - ["#::." - (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]) - (getGenericReturnType [] java/lang/reflect/Type) - (getGenericExceptionTypes [] [java/lang/reflect/Type]) - (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) - -(import: (java/lang/reflect/Constructor c) - ["#::." - (getModifiers [] int) - (getDeclaringClass [] (java/lang/Class c)) - (getTypeParameters [] [(java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))]) - (getGenericParameterTypes [] [java/lang/reflect/Type]) - (getGenericExceptionTypes [] [java/lang/reflect/Type]) - (getDeclaredAnnotations [] [java/lang/annotation/Annotation])]) - -(import: (java/lang/Class c) - ["#::." - (#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])]) - -(template [<name>] - [(exception: #export (<name> {class External} {field Text}) - (exception.report - ["Class" (%.text class)] - ["Field" (%.text field)]))] - - [cannot_set_a_final_field] - [deprecated_field] - ) - -(exception: #export (deprecated_method {class External} {method Text} {type .Type}) - (exception.report - ["Class" (%.text class)] - ["Method" (%.text method)] - ["Type" (%.type type)])) - -(exception: #export (deprecated_class {class External}) - (exception.report - ["Class" (%.text class)])) - -(def: (ensure_fresh_class! name) - (-> External (Operation Any)) - (do phase.monad - [class (phase.lift (reflection!.load name))] - (phase.assert ..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") - -(def: inheritance_relationship_type_name "_jvm_inheritance") -(def: #export (inheritance_relationship_type class super_class super_interfaces) - (-> .Type .Type (List .Type) .Type) - (#.Primitive ..inheritance_relationship_type_name - (list& class super_class super_interfaces))) - -## TODO: Get rid of this template block and use the definition in -## lux/ffi.jvm.lux ASAP -(template [<name> <class>] - [(def: #export <name> .Type (#.Primitive <class> #.Nil))] - - ## 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 - {#class External - #member Text}) - -(def: member - (Parser Member) - ($_ <>.and <code>.text <code>.text)) - -(type: Method_Signature - {#method .Type - #deprecated? Bit - #exceptions (List .Type)}) - -(template [<name>] - [(exception: #export (<name> {type .Type}) - (exception.report - ["Type" (%.type type)]))] - - [non_object] - [non_array] - [non_parameter] - [non_jvm_type] - ) - -(template [<name>] - [(exception: #export (<name> {class External}) - (exception.report - ["Class/type" (%.text class)]))] - - [non_interface] - [non_throwable] - [primitives_are_not_objects] - ) - -(template [<name>] - [(exception: #export (<name> {class External} - {method Text} - {inputsJT (List (Type Value))} - {hints (List Method_Signature)}) - (exception.report - ["Class" class] - ["Method" method] - ["Arguments" (exception.enumerate ..signature inputsJT)] - ["Hints" (exception.enumerate %.type (list\map product.left hints))]))] - - [no_candidates] - [too_many_candidates] - ) - -(exception: #export (cannot_cast {from .Type} {to .Type} {value Code}) - (exception.report - ["From" (%.type from)] - ["To" (%.type to)] - ["Value" (%.code value)])) - -(template [<name>] - [(exception: #export (<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)) - ))) - -(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] - ) - -(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: #export 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.from_list text.hash))) - -(def: (jvm_type luxT) - (-> .Type (Operation (Type Value))) - (case luxT - (#.Named name anonymousT) - (jvm_type anonymousT) - - (#.Apply inputT abstractionT) - (case (type.apply (list inputT) abstractionT) - (#.Some outputT) - (jvm_type outputT) - - #.None - (/////analysis.throw ..non_jvm_type luxT)) - - (^ (#.Primitive (static array.type_name) (list elemT))) - (phase\map jvm.array (jvm_type elemT)) - - (#.Primitive class parametersT) - (case (dictionary.get class ..boxes) - (#.Some [_ primitive_type]) - (case parametersT - #.Nil - (phase\wrap primitive_type) - - _ - (/////analysis.throw ..primitives_cannot_have_type_parameters class)) - - #.None - (do {! phase.monad} - [parametersJT (: (Operation (List (Type Parameter))) - (monad.map ! - (function (_ parameterT) - (do phase.monad - [parameterJT (jvm_type parameterT)] - (case (jvm_parser.parameter? parameterJT) - (#.Some parameterJT) - (wrap parameterJT) - - #.None - (/////analysis.throw ..non_parameter parameterT)))) - parametersT))] - (wrap (jvm.class class parametersJT)))) - - (#.Ex _) - (phase\wrap (jvm.class ..object_class (list))) - - _ - (/////analysis.throw ..non_jvm_type luxT))) - -(def: (jvm_array_type objectT) - (-> .Type (Operation (Type Array))) - (do phase.monad - [objectJ (jvm_type objectT)] - (|> objectJ - ..signature - (<text>.run jvm_parser.array) - phase.lift))) - -(def: (primitive_array_length_handler primitive_type) - (-> (Type Primitive) Handler) - (function (_ extension_name analyse archive args) - (case args - (^ (list arrayC)) - (do phase.monad - [_ (typeA.infer ..int) - arrayA (typeA.with_type (#.Primitive (|> (jvm.array primitive_type) - ..reflection) - (list)) - (analyse archive arrayC))] - (wrap (#/////analysis.Extension extension_name (list arrayA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: array::length::object - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list arrayC)) - (do phase.monad - [_ (typeA.infer ..int) - [var_id varT] (typeA.with_env check.var) - arrayA (typeA.with_type (.type (array.Array varT)) - (analyse archive arrayC)) - varT (typeA.with_env (check.clean varT)) - arrayJT (jvm_array_type (.type (array.Array varT)))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT)) - arrayA)))) - - _ - (/////analysis.throw ///.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.with_type ..int - (analyse archive lengthC)) - _ (typeA.infer (#.Primitive (|> (jvm.array primitive_type) ..reflection) - (list)))] - (wrap (#/////analysis.Extension extension_name (list lengthA)))) - - _ - (/////analysis.throw ///.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.with_type ..int - (analyse archive lengthC)) - expectedT (///.lift meta.expected_type) - expectedJT (jvm_array_type expectedT) - elementJT (case (jvm_parser.array? expectedJT) - (#.Some elementJT) - (wrap elementJT) - - #.None - (/////analysis.throw ..non_array expectedT))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature elementJT)) - lengthA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: (check_parameter objectT) - (-> .Type (Operation (Type Parameter))) - (case objectT - (^ (#.Primitive (static array.type_name) - (list elementT))) - (/////analysis.throw ..non_parameter objectT) - - (#.Primitive name parameters) - (`` (cond (or (~~ (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.throw ..non_parameter objectT) - - ## else - (phase\wrap (jvm.class name (list))))) - - (#.Named name anonymous) - (check_parameter anonymous) - - (^template [<tag>] - [(<tag> id) - (phase\wrap (jvm.class ..object_class (list)))]) - ([#.Var] - [#.Ex]) - - (^template [<tag>] - [(<tag> env unquantified) - (check_parameter unquantified)]) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT abstractionT) - (case (type.apply (list inputT) abstractionT) - (#.Some outputT) - (check_parameter outputT) - - #.None - (/////analysis.throw ..non_parameter objectT)) - - _ - (/////analysis.throw ..non_parameter objectT))) - -(def: (check_jvm objectT) - (-> .Type (Operation (Type Value))) - (case objectT - (#.Primitive name #.Nil) - (`` (cond (~~ (template [<type>] - [(text\= (..reflection <type>) name) - (phase\wrap <type>)] - - [jvm.boolean] - [jvm.byte] - [jvm.short] - [jvm.int] - [jvm.long] - [jvm.float] - [jvm.double] - [jvm.char])) - - (~~ (template [<type>] - [(text\= (..reflection (jvm.array <type>)) name) - (phase\wrap (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.assume (text.split_with descriptor.array_prefix name))] - (\ phase.monad map jvm.array - (check_jvm (#.Primitive unprefixed (list))))) - - ## else - (phase\wrap (jvm.class name (list))))) - - (^ (#.Primitive (static array.type_name) - (list elementT))) - (|> elementT - check_jvm - (phase\map jvm.array)) - - (#.Primitive name parameters) - (do {! phase.monad} - [parameters (monad.map ! check_parameter parameters)] - (phase\wrap (jvm.class name parameters))) - - (#.Named name anonymous) - (check_jvm anonymous) - - (^template [<tag>] - [(<tag> env unquantified) - (check_jvm unquantified)]) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT abstractionT) - (case (type.apply (list inputT) abstractionT) - (#.Some outputT) - (check_jvm outputT) - - #.None - (/////analysis.throw ..non_object objectT)) - - _ - (check_parameter objectT))) - -(def: (check_object objectT) - (-> .Type (Operation External)) - (do {! phase.monad} - [name (\ ! map ..reflection (check_jvm objectT))] - (if (dictionary.key? ..boxes name) - (/////analysis.throw ..primitives_are_not_objects [name]) - (phase\wrap name)))) - -(def: (check_return type) - (-> .Type (Operation (Type Return))) - (if (is? .Any type) - (phase\wrap 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.infer lux_type) - idxA (typeA.with_type ..int - (analyse archive idxC)) - arrayA (typeA.with_type (#.Primitive (|> (jvm.array jvm_type) ..reflection) - (list)) - (analyse archive arrayC))] - (wrap (#/////analysis.Extension extension_name (list idxA arrayA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) - -(def: array::read::object - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list idxC arrayC)) - (do phase.monad - [[var_id varT] (typeA.with_env check.var) - _ (typeA.infer varT) - arrayA (typeA.with_type (.type (array.Array varT)) - (analyse archive arrayC)) - varT (typeA.with_env - (check.clean varT)) - arrayJT (jvm_array_type (.type (array.Array varT))) - idxA (typeA.with_type ..int - (analyse archive idxC))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT)) - idxA - arrayA)))) - - _ - (/////analysis.throw ///.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.infer array_type) - idxA (typeA.with_type ..int - (analyse archive idxC)) - valueA (typeA.with_type lux_type - (analyse archive valueC)) - arrayA (typeA.with_type array_type - (analyse archive arrayC))] - (wrap (#/////analysis.Extension extension_name (list idxA - valueA - arrayA)))) - - _ - (/////analysis.throw ///.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)) - (do phase.monad - [[var_id varT] (typeA.with_env check.var) - _ (typeA.infer (.type (array.Array varT))) - arrayA (typeA.with_type (.type (array.Array varT)) - (analyse archive arrayC)) - varT (typeA.with_env - (check.clean varT)) - arrayJT (jvm_array_type (.type (array.Array varT))) - idxA (typeA.with_type ..int - (analyse archive idxC)) - valueA (typeA.with_type varT - (analyse archive valueC))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text (..signature arrayJT)) - idxA - valueA - arrayA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 3 (list.size args)])))) - -(def: bundle::array - Bundle - (<| (///bundle.prefix "array") - (|> ///bundle.empty - (dictionary.merge (<| (///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.merge (<| (///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.merge (<| (///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.merge (<| (///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 (///.lift meta.expected_type) - _ (check_object expectedT)] - (wrap (#/////analysis.Extension extension_name (list)))) - - _ - (/////analysis.throw ///.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.infer Bit) - [objectT objectA] (typeA.with_inference - (analyse archive objectC)) - _ (check_object objectT)] - (wrap (#/////analysis.Extension extension_name (list objectA)))) - - _ - (/////analysis.throw ///.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.with_inference - (analyse archive monitorC)) - _ (check_object monitorT) - exprA (analyse archive exprC)] - (wrap (#/////analysis.Extension extension_name (list monitorA exprA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 2 (list.size args)])))) - -(def: object::throw - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list exceptionC)) - (do phase.monad - [_ (typeA.infer Nothing) - [exceptionT exceptionA] (typeA.with_inference - (analyse archive exceptionC)) - exception_class (check_object exceptionT) - ? (phase.lift (reflection!.sub? "java.lang.Throwable" exception_class)) - _ (: (Operation Any) - (if ? - (wrap []) - (/////analysis.throw non_throwable exception_class)))] - (wrap (#/////analysis.Extension extension_name (list exceptionA)))) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: object::class - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list classC)) - (case classC - [_ (#.Text class)] - (do phase.monad - [_ (..ensure_fresh_class! class) - _ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) - _ (phase.lift (reflection!.load class))] - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text class))))) - - _ - (/////analysis.throw ///.invalid_syntax [extension_name %.code args])) - - _ - (/////analysis.throw ///.incorrect_arity [extension_name 1 (list.size args)])))) - -(def: object::instance? - Handler - (..custom - [($_ <>.and <code>.text <code>.any) - (function (_ extension_name analyse archive [sub_class objectC]) - (do phase.monad - [_ (..ensure_fresh_class! sub_class) - _ (typeA.infer Bit) - [objectT objectA] (typeA.with_inference - (analyse archive objectC)) - object_class (check_object objectT) - ? (phase.lift (reflection!.sub? object_class sub_class))] - (if ? - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text sub_class) objectA))) - (/////analysis.throw cannot_possibly_be_an_instance (format sub_class " !<= " object_class)))))])) - -(template [<name> <category> <parser>] - [(def: (<name> mapping typeJ) - (-> Mapping (Type <category>) (Operation .Type)) - (case (|> typeJ ..signature (<text>.run (<parser> mapping))) - (#try.Success check) - (typeA.with_env - check) - - (#try.Failure error) - (phase.fail error)))] - - [reflection_type Value luxT.type] - [reflection_return Return luxT.return] - ) - -(def: (class_candidate_parents from_name fromT to_name to_class) - (-> External .Type External (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit]))) - (do {! phase.monad} - [from_class (phase.lift (reflection!.load from_name)) - mapping (phase.lift (reflection!.correspond from_class fromT))] - (monad.map ! - (function (_ superJT) - (do ! - [superJT (phase.lift (reflection!.type superJT)) - #let [super_name (|> superJT ..reflection)] - super_class (phase.lift (reflection!.load super_name)) - superT (reflection_type mapping superJT)] - (wrap [[super_name superT] (java/lang/Class::isAssignableFrom super_class to_class)]))) - (case (java/lang/Class::getGenericSuperclass from_class) - (#.Some super) - (list& super (array.to_list (java/lang/Class::getGenericInterfaces from_class))) - - #.None - (if (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers from_class)) - (#.Cons (:as java/lang/reflect/Type (ffi.class_for java/lang/Object)) - (array.to_list (java/lang/Class::getGenericInterfaces from_class))) - (array.to_list (java/lang/Class::getGenericInterfaces from_class))))))) - -(def: (inheritance_candidate_parents fromT to_class toT fromC) - (-> .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit]))) - (case fromT - (^ (#.Primitive _ (list& self_classT super_classT super_interfacesT+))) - (monad.map phase.monad - (function (_ superT) - (do {! phase.monad} - [super_name (\ ! map ..reflection (check_jvm superT)) - super_class (phase.lift (reflection!.load super_name))] - (wrap [[super_name superT] - (java/lang/Class::isAssignableFrom super_class to_class)]))) - (list& super_classT super_interfacesT+)) - - _ - (/////analysis.throw ..cannot_cast [fromT toT fromC]))) - -(def: object::cast - Handler - (function (_ extension_name analyse archive args) - (case args - (^ (list fromC)) - (do {! phase.monad} - [toT (///.lift meta.expected_type) - to_name (\ ! map ..reflection (check_jvm toT)) - [fromT fromA] (typeA.with_inference - (analyse archive fromC)) - from_name (\ ! map ..reflection (check_jvm fromT)) - can_cast? (: (Operation Bit) - (`` (cond (~~ (template [<primitive> <object>] - [(let [=primitive (reflection.reflection <primitive>)] - (or (and (text\= =primitive from_name) - (or (text\= <object> to_name) - (text\= =primitive to_name))) - (and (text\= <object> from_name) - (text\= =primitive to_name)))) - (wrap 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.assert ..primitives_are_not_objects [from_name] - (not (dictionary.key? ..boxes from_name))) - _ (phase.assert ..primitives_are_not_objects [to_name] - (not (dictionary.key? ..boxes to_name))) - to_class (phase.lift (reflection!.load to_name)) - _ (if (text\= ..inheritance_relationship_type_name from_name) - (wrap []) - (do ! - [from_class (phase.lift (reflection!.load from_name))] - (phase.assert ..cannot_cast [fromT toT fromC] - (java/lang/Class::isAssignableFrom from_class to_class))))] - (loop [[current_name currentT] [from_name fromT]] - (if (text\= to_name current_name) - (wrap true) - (do ! - [candidate_parents (: (Operation (List [[Text .Type] Bit])) - (if (text\= ..inheritance_relationship_type_name current_name) - (inheritance_candidate_parents currentT to_class toT fromC) - (class_candidate_parents current_name currentT to_name to_class)))] - (case (|> candidate_parents - (list.filter product.right) - (list\map product.left)) - (#.Cons [next_name nextT] _) - (recur [next_name nextT]) - - #.Nil - (wrap false)))))))))] - (if can_cast? - (wrap (#/////analysis.Extension extension_name (list (/////analysis.text from_name) - (/////analysis.text to_name) - fromA))) - (/////analysis.throw ..cannot_cast [fromT toT fromC]))) - - _ - (/////analysis.throw ///.invalid_syntax [extension_name %.code args])))) - -(def: bundle::object - Bundle - (<| (///bundle.prefix "object") - (|> ///bundle.empty - (///bundle.install "null" object::null) - (///bundle.install "null?" object::null?) - (///bundle.install "synchronized" object::synchronized) - (///bundle.install "throw" object::throw) - (///bundle.install "class" object::class) - (///bundle.install "instance?" object::instance?) - (///bundle.install "cast" object::cast) - ))) - -(def: get::static - Handler - (..custom - [..member - (function (_ extension_name analyse archive [class field]) - (do phase.monad - [_ (..ensure_fresh_class! class) - [final? deprecated? fieldJT] (phase.lift - (do try.monad - [class (reflection!.load class)] - (reflection!.static_field field class))) - _ (phase.assert ..deprecated_field [class field] - (not deprecated?)) - fieldT (reflection_type luxT.fresh fieldJT) - _ (typeA.infer fieldT)] - (wrap (<| (#/////analysis.Extension extension_name) - (list (/////analysis.text class) - (/////analysis.text field) - (/////analysis.text (|> fieldJT ..reflection)))))))])) - -(def: put::static - Handler - (..custom - [($_ <>.and ..member <code>.any) - (function (_ extension_name analyse archive [[class field] valueC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - _ (typeA.infer Any) - [final? deprecated? fieldJT] (phase.lift - (do try.monad - [class (reflection!.load class)] - (reflection!.static_field field class))) - _ (phase.assert ..deprecated_field [class field] - (not deprecated?)) - _ (phase.assert ..cannot_set_a_final_field [class field] - (not final?)) - fieldT (reflection_type luxT.fresh fieldJT) - valueA (typeA.with_type fieldT - (analyse archive valueC))] - (wrap (<| (#/////analysis.Extension extension_name) - (list (/////analysis.text class) - (/////analysis.text field) - valueA)))))])) - -(def: get::virtual - Handler - (..custom - [($_ <>.and ..member <code>.any) - (function (_ extension_name analyse archive [[class field] objectC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - [objectT objectA] (typeA.with_inference - (analyse archive objectC)) - [deprecated? mapping fieldJT] (phase.lift - (do try.monad - [class (reflection!.load class) - [final? deprecated? fieldJT] (reflection!.virtual_field field class) - mapping (reflection!.correspond class objectT)] - (wrap [deprecated? mapping fieldJT]))) - _ (phase.assert ..deprecated_field [class field] - (not deprecated?)) - fieldT (reflection_type mapping fieldJT) - _ (typeA.infer fieldT)] - (wrap (<| (#/////analysis.Extension extension_name) - (list (/////analysis.text class) - (/////analysis.text field) - objectA)))))])) - -(def: put::virtual - Handler - (..custom - [($_ <>.and ..member <code>.any <code>.any) - (function (_ extension_name analyse archive [[class field] valueC objectC]) - (do phase.monad - [_ (..ensure_fresh_class! class) - [objectT objectA] (typeA.with_inference - (analyse archive objectC)) - _ (typeA.infer objectT) - [final? deprecated? mapping fieldJT] (phase.lift - (do try.monad - [class (reflection!.load class) - [final? deprecated? fieldJT] (reflection!.virtual_field field class) - mapping (reflection!.correspond class objectT)] - (wrap [final? deprecated? mapping fieldJT]))) - _ (phase.assert ..deprecated_field [class field] - (not deprecated?)) - _ (phase.assert ..cannot_set_a_final_field [class field] - (not final?)) - fieldT (reflection_type mapping fieldJT) - valueA (typeA.with_type fieldT - (analyse archive valueC))] - (wrap (<| (#/////analysis.Extension extension_name) - (list (/////analysis.text class) - (/////analysis.text field) - valueA - objectA)))))])) - -(type: Method_Style - #Static - #Abstract - #Virtual - #Special - #Interface) - -(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.to_list - (monad.map try.monad reflection!.type) - phase.lift) - #let [modifiers (java/lang/reflect/Method::getModifiers method) - correct_class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method)) - correct_method? (text\= method_name (java/lang/reflect/Method::getName method)) - static_matches? (case method_style - #Static - (java/lang/reflect/Modifier::isStatic modifiers) - - _ - true) - special_matches? (case method_style - #Special - (not (or (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class)) - (java/lang/reflect/Modifier::isAbstract modifiers))) - - _ - true) - arity_matches? (n.= (list.size inputsJT) (list.size parameters)) - inputs_match? (and arity_matches? - (list\fold (function (_ [expectedJC actualJC] prev) - (and prev - (jvm\= expectedJC (: (Type Value) - (case (jvm_parser.var? actualJC) - (#.Some name) - (|> aliasing - (dictionary.get name) - (maybe.default name) - jvm.var) - - #.None - actualJC))))) - true - (list.zip/2 parameters inputsJT)))]] - (wrap (and correct_class? - correct_method? - static_matches? - special_matches? - arity_matches? - inputs_match?)))) - -(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.to_list - (monad.map try.monad reflection!.type) - phase.lift)] - (wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor)) - (n.= (list.size inputsJT) (list.size parameters)) - (list\fold (function (_ [expectedJC actualJC] prev) - (and prev - (jvm\= expectedJC (: (Type Value) - (case (jvm_parser.var? actualJC) - (#.Some name) - (|> aliasing - (dictionary.get name) - (maybe.default name) - jvm.var) - - #.None - actualJC))))) - true - (list.zip/2 parameters inputsJT)))))) - -(def: idx_to_parameter - (-> Nat .Type) - (|>> (n.* 2) inc #.Parameter)) - -(def: (jvm_type_var_mapping owner_tvars method_tvars) - (-> (List Text) (List Text) [(List .Type) Mapping]) - (let [jvm_tvars (list\compose owner_tvars method_tvars) - lux_tvars (|> jvm_tvars - list.reverse - list.enumeration - (list\map (function (_ [idx name]) - [name (idx_to_parameter idx)])) - list.reverse) - num_owner_tvars (list.size owner_tvars) - owner_tvarsT (|> lux_tvars (list.take num_owner_tvars) (list\map product.right)) - mapping (dictionary.from_list text.hash lux_tvars)] - [owner_tvarsT mapping])) - -(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.to_list - (list\map (|>> java/lang/reflect/TypeVariable::getName)))) - method_tvars (|> (java/lang/reflect/Method::getTypeParameters method) - array.to_list - (list\map (|>> 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.to_list - (monad.map ! (|>> reflection!.type phase.lift)) - (phase\map (monad.map ! (..reflection_type mapping))) - phase\join) - outputT (|> method - java/lang/reflect/Method::getGenericReturnType - reflection!.return - phase.lift - (phase\map (..reflection_return mapping)) - phase\join) - exceptionsT (|> (java/lang/reflect/Method::getGenericExceptionTypes method) - array.to_list - (monad.map ! (|>> reflection!.type phase.lift)) - (phase\map (monad.map ! (..reflection_type mapping))) - phase\join) - #let [methodT (<| (type.univ_q (dictionary.size mapping)) - (type.function (case method_style - #Static - inputsT - - _ - (list& (#.Primitive (java/lang/Class::getName owner) owner_tvarsT) - inputsT))) - outputT)]] - (wrap [methodT - (reflection!.deprecated? (java/lang/reflect/Method::getDeclaredAnnotations method)) - exceptionsT])))) - -(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.to_list - (list\map (|>> java/lang/reflect/TypeVariable::getName))) - method_tvars (|> (java/lang/reflect/Constructor::getTypeParameters constructor) - array.to_list - (list\map (|>> 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.to_list - (monad.map ! (|>> reflection!.type phase.lift)) - (phase\map (monad.map ! (reflection_type mapping))) - phase\join) - exceptionsT (|> (java/lang/reflect/Constructor::getGenericExceptionTypes constructor) - array.to_list - (monad.map ! (|>> reflection!.type phase.lift)) - (phase\map (monad.map ! (reflection_type mapping))) - phase\join) - #let [objectT (#.Primitive (java/lang/Class::getName owner) owner_tvarsT) - constructorT (<| (type.univ_q (dictionary.size mapping)) - (type.function inputsT) - objectT)]] - (wrap [constructorT - (reflection!.deprecated? (java/lang/reflect/Constructor::getDeclaredAnnotations constructor)) - exceptionsT])))) - -(type: Evaluation - (#Pass Method_Signature) - (#Hint Method_Signature)) - -(template [<name> <tag>] - [(def: <name> - (-> Evaluation (Maybe Method_Signature)) - (|>> (case> (<tag> output) - (#.Some output) - - _ - #.None)))] - - [pass! #Pass] - [hint! #Hint] - ) - -(template [<name> <type> <method>] - [(def: <name> - (-> <type> (List (Type Var))) - (|>> <method> - array.to_list - (list\map (|>> 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.zip/2 (list\map jvm_parser.name actual) - (list\map jvm_parser.name expected)) - (dictionary.from_list text.hash))) - -(def: (method_candidate actual_class_tvars class_name actual_method_tvars method_name method_style inputsJT) - (-> (List (Type Var)) External (List (Type Var)) Text Method_Style (List (Type Value)) (Operation Method_Signature)) - (do {! phase.monad} - [class (phase.lift (reflection!.load class_name)) - #let [expected_class_tvars (class_type_variables class)] - candidates (|> class - java/lang/Class::getDeclaredMethods - array.to_list - (list.filter (|>> java/lang/reflect/Method::getName (text\= method_name))) - (monad.map ! (: (-> java/lang/reflect/Method (Operation Evaluation)) - (function (_ method) - (do ! - [#let [expected_method_tvars (method_type_variables method) - aliasing (dictionary.merge (..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)] - (\ ! map (if passes? - (|>> #Pass) - (|>> #Hint)) - (method_signature method_style method)))))))] - (case (list.all pass! candidates) - (#.Cons method #.Nil) - (wrap method) - - #.Nil - (/////analysis.throw ..no_candidates [class_name method_name inputsJT (list.all hint! candidates)]) - - candidates - (/////analysis.throw ..too_many_candidates [class_name method_name inputsJT candidates])))) - -(def: constructor_method - "<init>") - -(def: (constructor_candidate actual_class_tvars class_name actual_method_tvars inputsJT) - (-> (List (Type Var)) External (List (Type Var)) (List (Type Value)) (Operation Method_Signature)) - (do {! phase.monad} - [class (phase.lift (reflection!.load class_name)) - #let [expected_class_tvars (class_type_variables class)] - candidates (|> class - java/lang/Class::getConstructors - array.to_list - (monad.map ! (function (_ constructor) - (do ! - [#let [expected_method_tvars (constructor_type_variables constructor) - aliasing (dictionary.merge (..aliasing expected_class_tvars actual_class_tvars) - (..aliasing expected_method_tvars actual_method_tvars))] - passes? (check_constructor aliasing class inputsJT constructor)] - (\ ! map - (if passes? (|>> #Pass) (|>> #Hint)) - (constructor_signature constructor))))))] - (case (list.all pass! candidates) - (#.Cons constructor #.Nil) - (wrap constructor) - - #.Nil - (/////analysis.throw ..no_candidates [class_name ..constructor_method inputsJT (list.all hint! candidates)]) - - candidates - (/////analysis.throw ..too_many_candidates [class_name ..constructor_method inputsJT candidates])))) - -(template [<name> <category> <parser>] - [(def: #export <name> - (Parser (Type <category>)) - (<text>.embed <parser> <code>.text))] - - [var Var jvm_parser.var] - [class Class jvm_parser.class] - [type Value jvm_parser.value] - [return Return jvm_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.zip/2 (list\map (|>> ..signature /////analysis.text) typesT)) - (list\map (function (_ [type value]) - (/////analysis.tuple (list type value)))))) - -(def: type_vars - (<code>.tuple (<>.some ..var))) - -(def: invoke::static - Handler - (..custom - [($_ <>.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) - #let [argsT (list\map product.left argsTC)] - [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Static argsT) - _ (phase.assert ..deprecated_method [class method methodT] - (not deprecated?)) - [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC)) - outputJT (check_return outputT)] - (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) - (/////analysis.text method) - (/////analysis.text (..signature outputJT)) - (decorate_inputs argsT argsA))))))])) - -(def: invoke::virtual - Handler - (..custom - [($_ <>.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) - #let [argsT (list\map product.left argsTC)] - [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Virtual argsT) - _ (phase.assert ..deprecated_method [class method methodT] - (not deprecated?)) - [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC))) - #let [[objectA argsA] (case allA - (#.Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - outputJT (check_return outputT)] - (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) - (/////analysis.text method) - (/////analysis.text (..signature outputJT)) - objectA - (decorate_inputs argsT argsA))))))])) - -(def: invoke::special - Handler - (..custom - [($_ <>.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) - #let [argsT (list\map product.left argsTC)] - [methodT deprecated? exceptionsT] (..method_candidate class_tvars class method_tvars method #Special argsT) - _ (phase.assert ..deprecated_method [class method methodT] - (not deprecated?)) - [outputT argsA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC))) - outputJT (check_return outputT)] - (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) - (/////analysis.text method) - (/////analysis.text (..signature outputJT)) - (decorate_inputs argsT argsA))))))])) - -(def: invoke::interface - Handler - (..custom - [($_ <>.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_name) - #let [argsT (list\map product.left argsTC)] - class (phase.lift (reflection!.load class_name)) - _ (phase.assert non_interface class_name - (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))) - [methodT deprecated? exceptionsT] (..method_candidate class_tvars class_name method_tvars method #Interface argsT) - _ (phase.assert ..deprecated_method [class_name method methodT] - (not deprecated?)) - [outputT allA] (inferenceA.general archive analyse methodT (list& objectC (list\map product.right argsTC))) - #let [[objectA argsA] (case allA - (#.Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - outputJT (check_return outputT)] - (wrap (#/////analysis.Extension extension_name - (list& (/////analysis.text (..signature (jvm.class class_name (list)))) - (/////analysis.text method) - (/////analysis.text (..signature outputJT)) - objectA - (decorate_inputs argsT argsA))))))])) - -(def: invoke::constructor - (..custom - [($_ <>.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) - #let [argsT (list\map product.left argsTC)] - [methodT deprecated? exceptionsT] (..constructor_candidate class_tvars class method_tvars argsT) - _ (phase.assert ..deprecated_method [class ..constructor_method methodT] - (not deprecated?)) - [outputT argsA] (inferenceA.general archive analyse methodT (list\map product.right argsTC))] - (wrap (#/////analysis.Extension extension_name (list& (/////analysis.text (..signature (jvm.class class (list)))) - (decorate_inputs argsT argsA))))))])) - -(def: bundle::member - Bundle - (<| (///bundle.prefix "member") - (|> ///bundle.empty - (dictionary.merge (<| (///bundle.prefix "get") - (|> ///bundle.empty - (///bundle.install "static" get::static) - (///bundle.install "virtual" get::virtual)))) - (dictionary.merge (<| (///bundle.prefix "put") - (|> ///bundle.empty - (///bundle.install "static" put::static) - (///bundle.install "virtual" put::virtual)))) - (dictionary.merge (<| (///bundle.prefix "invoke") - (|> ///bundle.empty - (///bundle.install "static" invoke::static) - (///bundle.install "virtual" invoke::virtual) - (///bundle.install "special" invoke::special) - (///bundle.install "interface" invoke::interface) - (///bundle.install "constructor" invoke::constructor) - ))) - ))) - -(type: #export (Annotation_Parameter a) - [Text a]) - -(def: annotation_parameter - (Parser (Annotation_Parameter Code)) - (<code>.tuple (<>.and <code>.text <code>.any))) - -(type: #export (Annotation a) - [Text (List (Annotation_Parameter a))]) - -(def: #export annotation - (Parser (Annotation Code)) - (<code>.form (<>.and <code>.text (<>.some ..annotation_parameter)))) - -(def: #export 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& (/////analysis.text name) - (list\map annotation_parameter_analysis parameters)))) - -(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)))) - -(template [<name> <filter>] - [(def: <name> - (-> (java/lang/Class java/lang/Object) - (Try (List [Text (Type Method)]))) - (|>> java/lang/Class::getDeclaredMethods - array.to_list - <filter> - (monad.map try.monad - (function (_ method) - (do {! try.monad} - [inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method) - array.to_list - (monad.map ! reflection!.type)) - return (|> method - java/lang/reflect/Method::getGenericReturnType - reflection!.return) - exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method) - array.to_list - (monad.map ! reflection!.class))] - (wrap [(java/lang/reflect/Method::getName method) - (jvm.method [inputs return exceptions])]))))))] - - [abstract_methods (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))] - [methods (<|)] - ) - -(def: jvm_package_separator ".") - -(template [<name> <methods>] - [(def: <name> - (-> (List (Type Class)) (Try (List [Text (Type Method)]))) - (|>> (monad.map try.monad (|>> ..reflection reflection!.load)) - (try\map (monad.map try.monad <methods>)) - try\join - (try\map list\join)))] - - [all_abstract_methods ..abstract_methods] - [all_methods ..methods] - ) - -(template [<name>] - [(exception: #export (<name> {methods (List [Text (Type Method)])}) - (exception.report - ["Methods" (exception.enumerate - (function (_ [name type]) - (format (%.text name) " " (..signature type))) - methods)]))] - - [missing_abstract_methods] - [invalid_overriden_methods] - ) - -(type: #export Visibility - #Public - #Private - #Protected - #Default) - -(type: #export Finality Bit) -(type: #export Strictness Bit) - -(def: #export public_tag "public") -(def: #export private_tag "private") -(def: #export protected_tag "protected") -(def: #export default_tag "default") - -(def: #export visibility - (Parser Visibility) - ($_ <>.or - (<code>.text! ..public_tag) - (<code>.text! ..private_tag) - (<code>.text! ..protected_tag) - (<code>.text! ..default_tag))) - -(def: #export (visibility_analysis visibility) - (-> Visibility Analysis) - (/////analysis.text (case visibility - #Public ..public_tag - #Private ..private_tag - #Protected ..protected_tag - #Default ..default_tag))) - -(type: #export (Constructor a) - [Visibility - Strictness - (List (Annotation a)) - (List (Type Var)) - (List (Type Class)) ## Exceptions - Text - (List Argument) - (List (Typed a)) - a]) - -(def: #export constructor_tag "init") - -(def: #export constructor_definition - (Parser (Constructor Code)) - (<| <code>.form - (<>.after (<code>.text! ..constructor_tag)) - ($_ <>.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: #export (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} - [annotationsA (monad.map ! (function (_ [name parameters]) - (do ! - [parametersA (monad.map ! (function (_ [name value]) - (do ! - [valueA (analyse archive value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - super_arguments (monad.map ! (function (_ [jvmT super_argC]) - (do ! - [luxT (reflection_type mapping jvmT) - super_argA (typeA.with_type luxT - (analyse archive super_argC))] - (wrap [jvmT super_argA]))) - super_arguments) - arguments' (monad.map ! - (function (_ [name jvmT]) - (do ! - [luxT (reflection_type mapping jvmT)] - (wrap [name luxT]))) - arguments) - [scope bodyA] (|> arguments' - (#.Cons [self_name selfT]) - list.reverse - (list\fold scope.with_local (analyse archive body)) - (typeA.with_type .Any) - /////analysis.with_scope)] - (wrap (/////analysis.tuple (list (/////analysis.text ..constructor_tag) - (visibility_analysis visibility) - (/////analysis.bit strict_fp?) - (/////analysis.tuple (list\map annotation_analysis annotationsA)) - (/////analysis.tuple (list\map var_analysis vars)) - (/////analysis.text self_name) - (/////analysis.tuple (list\map ..argument_analysis arguments)) - (/////analysis.tuple (list\map class_analysis exceptions)) - (/////analysis.tuple (list\map typed_analysis super_arguments)) - (#/////analysis.Function - (list\map (|>> /////analysis.variable) - (scope.environment scope)) - (/////analysis.tuple (list bodyA))) - )))))) - -(type: #export (Virtual_Method a) - [Text - Visibility - Finality - Strictness - (List (Annotation a)) - (List (Type Var)) - Text - (List Argument) - (Type Return) - (List (Type Class)) ## Exceptions - a]) - -(def: virtual_tag "virtual") - -(def: #export virtual_method_definition - (Parser (Virtual_Method Code)) - (<| <code>.form - (<>.after (<code>.text! ..virtual_tag)) - ($_ <>.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))) - -(def: #export (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} - [annotationsA (monad.map ! (function (_ [name parameters]) - (do ! - [parametersA (monad.map ! (function (_ [name value]) - (do ! - [valueA (analyse archive value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - returnT (reflection_return mapping return) - arguments' (monad.map ! - (function (_ [name jvmT]) - (do ! - [luxT (reflection_type mapping jvmT)] - (wrap [name luxT]))) - arguments) - [scope bodyA] (|> arguments' - (#.Cons [self_name selfT]) - list.reverse - (list\fold scope.with_local (analyse archive body)) - (typeA.with_type returnT) - /////analysis.with_scope)] - (wrap (/////analysis.tuple (list (/////analysis.text ..virtual_tag) - (/////analysis.text method_name) - (visibility_analysis visibility) - (/////analysis.bit final?) - (/////analysis.bit strict_fp?) - (/////analysis.tuple (list\map annotation_analysis annotationsA)) - (/////analysis.tuple (list\map var_analysis vars)) - (/////analysis.text self_name) - (/////analysis.tuple (list\map ..argument_analysis arguments)) - (return_analysis return) - (/////analysis.tuple (list\map class_analysis exceptions)) - (#/////analysis.Function - (list\map (|>> /////analysis.variable) - (scope.environment scope)) - (/////analysis.tuple (list bodyA))) - )))))) - -(type: #export (Static_Method a) - [Text - Visibility - Strictness - (List (Annotation a)) - (List (Type Var)) - (List (Type Class)) ## Exceptions - (List Argument) - (Type Return) - a]) - -(def: #export static_tag "static") - -(def: #export static_method_definition - (Parser (Static_Method Code)) - (<| <code>.form - (<>.after (<code>.text! ..static_tag)) - ($_ <>.and - <code>.text - ..visibility - <code>.bit - (<code>.tuple (<>.some ..annotation)) - (<code>.tuple (<>.some ..var)) - (<code>.tuple (<>.some ..class)) - (<code>.tuple (<>.some ..argument)) - ..return - <code>.any))) - -(def: #export (analyse_static_method analyse archive mapping method) - (-> Phase Archive Mapping (Static_Method Code) (Operation Analysis)) - (let [[method_name visibility - strict_fp? annotations vars exceptions - arguments return - body] method] - (do {! phase.monad} - [annotationsA (monad.map ! (function (_ [name parameters]) - (do ! - [parametersA (monad.map ! (function (_ [name value]) - (do ! - [valueA (analyse archive value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - returnT (reflection_return mapping return) - arguments' (monad.map ! - (function (_ [name jvmT]) - (do ! - [luxT (reflection_type mapping jvmT)] - (wrap [name luxT]))) - arguments) - [scope bodyA] (|> arguments' - list.reverse - (list\fold scope.with_local (analyse archive body)) - (typeA.with_type returnT) - /////analysis.with_scope)] - (wrap (/////analysis.tuple (list (/////analysis.text ..static_tag) - (/////analysis.text method_name) - (visibility_analysis visibility) - (/////analysis.bit strict_fp?) - (/////analysis.tuple (list\map annotation_analysis annotationsA)) - (/////analysis.tuple (list\map var_analysis vars)) - (/////analysis.tuple (list\map ..argument_analysis arguments)) - (return_analysis return) - (/////analysis.tuple (list\map class_analysis - exceptions)) - (#/////analysis.Function - (list\map (|>> /////analysis.variable) - (scope.environment scope)) - (/////analysis.tuple (list bodyA))) - )))))) - -(type: #export (Overriden_Method a) - [(Type Class) - Text - Bit - (List (Annotation a)) - (List (Type Var)) - Text - (List Argument) - (Type Return) - (List (Type Class)) - a]) - -(def: #export overriden_tag "override") - -(def: #export overriden_method_definition - (Parser (Overriden_Method Code)) - (<| <code>.form - (<>.after (<code>.text! ..overriden_tag)) - ($_ <>.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 - ))) - -(def: #export (analyse_overriden_method analyse archive selfT mapping method) - (-> Phase Archive .Type Mapping (Overriden_Method Code) (Operation Analysis)) - (let [[parent_type method_name - strict_fp? annotations vars - self_name arguments return exceptions - body] method] - (do {! phase.monad} - [annotationsA (monad.map ! (function (_ [name parameters]) - (do ! - [parametersA (monad.map ! (function (_ [name value]) - (do ! - [valueA (analyse archive value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - returnT (reflection_return mapping return) - arguments' (monad.map ! - (function (_ [name jvmT]) - (do ! - [luxT (reflection_type mapping jvmT)] - (wrap [name luxT]))) - arguments) - [scope bodyA] (|> arguments' - (#.Cons [self_name selfT]) - list.reverse - (list\fold scope.with_local (analyse archive body)) - (typeA.with_type returnT) - /////analysis.with_scope)] - (wrap (/////analysis.tuple (list (/////analysis.text ..overriden_tag) - (class_analysis parent_type) - (/////analysis.text method_name) - (/////analysis.bit strict_fp?) - (/////analysis.tuple (list\map annotation_analysis annotationsA)) - (/////analysis.tuple (list\map var_analysis vars)) - (/////analysis.text self_name) - (/////analysis.tuple (list\map ..argument_analysis arguments)) - (return_analysis return) - (/////analysis.tuple (list\map class_analysis - exceptions)) - (#/////analysis.Function - (list\map (|>> /////analysis.variable) - (scope.environment scope)) - (/////analysis.tuple (list bodyA))) - )))))) - -(type: #export (Method_Definition a) - (#Overriden_Method (Overriden_Method a))) - -(def: #export parameter_types - (-> (List (Type Var)) (Check (List [(Type Var) .Type]))) - (monad.map check.monad - (function (_ parameterJ) - (do check.monad - [[_ parameterT] check.existential] - (wrap [parameterJ parameterT]))))) - -(def: (mismatched_methods super_set sub_set) - (-> (List [Text (Type Method)]) - (List [Text (Type Method)]) - (List [Text (Type Method)])) - (list.filter (function (_ [sub_name subJT]) - (|> super_set - (list.filter (function (_ [super_name superJT]) - (and (text\= super_name sub_name) - (jvm\= superJT subJT)))) - list.size - (n.= 1) - not)) - sub_set)) - -(exception: #export (class_parameter_mismatch {expected (List Text)} - {actual (List (Type Parameter))}) - (exception.report - ["Expected (amount)" (%.nat (list.size expected))] - ["Expected (parameters)" (exception.enumerate %.text expected)] - ["Actual (amount)" (%.nat (list.size actual))] - ["Actual (parameters)" (exception.enumerate ..signature actual)])) - -(def: (super_aliasing class) - (-> (Type Class) (Operation Aliasing)) - (do phase.monad - [#let [[name actual_parameters] (jvm_parser.read_class class)] - class (phase.lift (reflection!.load name)) - #let [expected_parameters (|> (java/lang/Class::getTypeParameters class) - array.to_list - (list\map (|>> java/lang/reflect/TypeVariable::getName)))] - _ (phase.assert ..class_parameter_mismatch [expected_parameters actual_parameters] - (n.= (list.size expected_parameters) - (list.size actual_parameters)))] - (wrap (|> (list.zip/2 expected_parameters actual_parameters) - (list\fold (function (_ [expected actual] mapping) - (case (jvm_parser.var? actual) - (#.Some actual) - (dictionary.put actual expected mapping) - - #.None - mapping)) - jvm_alias.fresh))))) - -(def: (anonymous_class_name module id) - (-> Module Nat Text) - (let [global (text.replace_all .module_separator ..jvm_package_separator module) - local (format "anonymous-class" (%.nat id))] - (format global ..jvm_package_separator local))) - -(def: class::anonymous - Handler - (..custom - [($_ <>.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! (..reflection super_class)) - _ (monad.map ! (|>> ..reflection ..ensure_fresh_class!) super_interfaces) - parameters (typeA.with_env - (..parameter_types parameters)) - #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping) - (dictionary.put (jvm_parser.name parameterJ) - parameterT - mapping)) - luxT.fresh - parameters)] - super_classT (typeA.with_env - (luxT.check (luxT.class mapping) (..signature super_class))) - super_interfaceT+ (typeA.with_env - (monad.map check.monad - (|>> ..signature (luxT.check (luxT.class mapping))) - super_interfaces)) - selfT (///.lift (do meta.monad - [where meta.current_module_name - id meta.count] - (wrap (inheritance_relationship_type (#.Primitive (..anonymous_class_name where id) (list)) - super_classT - super_interfaceT+)))) - _ (typeA.infer selfT) - constructor_argsA+ (monad.map ! (function (_ [type term]) - (do ! - [argT (reflection_type mapping type) - termA (typeA.with_type argT - (analyse archive term))] - (wrap [type termA]))) - constructor_args) - methodsA (monad.map ! (analyse_overriden_method analyse archive selfT mapping) methods) - required_abstract_methods (phase.lift (all_abstract_methods (list& super_class super_interfaces))) - available_methods (phase.lift (all_methods (list& super_class super_interfaces))) - overriden_methods (monad.map ! (function (_ [parent_type method_name - strict_fp? annotations vars - self_name arguments return exceptions - body]) - (do ! - [aliasing (super_aliasing parent_type)] - (wrap [method_name (|> (jvm.method [(list\map product.right arguments) - return - exceptions]) - (jvm_alias.method aliasing))]))) - methods) - #let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods) - invalid_overriden_methods (mismatched_methods available_methods overriden_methods)] - _ (phase.assert ..missing_abstract_methods missing_abstract_methods - (list.empty? missing_abstract_methods)) - _ (phase.assert ..invalid_overriden_methods invalid_overriden_methods - (list.empty? invalid_overriden_methods))] - (wrap (#/////analysis.Extension extension_name - (list (class_analysis super_class) - (/////analysis.tuple (list\map class_analysis super_interfaces)) - (/////analysis.tuple (list\map typed_analysis constructor_argsA+)) - (/////analysis.tuple methodsA))))))])) - -(def: bundle::class - Bundle - (<| (///bundle.prefix "class") - (|> ///bundle.empty - (///bundle.install "anonymous" class::anonymous) - ))) - -(def: #export bundle - Bundle - (<| (///bundle.prefix "jvm") - (|> ///bundle.empty - (dictionary.merge bundle::conversion) - (dictionary.merge bundle::int) - (dictionary.merge bundle::long) - (dictionary.merge bundle::float) - (dictionary.merge bundle::double) - (dictionary.merge bundle::char) - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - (dictionary.merge bundle::member) - (dictionary.merge bundle::class) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux deleted file mode 100644 index 8f97d1ba9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux +++ /dev/null @@ -1,251 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" lua]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: Nil - (for {@.lua ffi.Nil} - Any)) - -(def: Object - (for {@.lua (type (ffi.Object Any))} - Any)) - -(def: Function - (for {@.lua ffi.Function} - Any)) - -(def: array::new - Handler - (custom - [<code>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<code>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <code>.any <code>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <code>.any <code>.any <code>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <code>.any <code>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#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 - [($_ <>.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)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.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.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (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)) - ))) - -(template [<name> <fromT> <toT>] - [(def: <name> - Handler - (custom - [<code>.any - (function (_ extension phase archive inputC) - (do {! phase.monad} - [inputA (analysis/type.with_type (type <fromT>) - (phase archive inputC)) - _ (analysis/type.infer (type <toT>))] - (wrap (#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.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: lua::apply - Handler - (custom - [($_ <>.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.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: lua::power - Handler - (custom - [($_ <>.and <code>.any <code>.any) - (function (_ extension phase archive [powerC baseC]) - (do {! phase.monad} - [powerA (analysis/type.with_type Frac - (phase archive powerC)) - baseA (analysis/type.with_type Frac - (phase archive baseC)) - _ (analysis/type.infer Frac)] - (wrap (#analysis.Extension extension (list powerA baseA)))))])) - -(def: lua::import - Handler - (custom - [<code>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer ..Object)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: lua::function - Handler - (custom - [($_ <>.and <code>.nat <code>.any) - (function (_ extension phase archive [arity abstractionC]) - (do phase.monad - [#let [inputT (type.tuple (list.repeat arity Any))] - abstractionA (analysis/type.with_type (-> inputT Any) - (phase archive abstractionC)) - _ (analysis/type.infer ..Function)] - (wrap (#analysis.Extension extension (list (analysis.nat arity) - abstractionA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lua") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - (dictionary.merge 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/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux deleted file mode 100644 index a86295b2a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux +++ /dev/null @@ -1,300 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["n" nat]]] - [type - ["." check]] - ["." meta]] - ["." /// - ["#." bundle] - ["/#" // #_ - [analysis - [".A" type]] - [// - ["#." analysis (#+ Analysis Operation Phase Handler Bundle) - [evaluation (#+ Eval)]] - [/// - ["#" phase] - [meta - [archive (#+ Archive)]]]]]]) - -(def: #export (custom [syntax handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase Archive s (Operation Analysis))] - Handler)) - (function (_ extension_name analyse archive args) - (case (<code>.run syntax args) - (#try.Success inputs) - (handler extension_name analyse archive inputs) - - (#try.Failure _) - (////analysis.throw ///.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.infer outputT) - argsA (monad.map ! - (function (_ [argT argC]) - (typeA.with_type argT - (analyse archive argC))) - (list.zip/2 inputsT+ args))] - (wrap (#////analysis.Extension extension_name argsA))) - (////analysis.throw ///.incorrect_arity [extension_name num_expected num_actual])))))) - -(def: #export (nullary valueT) - (-> Type Handler) - (simple (list) valueT)) - -(def: #export (unary inputT outputT) - (-> Type Type Handler) - (simple (list inputT) outputT)) - -(def: #export (binary subjectT paramT outputT) - (-> Type Type Type Handler) - (simple (list subjectT paramT) outputT)) - -(def: #export (trinary subjectT param0T param1T outputT) - (-> Type Type Type Type Handler) - (simple (list subjectT param0T param1T) outputT)) - -## TODO: Get rid of this ASAP -(as_is - (exception: #export (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 (wrap (|> raw (text.nth 0) maybe.assume)) - _ (<>.fail (exception.construct ..char_text_must_be_size_1 [raw]))))) - - (def: lux::syntax_char_case! - (..custom - [($_ <>.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.with_type text.Char - (phase archive input)) - expectedT (///.lift meta.expected_type) - conditionals (monad.map ! (function (_ [cases branch]) - (do ! - [branch (typeA.with_type expectedT - (phase archive branch))] - (wrap [cases branch]))) - conditionals) - else (typeA.with_type expectedT - (phase archive else))] - (wrap (|> conditionals - (list\map (function (_ [cases branch]) - (////analysis.tuple - (list (////analysis.tuple (list\map (|>> ////analysis.nat) cases)) - branch)))) - (list& input else) - (#////analysis.Extension extension_name)))))]))) - -## "lux is" represents reference/pointer equality. -(def: lux::is - Handler - (function (_ extension_name analyse archive args) - (do ////.monad - [[var_id varT] (typeA.with_env check.var)] - ((binary varT varT 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)) - (do ////.monad - [[var_id varT] (typeA.with_env check.var) - _ (typeA.infer (type (Either Text varT))) - opA (typeA.with_type (type (-> .Any varT)) - (analyse archive opC))] - (wrap (#////analysis.Extension extension_name (list opA)))) - - _ - (////analysis.throw ///.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.throw ///.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} - [count (///.lift meta.count) - actualT (\ ! map (|>> (:as Type)) - (eval archive count Type typeC)) - _ (typeA.infer actualT)] - (typeA.with_type actualT - (analyse archive valueC))) - - _ - (////analysis.throw ///.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} - [count (///.lift meta.count) - actualT (\ ! map (|>> (:as Type)) - (eval archive count Type typeC)) - _ (typeA.infer actualT) - [valueT valueA] (typeA.with_inference - (analyse archive valueC))] - (wrap valueA)) - - _ - (////analysis.throw ///.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.infer output)] - (typeA.with_type input - (phase archive valueC))))])) - -(def: lux::macro - Handler - (..custom - [<code>.any - (function (_ extension_name phase archive valueC) - (do {! ////.monad} - [_ (typeA.infer .Macro) - input_type (loop [input_name (name_of .Macro')] - (do ! - [input_type (///.lift (meta.find_def (name_of .Macro')))] - (case input_type - (#.Definition [exported? def_type def_data def_value]) - (wrap (:as Type def_value)) - - (#.Alias real_name) - (recur real_name))))] - (typeA.with_type 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 (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 (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 (Maybe Nat)))) - (///bundle.install "size" (unary Text Nat)) - (///bundle.install "char" (binary Nat Text Nat)) - (///bundle.install "clip" (trinary Nat Nat Text Text)) - ))) - -(def: #export (bundle eval) - (-> Eval Bundle) - (<| (///bundle.prefix "lux") - (|> ///bundle.empty - (dictionary.merge (bundle::lux eval)) - (dictionary.merge bundle::i64) - (dictionary.merge bundle::f64) - (dictionary.merge bundle::text) - (dictionary.merge bundle::io) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux deleted file mode 100644 index 19aea38fa..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux +++ /dev/null @@ -1,213 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" php]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<c>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<c>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <c>.any <c>.any <c>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#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 (ffi.Object Any))} - Any)) - -(def: Function - (for {@.php ffi.Function} - Any)) - -(def: object::new - Handler - (custom - [($_ <>.and <c>.text (<>.some <c>.any)) - (function (_ extension phase archive [constructor inputsC]) - (do {! phase.monad} - [inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (analysis.text constructor) inputsA)))))])) - -(def: object::get - Handler - (custom - [($_ <>.and <c>.text <c>.any) - (function (_ extension phase archive [fieldC objectC]) - (do phase.monad - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <c>.text <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [methodC objectC inputsC]) - (do {! phase.monad} - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (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 - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: php::apply - Handler - (custom - [($_ <>.and <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: php::pack - Handler - (custom - [($_ <>.and <c>.any <c>.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 (Array (I64 Any))) - (phase archive dataC)) - _ (analysis/type.infer Text)] - (wrap (#analysis.Extension extension (list formatA dataA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "php") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge 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/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux deleted file mode 100644 index 53e6c0b05..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux +++ /dev/null @@ -1,230 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<.>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" python]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<code>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<code>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <code>.any <code>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <code>.any <code>.any <code>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <code>.any <code>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#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 (ffi.Object Any))} - Any)) - -(def: Function - (for {@.python ffi.Function} - Any)) - -(def: Dict - (for {@.python ffi.Dict} - Any)) - -(def: object::get - Handler - (custom - [($_ <>.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)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.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.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (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.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: python::import - Handler - (custom - [<code>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer ..Object)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: python::apply - Handler - (custom - [($_ <>.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.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: python::function - Handler - (custom - [($_ <>.and <code>.nat <code>.any) - (function (_ extension phase archive [arity abstractionC]) - (do phase.monad - [#let [inputT (type.tuple (list.repeat arity Any))] - abstractionA (analysis/type.with_type (-> inputT Any) - (phase archive abstractionC)) - _ (analysis/type.infer ..Function)] - (wrap (#analysis.Extension extension (list (analysis.nat arity) - abstractionA)))))])) - -(def: python::exec - Handler - (custom - [($_ <>.and <code>.any <code>.any) - (function (_ extension phase archive [codeC globalsC]) - (do phase.monad - [codeA (analysis/type.with_type Text - (phase archive codeC)) - globalsA (analysis/type.with_type ..Dict - (phase archive globalsC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list codeA globalsA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "python") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge 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/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux deleted file mode 100644 index 12f578ed2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux +++ /dev/null @@ -1,34 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" r]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: #export bundle - Bundle - (<| (bundle.prefix "r") - (|> bundle.empty - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux deleted file mode 100644 index 0fda869e9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux +++ /dev/null @@ -1,198 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" ruby]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<c>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<c>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <c>.any <c>.any <c>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#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 (ffi.Object Any))} - Any)) - -(def: Function - (for {@.ruby ffi.Function} - Any)) - -(def: object::get - Handler - (custom - [($_ <>.and <c>.text <c>.any) - (function (_ extension phase archive [fieldC objectC]) - (do phase.monad - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list (analysis.text fieldC) - objectA)))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <c>.text <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [methodC objectC inputsC]) - (do {! phase.monad} - [objectA (analysis/type.with_type ..Object - (phase archive objectC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer .Any)] - (wrap (#analysis.Extension extension (list& (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 - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: ruby::apply - Handler - (custom - [($_ <>.and <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: ruby::import - Handler - (custom - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Bit)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "ruby") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge 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/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux deleted file mode 100644 index 86db4170f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux +++ /dev/null @@ -1,157 +0,0 @@ -(.module: - [lux #* - ["." ffi] - [abstract - ["." monad (#+ do)]] - [control - ["<>" parser - ["<c>" code (#+ Parser)]]] - [data - [collection - ["." array (#+ Array)] - ["." dictionary] - ["." list]]] - ["." type - ["." check]] - ["@" target - ["_" scheme]]] - [// - ["/" lux (#+ custom)] - [// - ["." bundle] - [// - ["." analysis #_ - ["#/." type]] - [// - ["." analysis (#+ Analysis Operation Phase Handler Bundle)] - [/// - ["." phase]]]]]]) - -(def: array::new - Handler - (custom - [<c>.any - (function (_ extension phase archive lengthC) - (do phase.monad - [lengthA (analysis/type.with_type Nat - (phase archive lengthC)) - [var_id varT] (analysis/type.with_env check.var) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list lengthA)))))])) - -(def: array::length - Handler - (custom - [<c>.any - (function (_ extension phase archive arrayC) - (do phase.monad - [[var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer Nat)] - (wrap (#analysis.Extension extension (list arrayA)))))])) - -(def: array::read - Handler - (custom - [(<>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer varT)] - (wrap (#analysis.Extension extension (list indexA arrayA)))))])) - -(def: array::write - Handler - (custom - [($_ <>.and <c>.any <c>.any <c>.any) - (function (_ extension phase archive [indexC valueC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - valueA (analysis/type.with_type varT - (phase archive valueC)) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) - -(def: array::delete - Handler - (custom - [($_ <>.and <c>.any <c>.any) - (function (_ extension phase archive [indexC arrayC]) - (do phase.monad - [indexA (analysis/type.with_type Nat - (phase archive indexC)) - [var_id varT] (analysis/type.with_env check.var) - arrayA (analysis/type.with_type (type (Array varT)) - (phase archive arrayC)) - _ (analysis/type.infer (type (Array varT)))] - (wrap (#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 - [<c>.text - (function (_ extension phase archive name) - (do phase.monad - [_ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list (analysis.text name))))))])) - -(def: scheme::apply - Handler - (custom - [($_ <>.and <c>.any (<>.some <c>.any)) - (function (_ extension phase archive [abstractionC inputsC]) - (do {! phase.monad} - [abstractionA (analysis/type.with_type ..Function - (phase archive abstractionC)) - inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) - _ (analysis/type.infer Any)] - (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) - -(def: #export bundle - Bundle - (<| (bundle.prefix "scheme") - (|> bundle.empty - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - - (bundle.install "constant" scheme::constant) - (bundle.install "apply" scheme::apply) - (bundle.install "script universe" (/.nullary .Bit)) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux deleted file mode 100644 index 147904b62..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/bundle.lux +++ /dev/null @@ -1,28 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]]] - [// (#+ Handler Bundle)]) - -(def: #export empty - Bundle - (dictionary.new text.hash)) - -(def: #export (install name anonymous) - (All [s i o] - (-> Text (Handler s i o) - (-> (Bundle s i o) (Bundle s i o)))) - (dictionary.put name anonymous)) - -(def: #export (prefix prefix) - (All [s i o] - (-> Text (-> (Bundle s i o) (Bundle s i o)))) - (|>> dictionary.entries - (list\map (function (_ [key val]) [(format prefix " " key) val])) - (dictionary.from_list text.hash))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux deleted file mode 100644 index a00fe5273..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux +++ /dev/null @@ -1,306 +0,0 @@ -(.module: - [lux (#- Type Definition) - ["." host] - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ case>)] - ["<>" parser ("#\." monad) - ["<c>" code (#+ Parser)] - ["<t>" text]]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary] - ["." row]]] - [macro - ["." template]] - [math - [number - ["." i32]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." attribute] - ["." field] - ["." version] - ["." class] - ["." constant - ["." pool (#+ Resource)]] - [encoding - ["." name]] - ["." type (#+ Type Constraint Argument Typed) - [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] - [".T" lux (#+ Mapping)] - ["." signature] - ["." descriptor (#+ Descriptor)] - ["." parser]]]] - [tool - [compiler - ["." analysis] - ["." synthesis] - ["." generation] - ["." directive (#+ Handler Bundle)] - ["." phase - [analysis - [".A" type]] - ["." generation - [jvm - [runtime (#+ Anchor Definition)]]] - ["." extension - ["." bundle] - [analysis - ["." jvm]] - [directive - ["/" lux]]]]]] - [type - ["." check (#+ Check)]]]) - -(type: Operation - (directive.Operation Anchor (Bytecode Any) Definition)) - -(def: signature (|>> type.signature signature.signature)) - -(type: Declaration - [Text (List (Type Var))]) - -(def: declaration - (Parser Declaration) - (<c>.form (<>.and <c>.text (<>.some jvm.var)))) - -(def: visibility - (Parser (Modifier field.Field)) - (`` ($_ <>.either - (~~ (template [<label> <modifier>] - [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))] - - ["public" field.public] - ["private" field.private] - ["protected" field.protected] - ["default" modifier.empty]))))) - -(def: inheritance - (Parser (Modifier class.Class)) - (`` ($_ <>.either - (~~ (template [<label> <modifier>] - [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))] - - ["final" class.final] - ["abstract" class.abstract] - ["default" modifier.empty]))))) - -(def: state - (Parser (Modifier field.Field)) - (`` ($_ <>.either - (~~ (template [<label> <modifier>] - [(<>.after (<c>.text! <label>) (<>\wrap <modifier>))] - - ["volatile" field.volatile] - ["final" field.final] - ["default" modifier.empty]))))) - -(type: Annotation Any) - -(def: annotation - (Parser Annotation) - <c>.any) - -(def: field-type - (Parser (Type Value)) - (<t>.embed parser.value <c>.text)) - -(type: Constant - [Text (List Annotation) (Type Value) Code]) - -(def: constant - (Parser Constant) - (<| <c>.form - (<>.after (<c>.text! "constant")) - ($_ <>.and - <c>.text - (<c>.tuple (<>.some ..annotation)) - ..field-type - <c>.any - ))) - -(type: Variable - [Text (Modifier field.Field) (Modifier field.Field) (List Annotation) (Type Value)]) - -(def: variable - (Parser Variable) - (<| <c>.form - (<>.after (<c>.text! "variable")) - ($_ <>.and - <c>.text - ..visibility - ..state - (<c>.tuple (<>.some ..annotation)) - ..field-type - ))) - -(type: Field - (#Constant Constant) - (#Variable Variable)) - -(def: field - (Parser Field) - ($_ <>.or - ..constant - ..variable - )) - -(type: Method-Definition - (#Constructor (jvm.Constructor Code)) - (#Virtual-Method (jvm.Virtual-Method Code)) - (#Static-Method (jvm.Static-Method Code)) - (#Overriden-Method (jvm.Overriden-Method Code))) - -(def: method - (Parser Method-Definition) - ($_ <>.or - jvm.constructor-definition - jvm.virtual-method-definition - jvm.static-method-definition - jvm.overriden-method-definition - )) - -(def: (constraint name) - (-> Text Constraint) - {#type.name name - #type.super-class (type.class "java.lang.Object" (list)) - #type.super-interfaces (list)}) - -(def: constant::modifier - (Modifier field.Field) - ($_ modifier\compose - 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 - (^template [<tag> <type> <constant>] - [[_ (<tag> value)] - (do pool.monad - [constant (`` (|> value (~~ (template.splice <constant>)))) - attribute (attribute.constant constant)] - (field.field ..constant::modifier name <type> (row.row attribute)))]) - ([#.Bit type.boolean [(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 [host.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 annotations type]) - (field.field (modifier\compose visibility state) - name type (row.row)))) - -(def: (method-definition [mapping selfT] [analyse synthesize generate]) - (-> [Mapping .Type] - [analysis.Phase - synthesis.Phase - (generation.Phase Anchor (Bytecode Any) Definition)] - (-> Method-Definition (Operation synthesis.Synthesis))) - (function (_ methodC) - (do phase.monad - [methodA (: (Operation analysis.Analysis) - (directive.lift-analysis - (case methodC - (#Constructor method) - (jvm.analyse-constructor-method analyse selfT mapping method) - - (#Virtual-Method method) - (jvm.analyse-virtual-method analyse selfT mapping method) - - (#Static-Method method) - (jvm.analyse-static-method analyse mapping method) - - (#Overriden-Method method) - (jvm.analyse-overriden-method analyse selfT mapping method))))] - (directive.lift-synthesis - (synthesize methodA))))) - -(def: jvm::class - (Handler Anchor (Bytecode Any) Definition) - (/.custom - [($_ <>.and - ..declaration - jvm.class - (<c>.tuple (<>.some jvm.class)) - ..inheritance - (<c>.tuple (<>.some ..annotation)) - (<c>.tuple (<>.some ..field)) - (<c>.tuple (<>.some ..method))) - (function (_ extension phase - [[name parameters] - super-class - super-interfaces - inheritance - ## TODO: Handle annotations. - annotations - fields - methods]) - (do {! phase.monad} - [parameters (directive.lift-analysis - (typeA.with-env - (jvm.parameter-types parameters))) - #let [mapping (list\fold (function (_ [parameterJ parameterT] mapping) - (dictionary.put (parser.name parameterJ) parameterT mapping)) - luxT.fresh - parameters)] - super-classT (directive.lift-analysis - (typeA.with-env - (luxT.check (luxT.class mapping) (..signature super-class)))) - super-interfaceT+ (directive.lift-analysis - (typeA.with-env - (monad.map check.monad - (|>> ..signature (luxT.check (luxT.class mapping))) - super-interfaces))) - #let [selfT (jvm.inheritance-relationship-type (#.Primitive name (list\map product.right parameters)) - super-classT - super-interfaceT+)] - state (extension.lift phase.get-state) - #let [analyse (get@ [#directive.analysis #directive.phase] state) - synthesize (get@ [#directive.synthesis #directive.phase] state) - generate (get@ [#directive.generation #directive.phase] state)] - methods (monad.map ! (..method-definition [mapping selfT] [analyse synthesize generate]) - methods) - ## _ (directive.lift-generation - ## (generation.save! true ["" name] - ## [name - ## (class.class version.v6_0 - ## (modifier\compose class.public inheritance) - ## (name.internal name) (list\map (|>> product.left parser.name ..constraint) parameters) - ## super-class super-interfaces - ## (list\map ..field-definition fields) - ## (list) ## TODO: Add methods - ## (row.row))])) - _ (directive.lift-generation - (generation.log! (format "Class " name)))] - (wrap directive.no-requirements)))])) - -(def: #export bundle - (Bundle Anchor (Bytecode Any) Definition) - (<| (bundle.prefix "jvm") - (|> bundle.empty - ## TODO: Finish handling methods and un-comment. - ## (dictionary.put "class" jvm::class) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux deleted file mode 100644 index 9e405eb78..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ /dev/null @@ -1,450 +0,0 @@ -(.module: - [lux #* - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - [io (#+ IO)] - ["." try] - ["." exception (#+ exception:)] - ["p" parser - ["s" code (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary]]] - [macro - ["." code]] - [math - [number - ["n" nat]]] - ["." type (#+ :share) - ["." check]]] - ["." /// (#+ Extender) - ["#." bundle] - ["#." analysis] - ["/#" // #_ - [analysis - ["." module] - [".A" type]] - ["/#" // #_ - ["#." analysis - [macro (#+ Expander)] - ["#/." evaluation]] - ["#." synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["#." directive (#+ Import Requirements Phase Operation Handler Bundle)] - ["#." program (#+ Program)] - [/// - ["." phase] - [meta - ["." archive (#+ Archive)]]]]]]) - -(def: #export (custom [syntax handler]) - (All [anchor expression directive s] - (-> [(Parser s) - (-> Text - (Phase anchor expression directive) - Archive - s - (Operation anchor expression directive Requirements))] - (Handler anchor expression directive))) - (function (_ extension_name phase archive inputs) - (case (s.run syntax inputs) - (#try.Success inputs) - (handler extension_name phase archive inputs) - - (#try.Failure error) - (phase.throw ///.invalid_syntax [extension_name %.code inputs])))) - -(def: (context [module_id artifact_id]) - (-> Context Context) - ## TODO: Find a better way that doesn't rely on clever tricks. - [module_id (n.- (inc artifact_id) 0)]) - -## TODO: Inline "evaluate!'" into "evaluate!" ASAP -(def: (evaluate!' archive generate code//type codeS) - (All [anchor expression directive] - (-> Archive - (/////generation.Phase anchor expression directive) - Type - Synthesis - (Operation anchor expression directive [Type expression Any]))) - (/////directive.lift_generation - (do phase.monad - [module /////generation.module - id /////generation.next - codeG (generate archive codeS) - module_id (/////generation.module_id module archive) - codeV (/////generation.evaluate! (..context [module_id id]) codeG)] - (wrap [code//type codeG codeV])))) - -(def: #export (evaluate! archive type codeC) - (All [anchor expression directive] - (-> Archive Type Code (Operation anchor expression directive [Type expression Any]))) - (do phase.monad - [state (///.lift phase.get_state) - #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) - synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) - generate (get@ [#/////directive.generation #/////directive.phase] state)] - [_ codeA] (/////directive.lift_analysis - (/////analysis.with_scope - (typeA.with_fresh_env - (typeA.with_type type - (analyse archive codeC))))) - codeS (/////directive.lift_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 directive] - (-> Archive - (/////generation.Phase anchor expression directive) - Name - Type - Synthesis - (Operation anchor expression directive [Type expression Any]))) - (/////directive.lift_generation - (do phase.monad - [codeG (generate archive codeS) - id (/////generation.learn name) - module_id (phase.lift (archive.id module archive)) - [target_name value directive] (/////generation.define! [module_id id] codeG) - _ (/////generation.save! id directive)] - (wrap [code//type codeG value])))) - -(def: (definition archive name expected codeC) - (All [anchor expression directive] - (-> Archive Name (Maybe Type) Code - (Operation anchor expression directive [Type expression Any]))) - (do {! phase.monad} - [state (///.lift phase.get_state) - #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) - synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) - generate (get@ [#/////directive.generation #/////directive.phase] state)] - [_ code//type codeA] (/////directive.lift_analysis - (/////analysis.with_scope - (typeA.with_fresh_env - (case expected - #.None - (do ! - [[code//type codeA] (typeA.with_inference - (analyse archive codeC)) - code//type (typeA.with_env - (check.clean code//type))] - (wrap [code//type codeA])) - - (#.Some expected) - (do ! - [codeA (typeA.with_type expected - (analyse archive codeC))] - (wrap [expected codeA])))))) - codeS (/////directive.lift_synthesis - (synthesize archive codeA))] - (definition' archive generate name code//type codeS))) - -(template [<full> <partial> <learn>] - [## TODO: Inline "<partial>" into "<full>" ASAP - (def: (<partial> archive generate extension codeT codeS) - (All [anchor expression directive] - (-> Archive - (/////generation.Phase anchor expression directive) - Text - Type - Synthesis - (Operation anchor expression directive [expression Any]))) - (do phase.monad - [current_module (/////directive.lift_analysis - (///.lift meta.current_module_name))] - (/////directive.lift_generation - (do phase.monad - [codeG (generate archive codeS) - module_id (phase.lift (archive.id current_module archive)) - id (<learn> extension) - [target_name value directive] (/////generation.define! [module_id id] codeG) - _ (/////generation.save! id directive)] - (wrap [codeG value]))))) - - (def: #export (<full> archive extension codeT codeC) - (All [anchor expression directive] - (-> Archive Text Type Code - (Operation anchor expression directive [expression Any]))) - (do phase.monad - [state (///.lift phase.get_state) - #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) - synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) - generate (get@ [#/////directive.generation #/////directive.phase] state)] - [_ codeA] (/////directive.lift_analysis - (/////analysis.with_scope - (typeA.with_fresh_env - (typeA.with_type codeT - (analyse archive codeC))))) - codeS (/////directive.lift_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] - [directive directive' /////generation.learn_directive] - ) - -(def: (refresh expander host_analysis) - (All [anchor expression directive] - (-> Expander /////analysis.Bundle (Operation anchor expression directive Any))) - (do phase.monad - [[bundle state] phase.get_state - #let [eval (/////analysis/evaluation.evaluator expander - (get@ [#/////directive.synthesis #/////directive.state] state) - (get@ [#/////directive.generation #/////directive.state] state) - (get@ [#/////directive.generation #/////directive.phase] state))]] - (phase.set_state [bundle - (update@ [#/////directive.analysis #/////directive.state] - (: (-> /////analysis.State+ /////analysis.State+) - (|>> product.right - [(///analysis.bundle eval host_analysis)])) - state)]))) - -(def: (announce_definition! short type) - (All [anchor expression directive] - (-> Text Type (Operation anchor expression directive Any))) - (/////directive.lift_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 [_ (#.Identifier ["" short_name])] valueC annotationsC [_ (#.Bit exported?)])) - (do phase.monad - [current_module (/////directive.lift_analysis - (///.lift meta.current_module_name)) - #let [full_name [current_module short_name]] - [type valueT value] (..definition archive full_name #.None valueC) - [_ annotationsT annotations] (evaluate! archive Code annotationsC) - _ (/////directive.lift_analysis - (module.define short_name (#.Right [exported? type (:as Code annotations) value]))) - _ (..refresh expander host_analysis) - _ (..announce_definition! short_name type)] - (wrap /////directive.no_requirements)) - - _ - (phase.throw ///.invalid_syntax [extension_name %.code inputsC+])))) - -(def: (def::type_tagged expander host_analysis) - (-> Expander /////analysis.Bundle Handler) - (..custom - [($_ p.and s.local_identifier s.any s.any (s.tuple (p.some s.text)) s.bit) - (function (_ extension_name phase archive [short_name valueC annotationsC tags exported?]) - (do phase.monad - [current_module (/////directive.lift_analysis - (///.lift meta.current_module_name)) - #let [full_name [current_module short_name]] - [_ annotationsT annotations] (evaluate! archive Code annotationsC) - #let [annotations (:as Code annotations)] - [type valueT value] (..definition archive full_name (#.Some .Type) valueC) - _ (/////directive.lift_analysis - (do phase.monad - [_ (module.define short_name (#.Right [exported? type annotations value]))] - (module.declare_tags tags exported? (:as Type value)))) - _ (..refresh expander host_analysis) - _ (..announce_definition! short_name type)] - (wrap /////directive.no_requirements)))])) - -(def: imports - (Parser (List Import)) - (|> (s.tuple (p.and s.text s.text)) - p.some - s.tuple)) - -(def: def::module - Handler - (..custom - [($_ p.and s.any ..imports) - (function (_ extension_name phase archive [annotationsC imports]) - (do {! phase.monad} - [[_ annotationsT annotationsV] (evaluate! archive Code annotationsC) - #let [annotationsV (:as Code annotationsV)] - _ (/////directive.lift_analysis - (do ! - [_ (monad.map ! (function (_ [module alias]) - (do ! - [_ (module.import module)] - (case alias - "" (wrap []) - _ (module.alias alias module)))) - imports)] - (module.set_annotations annotationsV)))] - (wrap {#/////directive.imports imports - #/////directive.referrals (list)})))])) - -(exception: #export (cannot_alias_an_alias {local Alias} {foreign Alias} {target Name}) - (exception.report - ["Local alias" (%.name local)] - ["Foreign alias" (%.name foreign)] - ["Target definition" (%.name target)])) - -(def: (define_alias alias original) - (-> Text Name (/////analysis.Operation Any)) - (do phase.monad - [current_module (///.lift meta.current_module_name) - constant (///.lift (meta.find_def original))] - (case constant - (#.Left de_aliased) - (phase.throw ..cannot_alias_an_alias [[current_module alias] original de_aliased]) - - (#.Right [exported? original_type original_annotations original_value]) - (module.define alias (#.Left original))))) - -(def: def::alias - Handler - (..custom - [($_ p.and s.local_identifier s.identifier) - (function (_ extension_name phase archive [alias def_name]) - (do phase.monad - [_ (///.lift - (phase.sub [(get@ [#/////directive.analysis #/////directive.state]) - (set@ [#/////directive.analysis #/////directive.state])] - (define_alias alias def_name)))] - (wrap /////directive.no_requirements)))])) - -(template [<description> <mame> <def_type> <type> <scope> <definer>] - [(def: (<mame> [anchorT expressionT directiveT] extender) - (All [anchor expression directive] - (-> [Type Type Type] Extender - (Handler anchor expression directive))) - (function (handler extension_name phase archive inputsC+) - (case inputsC+ - (^ (list nameC valueC)) - (do phase.monad - [[_ _ name] (evaluate! archive Text nameC) - [_ handlerV] (<definer> archive (:as Text name) - (type <def_type>) - valueC) - _ (<| <scope> - (///.install extender (:as Text name)) - (:share [anchor expression directive] - (Handler anchor expression directive) - handler - - <type> - (:assume handlerV))) - _ (/////directive.lift_generation - (/////generation.log! (format <description> " " (%.text (:as Text name)))))] - (wrap /////directive.no_requirements)) - - _ - (phase.throw ///.invalid_syntax [extension_name %.code inputsC+]))))] - - ["Analysis" - def::analysis - /////analysis.Handler /////analysis.Handler - /////directive.lift_analysis - ..analyser] - ["Synthesis" - def::synthesis - /////synthesis.Handler /////synthesis.Handler - /////directive.lift_synthesis - ..synthesizer] - ["Generation" - def::generation - (/////generation.Handler anchorT expressionT directiveT) (/////generation.Handler anchor expression directive) - /////directive.lift_generation - ..generator] - ["Directive" - def::directive - (/////directive.Handler anchorT expressionT directiveT) (/////directive.Handler anchor expression directive) - (<|) - ..directive] - ) - -## TODO; Both "prepare-program" and "define-program" exist only -## because the old compiler couldn't handle a fully-inlined definition -## for "def::program". Inline them ASAP. -(def: (prepare_program archive analyse synthesize programC) - (All [anchor expression directive output] - (-> Archive - /////analysis.Phase - /////synthesis.Phase - Code - (Operation anchor expression directive Synthesis))) - (do phase.monad - [[_ programA] (/////directive.lift_analysis - (/////analysis.with_scope - (typeA.with_fresh_env - (typeA.with_type (type (-> (List Text) (IO Any))) - (analyse archive programC)))))] - (/////directive.lift_synthesis - (synthesize archive programA)))) - -(def: (define_program archive module_id generate program programS) - (All [anchor expression directive output] - (-> Archive - archive.ID - (/////generation.Phase anchor expression directive) - (Program expression directive) - Synthesis - (/////generation.Operation anchor expression directive Any))) - (do phase.monad - [programG (generate archive programS) - artifact_id (/////generation.learn /////program.name)] - (/////generation.save! artifact_id (program [module_id artifact_id] programG)))) - -(def: (def::program program) - (All [anchor expression directive] - (-> (Program expression directive) (Handler anchor expression directive))) - (function (handler extension_name phase archive inputsC+) - (case inputsC+ - (^ (list programC)) - (do phase.monad - [state (///.lift phase.get_state) - #let [analyse (get@ [#/////directive.analysis #/////directive.phase] state) - synthesize (get@ [#/////directive.synthesis #/////directive.phase] state) - generate (get@ [#/////directive.generation #/////directive.phase] state)] - programS (prepare_program archive analyse synthesize programC) - current_module (/////directive.lift_analysis - (///.lift meta.current_module_name)) - module_id (phase.lift (archive.id current_module archive)) - _ (/////directive.lift_generation - (define_program archive module_id generate program programS))] - (wrap /////directive.no_requirements)) - - _ - (phase.throw ///.invalid_syntax [extension_name %.code inputsC+])))) - -(def: (bundle::def expander host_analysis program anchorT,expressionT,directiveT extender) - (All [anchor expression directive] - (-> Expander - /////analysis.Bundle - (Program expression directive) - [Type Type Type] - Extender - (Bundle anchor expression directive))) - (<| (///bundle.prefix "def") - (|> ///bundle.empty - (dictionary.put "module" def::module) - (dictionary.put "alias" def::alias) - (dictionary.put "type tagged" (def::type_tagged expander host_analysis)) - (dictionary.put "analysis" (def::analysis anchorT,expressionT,directiveT extender)) - (dictionary.put "synthesis" (def::synthesis anchorT,expressionT,directiveT extender)) - (dictionary.put "generation" (def::generation anchorT,expressionT,directiveT extender)) - (dictionary.put "directive" (def::directive anchorT,expressionT,directiveT extender)) - (dictionary.put "program" (def::program program)) - ))) - -(def: #export (bundle expander host_analysis program anchorT,expressionT,directiveT extender) - (All [anchor expression directive] - (-> Expander - /////analysis.Bundle - (Program expression directive) - [Type Type Type] - Extender - (Bundle anchor expression directive))) - (<| (///bundle.prefix "lux") - (|> ///bundle.empty - (dictionary.put "def" (lux::def expander host_analysis)) - (dictionary.merge (..bundle::def expander host_analysis program anchorT,expressionT,directiveT extender))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux deleted file mode 100644 index dc81d4b18..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [common_lisp - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux deleted file mode 100644 index d1ad7bd99..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux +++ /dev/null @@ -1,179 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." set] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" common_lisp (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" common_lisp #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." case]]] - [// - ["." synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -(template: (!unary function) - (|>> list _.apply/* (|> (_.constant function)))) - -## ## TODO: Get rid of this ASAP -## (def: lux::syntax_char_case! -## (..custom [($_ <>.and -## <s>.any -## <s>.any -## (<>.some (<s>.tuple ($_ <>.and -## (<s>.tuple (<>.many <s>.i64)) -## <s>.any)))) -## (function (_ extension_name phase archive [input else conditionals]) -## (do {! /////.monad} -## [@input (\ ! map _.var (generation.gensym "input")) -## inputG (phase archive input) -## elseG (phase archive else) -## conditionalsG (: (Operation (List [Expression Expression])) -## (monad.map ! (function (_ [chars branch]) -## (do ! -## [branchG (phase archive branch)] -## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) -## branchG]))) -## conditionals))] -## (wrap (_.let (list [@input inputG]) -## (list (list\fold (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.uncurry //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 (|>> _.code-char/1 _.string/1))) - ))) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - ## (/.install "=" (binary (product.uncurry _.=/2))) - ## (/.install "<" (binary (product.uncurry _.</2))) - ## (/.install "+" (binary (product.uncurry _.+/2))) - ## (/.install "-" (binary (product.uncurry _.-/2))) - ## (/.install "*" (binary (product.uncurry _.*/2))) - ## (/.install "/" (binary (product.uncurry _.//2))) - ## (/.install "%" (binary (product.uncurry _.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.uncurry _.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: #export bundle - Bundle - (<| (/.prefix "lux") - (|> /.empty - (dictionary.merge lux_procs) - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux deleted file mode 100644 index f6d164404..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" common_lisp (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" common_lisp #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: #export bundle - Bundle - (<| (/.prefix "common_lisp") - (|> /.empty - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux deleted file mode 100644 index 81d2fe57b..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [js - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux deleted file mode 100644 index deffe31d8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux +++ /dev/null @@ -1,190 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - [collection - ["." list ("#\." functor)] - ["." dictionary]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" js (#+ Literal Expression Statement)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" js #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." primitive]]] - [// - [synthesis (#+ %synthesis)] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -## [Procedures] -## [[Bits]] -(template [<name> <op>] - [(def: (<name> [paramG subjectG]) - (Binary Expression) - (<op> subjectG (//runtime.i64//to_number paramG)))] - - [i64//left_shift //runtime.i64//left_shift] - [i64//right_shift //runtime.i64//right_shift] - ) - -## [[Numbers]] -(def: f64//decode - (Unary Expression) - (|>> list - (_.apply/* (_.var "parseFloat")) - _.return - (_.closure (list)) - //runtime.lux//try)) - -(def: i64//char - (Unary Expression) - (|>> //runtime.i64//to_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) - ($_ _., - (//runtime.io//log messageG) - //runtime.unit)) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [inputG (phase archive input) - elseG (phase archive else) - conditionalsG (: (Operation (List [(List Literal) - Statement])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(list\map (|>> .int _.int) chars) - (_.return branchG)]))) - conditionals))] - (wrap (_.apply/* (_.closure (list) - (_.switch (_.the //runtime.i64_low_field inputG) - conditionalsG - (#.Some (_.return elseG)))) - (list)))))])) - -## [Bundles] -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurry _.=))) - (/.install "try" (unary //runtime.lux//try)))) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurry //runtime.i64//and))) - (/.install "or" (binary (product.uncurry //runtime.i64//or))) - (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) - (/.install "left-shift" (binary i64//left_shift)) - (/.install "right-shift" (binary i64//right_shift)) - (/.install "=" (binary (product.uncurry //runtime.i64//=))) - (/.install "<" (binary (product.uncurry //runtime.i64//<))) - (/.install "+" (binary (product.uncurry //runtime.i64//+))) - (/.install "-" (binary (product.uncurry //runtime.i64//-))) - (/.install "*" (binary (product.uncurry //runtime.i64//*))) - (/.install "/" (binary (product.uncurry //runtime.i64///))) - (/.install "%" (binary (product.uncurry //runtime.i64//%))) - (/.install "f64" (unary //runtime.i64//to_number)) - (/.install "char" (unary i64//char)) - ))) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry _./))) - (/.install "%" (binary (product.uncurry _.%))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "i64" (unary //runtime.i64//from_number)) - (/.install "encode" (unary (_.do "toString" (list)))) - (/.install "decode" (unary f64//decode))))) - -(def: text_procs - Bundle - (<| (/.prefix "text") - (|> /.empty - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary text//concat)) - (/.install "index" (trinary text//index)) - (/.install "size" (unary (|>> (_.the "length") //runtime.i64//from_number))) - (/.install "char" (binary (product.uncurry //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: #export bundle - Bundle - (<| (/.prefix "lux") - (|> lux_procs - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux deleted file mode 100644 index 45fb3e5d2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux +++ /dev/null @@ -1,159 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]]] - [target - ["_" js (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" js #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: array::new - (Unary Expression) - (|>> (_.the //runtime.i64_low_field) list (_.new (_.var "Array")))) - -(def: array::length - (Unary Expression) - (|>> (_.the "length") //runtime.i64//from_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 - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [constructorS inputsS]) - (do {! ////////phase.monad} - [constructorG (phase archive constructorS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.new constructorG inputsG))))])) - -(def: object::get - Handler - (custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(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) - (\ ////////phase.monad wrap (_.var name)))])) - -(def: js::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* abstractionG inputsG))))])) - -(def: js::function - (custom - [($_ <>.and <s>.i64 <s>.any) - (function (_ extension phase archive [arity abstractionS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - #let [variable (: (-> Text (Operation Var)) - (|>> generation.gensym - (\ ! map _.var)))] - g!inputs (monad.map ! (function (_ _) (variable "input")) - (list.repeat (.nat arity) [])) - g!abstraction (variable "abstraction")] - (wrap (_.closure g!inputs - ($_ _.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: #export bundle - Bundle - (<| (/.prefix "js") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..object) - - (/.install "constant" js::constant) - (/.install "apply" js::apply) - (/.install "type-of" (unary _.type_of)) - (/.install "function" js::function) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux deleted file mode 100644 index 93816d128..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux +++ /dev/null @@ -1,19 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [jvm - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - ($_ dictionary.merge - /common.bundle - /host.bundle - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux deleted file mode 100644 index 24f82d1ef..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux +++ /dev/null @@ -1,413 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - [number - ["." i32] - ["f" frac]] - [collection - ["." list ("#\." monad)] - ["." dictionary]]] - [target - [jvm - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - [encoding - ["." signed (#+ S4)]] - ["." type (#+ Type) - [category (#+ Primitive Class)]]]]] - ["." ///// #_ - [generation - [extension (#+ Nullary Unary Binary Trinary Variadic - nullary unary binary trinary variadic)] - ["///" jvm #_ - ["#." value] - ["#." runtime (#+ Operation Phase Bundle Handler)] - ["#." function #_ - ["#" abstract]]]] - [extension - ["#extension" /] - ["#." bundle]] - [// - ["/#." synthesis (#+ Synthesis %synthesis)] - [/// - ["#" phase] - [meta - [archive (#+ Archive)]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase Archive s (Operation (Bytecode Any)))] - Handler)) - (function (_ extension-name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension-name phase archive input') - - (#try.Failure error) - (/////.throw /////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) - ($_ _.compose - _.i2l - (///value.wrap type.long))) - -(def: jvm-int - (Bytecode Any) - ($_ _.compose - (///value.unwrap type.long) - _.l2i)) - -(def: ensure-string - (Bytecode Any) - (_.checkcast $String)) - -(def: (predicate bytecode) - (-> (-> Label (Bytecode Any)) - (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - (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 [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension-name phase archive [inputS elseS conditionalsS]) - (do {! /////.monad} - [@end ///runtime.forge-label - inputG (phase archive inputS) - elseG (phase archive elseS) - conditionalsG+ (: (Operation (List [(List [S4 Label]) - (Bytecode Any)])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch) - @branch ///runtime.forge-label] - (wrap [(list\map (function (_ char) - [(try.assume (signed.s4 (.int char))) @branch]) - chars) - ($_ _.compose - (_.set-label @branch) - branchG - (_.goto @end))]))) - conditionalsS)) - #let [table (|> conditionalsG+ - (list\map product.left) - list\join) - conditionalsG (|> conditionalsG+ - (list\map product.right) - (monad.seq _.monad))]] - (wrap (do _.monad - [@else _.new-label] - ($_ _.compose - inputG (///value.unwrap type.long) _.l2i - (_.lookupswitch @else table) - conditionalsG - (_.set-label @else) - elseG - (_.set-label @end) - )))))])) - -(def: (lux::is [referenceG sampleG]) - (Binary (Bytecode Any)) - ($_ _.compose - referenceG - sampleG - (..predicate _.if-acmpeq))) - -(def: (lux::try riskyG) - (Unary (Bytecode Any)) - ($_ _.compose - riskyG - (_.checkcast ///function.class) - ///runtime.try)) - -(def: bundle::lux - Bundle - (|> (: Bundle /////bundle.empty) - (/////bundle.install "syntax char case!" ..lux::syntax-char-case!) - (/////bundle.install "is" (binary ..lux::is)) - (/////bundle.install "try" (unary ..lux::try)))) - -(template [<name> <op>] - [(def: (<name> [maskG inputG]) - (Binary (Bytecode Any)) - ($_ _.compose - inputG (///value.unwrap type.long) - maskG (///value.unwrap type.long) - <op> (///value.wrap type.long)))] - - [i64::and _.land] - [i64::or _.lor] - [i64::xor _.lxor] - ) - -(template [<name> <op>] - [(def: (<name> [shiftG inputG]) - (Binary (Bytecode Any)) - ($_ _.compose - inputG (///value.unwrap type.long) - shiftG ..jvm-int - <op> (///value.wrap type.long)))] - - [i64::left-shift _.lshl] - [i64::right-shift _.lushr] - ) - -(template [<name> <type> <op>] - [(def: (<name> [paramG subjectG]) - (Binary (Bytecode Any)) - ($_ _.compose - 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] - ) - -(template [<eq> <lt> <type> <cmp>] - [(template [<name> <reference>] - [(def: (<name> [paramG subjectG]) - (Binary (Bytecode Any)) - ($_ _.compose - 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: (to-string class from) - (-> (Type Class) (Type Primitive) (Bytecode Any)) - (_.invokestatic class "toString" (type.method [(list from) ..$String (list)]))) - -(template [<name> <prepare> <transform>] - [(def: (<name> inputG) - (Unary (Bytecode Any)) - ($_ _.compose - inputG - <prepare> - <transform>))] - - [i64::f64 - (///value.unwrap type.long) - ($_ _.compose - _.l2d - (///value.wrap type.double))] - - [i64::char - (///value.unwrap type.long) - ($_ _.compose - _.l2i - _.i2c - (..to-string ..$Character type.char))] - - [f64::i64 - (///value.unwrap type.double) - ($_ _.compose - _.d2l - (///value.wrap type.long))] - - [f64::encode - (///value.unwrap type.double) - (..to-string ..$Double type.double)] - - [f64::decode - ..ensure-string - ///runtime.decode-frac] - ) - -(def: bundle::i64 - Bundle - (<| (/////bundle.prefix "i64") - (|> (: 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-shift)) - (/////bundle.install "right-shift" (binary ..i64::right-shift)) - (/////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") - (|> (: 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)) - ($_ _.compose - inputG - ..ensure-string - (_.invokevirtual ..$String "length" (type.method [(list) type.int (list)])) - ..lux-int)) - -(def: no-op (Bytecode Any) (_\wrap [])) - -(template [<name> <pre-subject> <pre-param> <op> <post>] - [(def: (<name> [paramG subjectG]) - (Binary (Bytecode Any)) - ($_ _.compose - subjectG <pre-subject> - paramG <pre-param> - <op> <post>))] - - [text::= ..no-op ..no-op - (_.invokevirtual ..$Object "equals" (type.method [(list ..$Object) type.boolean (list)])) - (///value.wrap type.boolean)] - [text::< ..ensure-string ..ensure-string - (_.invokevirtual ..$String "compareTo" (type.method [(list ..$String) type.int (list)])) - (..predicate _.iflt)] - [text::char ..ensure-string ..jvm-int - (_.invokevirtual ..$String "charAt" (type.method [(list type.int) type.char (list)])) - ..lux-int] - ) - -(def: (text::concat [leftG rightG]) - (Binary (Bytecode Any)) - ($_ _.compose - leftG ..ensure-string - rightG ..ensure-string - (_.invokevirtual ..$String "concat" (type.method [(list ..$String) ..$String (list)])))) - -(def: (text::clip [startG endG subjectG]) - (Trinary (Bytecode Any)) - ($_ _.compose - subjectG ..ensure-string - startG ..jvm-int - endG ..jvm-int - (_.invokevirtual ..$String "substring" (type.method [(list type.int type.int) ..$String (list)])))) - -(def: index-method (type.method [(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] - ($_ _.compose - textG ..ensure-string - partG ..ensure-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") - (|> (: 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 ..$String) type.void (list)])) -(def: (io::log messageG) - (Unary (Bytecode Any)) - ($_ _.compose - (_.getstatic ..$System "out" ..$PrintStream) - messageG - ..ensure-string - (_.invokevirtual ..$PrintStream "println" ..string-method) - ///runtime.unit)) - -(def: (io::error messageG) - (Unary (Bytecode Any)) - ($_ _.compose - (_.new ..$Error) - _.dup - messageG - ..ensure-string - (_.invokespecial ..$Error "<init>" ..string-method) - _.athrow)) - -(def: bundle::io - Bundle - (<| (/////bundle.prefix "io") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "log" (unary ..io::log)) - (/////bundle.install "error" (unary ..io::error))))) - -(def: #export bundle - Bundle - (<| (/////bundle.prefix "lux") - (|> bundle::lux - (dictionary.merge ..bundle::i64) - (dictionary.merge ..bundle::f64) - (dictionary.merge ..bundle::text) - (dictionary.merge ..bundle::io)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux deleted file mode 100644 index 03ec04853..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux +++ /dev/null @@ -1,1105 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [control - ["." try] - ["." exception (#+ exception:)] - ["<>" parser - ["<t>" text] - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." maybe] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [number - ["." i32]] - [collection - ["." list ("#\." monad)] - ["." dictionary (#+ Dictionary)] - ["." set] - ["." row]] - ["." format #_ - ["#" binary]]] - [target - [jvm - ["." version] - ["." modifier ("#\." monoid)] - ["." method (#+ Method)] - ["." class (#+ Class)] - [constant - [pool (#+ Resource)]] - [encoding - ["." name]] - ["_" bytecode (#+ Label Bytecode) ("#\." monad) - ["__" instruction (#+ Primitive-Array-Type)]] - ["." type (#+ Type Typed Argument) - ["." category (#+ Void Value' Value Return' Return Primitive Object Array Var Parameter)] - ["." box] - ["." reflection] - ["." signature] - ["." parser]]]]] - ["." // #_ - [common (#+ custom)] - ["///#" //// #_ - [generation - [extension (#+ Nullary Unary Binary Trinary Variadic - nullary unary binary trinary variadic)] - ["///" jvm - ["#." runtime (#+ Operation Bundle Phase Handler)] - ["#." reference] - [function - [field - [variable - ["." foreign]]]]]] - [extension - ["#." bundle] - [analysis - ["/" jvm]]] - ["/#" // #_ - [analysis (#+ Environment)] - ["#." synthesis (#+ Synthesis Path %synthesis)] - ["#." generation] - [/// - ["#" phase] - [reference - ["#." variable (#+ Variable)]] - [meta - ["." archive (#+ Archive)]]]]]]) - -(template [<name> <0> <1>] - [(def: <name> - (Bytecode Any) - ($_ _.compose - <0> - <1>))] - - [l2s _.l2i _.i2s] - [l2b _.l2i _.i2b] - [l2c _.l2i _.i2c] - ) - -(template [<conversion> <name>] - [(def: (<name> inputG) - (Unary (Bytecode Any)) - (if (is? _.nop <conversion>) - inputG - ($_ _.compose - 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") - (|> (: 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)) - ))) - -(template [<name> <op>] - [(def: (<name> [xG yG]) - (Binary (Bytecode Any)) - ($_ _.compose - xG - yG - <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)) - -(template [<name> <op>] - [(def: (<name> [xG yG]) - (Binary (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - xG - yG - (<op> @then) - falseG - (_.goto @end) - (_.set-label @then) - trueG - (_.set-label @end))))] - - [int::= _.if-icmpeq] - [int::< _.if-icmplt] - - [char::= _.if-icmpeq] - [char::< _.if-icmplt] - ) - -(template [<name> <op> <reference>] - [(def: (<name> [xG yG]) - (Binary (Bytecode Any)) - (do _.monad - [@then _.new-label - @end _.new-label] - ($_ _.compose - xG - yG - <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)) - (|> (: 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)) - (|> (: 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)) - (|> (: 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)) - (|> (: 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)) - (|> (: Bundle /////bundle.empty) - (/////bundle.install "=" (binary char::=)) - (/////bundle.install "<" (binary char::<)) - ))) - -(template [<name> <category> <parser>] - [(def: #export <name> - (Parser (Type <category>)) - (<t>.embed <parser> <s>.text))] - - [var Var parser.var] - [class category.Class parser.class] - [object Object parser.object] - [value Value parser.value] - [return Return parser.return] - ) - -(exception: #export (not-an-object-array {arrayJT (Type Array)}) - (exception.report - ["JVM Type" (|> arrayJT type.signature signature.signature)])) - -(def: #export object-array - (Parser (Type Object)) - (do <>.monad - [arrayJT (<t>.embed parser.array <s>.text)] - (case (parser.array? arrayJT) - (#.Some elementJT) - (case (parser.object? elementJT) - (#.Some elementJT) - (wrap elementJT) - - #.None - (<>.fail (exception.construct ..not-an-object-array arrayJT))) - - #.None - (undefined)))) - -(def: (primitive-array-length-handler jvm-primitive) - (-> (Type Primitive) Handler) - (..custom - [<s>.any - (function (_ extension-name generate archive arrayS) - (do //////.monad - [arrayG (generate archive arrayS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array jvm-primitive)) - _.arraylength))))])) - -(def: array::length::object - Handler - (..custom - [($_ <>.and ..object-array <s>.any) - (function (_ extension-name generate archive [elementJT arrayS]) - (do //////.monad - [arrayG (generate archive arrayS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array elementJT)) - _.arraylength))))])) - -(def: (new-primitive-array-handler jvm-primitive) - (-> Primitive-Array-Type Handler) - (..custom - [<s>.any - (function (_ extension-name generate archive [lengthS]) - (do //////.monad - [lengthG (generate archive lengthS)] - (wrap ($_ _.compose - lengthG - (_.newarray jvm-primitive)))))])) - -(def: array::new::object - Handler - (..custom - [($_ <>.and ..object <s>.any) - (function (_ extension-name generate archive [objectJT lengthS]) - (do //////.monad - [lengthG (generate archive lengthS)] - (wrap ($_ _.compose - lengthG - (_.anewarray objectJT)))))])) - -(def: (read-primitive-array-handler jvm-primitive loadG) - (-> (Type Primitive) (Bytecode Any) Handler) - (..custom - [($_ <>.and <s>.any <s>.any) - (function (_ extension-name generate archive [idxS arrayS]) - (do //////.monad - [arrayG (generate archive arrayS) - idxG (generate archive idxS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array jvm-primitive)) - idxG - loadG))))])) - -(def: array::read::object - Handler - (..custom - [($_ <>.and ..object-array <s>.any <s>.any) - (function (_ extension-name generate archive [elementJT idxS arrayS]) - (do //////.monad - [arrayG (generate archive arrayS) - idxG (generate archive idxS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array elementJT)) - idxG - _.aaload))))])) - -(def: (write-primitive-array-handler jvm-primitive storeG) - (-> (Type Primitive) (Bytecode Any) Handler) - (..custom - [($_ <>.and <s>.any <s>.any <s>.any) - (function (_ extension-name generate archive [idxS valueS arrayS]) - (do //////.monad - [arrayG (generate archive arrayS) - idxG (generate archive idxS) - valueG (generate archive valueS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array jvm-primitive)) - _.dup - idxG - valueG - storeG))))])) - -(def: array::write::object - Handler - (..custom - [($_ <>.and ..object-array <s>.any <s>.any <s>.any) - (function (_ extension-name generate archive [elementJT idxS valueS arrayS]) - (do //////.monad - [arrayG (generate archive arrayS) - idxG (generate archive idxS) - valueG (generate archive valueS)] - (wrap ($_ _.compose - arrayG - (_.checkcast (type.array elementJT)) - _.dup - idxG - valueG - _.aastore))))])) - -(def: bundle::array - Bundle - (<| (/////bundle.prefix "array") - (|> /////bundle.empty - (dictionary.merge (<| (/////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.merge (<| (/////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.merge (<| (/////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.merge (<| (/////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] - ($_ _.compose - objectG - (_.ifnull @then) - ..falseG - (_.goto @end) - (_.set-label @then) - ..trueG - (_.set-label @end)))) - -(def: (object::synchronized [monitorG exprG]) - (Binary (Bytecode Any)) - ($_ _.compose - monitorG - _.dup - _.monitorenter - exprG - _.swap - _.monitorexit)) - -(def: (object::throw exceptionG) - (Unary (Bytecode Any)) - ($_ _.compose - exceptionG - _.athrow)) - -(def: $Class (type.class "java.lang.Class" (list))) -(def: $String (type.class "java.lang.String" (list))) - -(def: object::class - Handler - (..custom - [<s>.text - (function (_ extension-name generate archive [class]) - (do //////.monad - [] - (wrap ($_ _.compose - (_.string class) - (_.invokestatic ..$Class "forName" (type.method [(list ..$String) ..$Class (list)]))))))])) - -(def: object::instance? - Handler - (..custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension-name generate archive [class objectS]) - (do //////.monad - [objectG (generate archive objectS)] - (wrap ($_ _.compose - objectG - (_.instanceof (type.class class (list))) - (_.invokestatic ..$Boolean "valueOf" (type.method [(list type.boolean) ..$Boolean (list)]))))))])) - -(def: reflection - (All [category] - (-> (Type (<| Return' Value' category)) Text)) - (|>> type.reflection reflection.reflection)) - -(def: object::cast - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.any) - (function (_ extension-name generate archive [from to valueS]) - (do //////.monad - [valueG (generate archive valueS)] - (wrap (`` (cond (~~ (template [<object> <type> <unwrap>] - [(and (text\= (..reflection <type>) - from) - (text\= <object> - to)) - (let [$<object> (type.class <object> (list))] - ($_ _.compose - valueG - (_.invokestatic $<object> "valueOf" (type.method [(list <type>) $<object> (list)])))) - - (and (text\= <object> - from) - (text\= (..reflection <type>) - to)) - (let [$<object> (type.class <object> (list))] - ($_ _.compose - valueG - (_.checkcast $<object>) - (_.invokevirtual $<object> <unwrap> (type.method [(list) <type> (list)]))))] - - [box.boolean type.boolean "booleanValue"] - [box.byte type.byte "byteValue"] - [box.short type.short "shortValue"] - [box.int type.int "intValue"] - [box.long type.long "longValue"] - [box.float type.float "floatValue"] - [box.double type.double "doubleValue"] - [box.char type.char "charValue"])) - ## else - valueG)))))])) - -(def: bundle::object - Bundle - (<| (/////bundle.prefix "object") - (|> (: 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: primitives - (Dictionary Text (Type Primitive)) - (|> (list [(reflection.reflection reflection.boolean) type.boolean] - [(reflection.reflection reflection.byte) type.byte] - [(reflection.reflection reflection.short) type.short] - [(reflection.reflection reflection.int) type.int] - [(reflection.reflection reflection.long) type.long] - [(reflection.reflection reflection.float) type.float] - [(reflection.reflection reflection.double) type.double] - [(reflection.reflection reflection.char) type.char]) - (dictionary.from-list text.hash))) - -(def: get::static - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text) - (function (_ extension-name generate archive [class field unboxed]) - (do //////.monad - [#let [$class (type.class class (list))]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap (_.getstatic $class field primitive)) - - #.None - (wrap (_.getstatic $class field (type.class unboxed (list)))))))])) - -(def: unitG (_.string //////synthesis.unit)) - -(def: put::static - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) - (function (_ extension-name generate archive [class field unboxed valueS]) - (do //////.monad - [valueG (generate archive valueS) - #let [$class (type.class class (list))]] - (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (wrap ($_ _.compose - valueG - (_.putstatic $class field primitive) - ..unitG)) - - #.None - (wrap ($_ _.compose - valueG - (_.checkcast $class) - (_.putstatic $class field $class) - ..unitG)))))])) - -(def: get::virtual - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any) - (function (_ extension-name generate archive [class field unboxed objectS]) - (do //////.monad - [objectG (generate archive objectS) - #let [$class (type.class class (list)) - getG (case (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.getfield $class field primitive) - - #.None - (_.getfield $class field (type.class unboxed (list))))]] - (wrap ($_ _.compose - objectG - (_.checkcast $class) - getG))))])) - -(def: put::virtual - Handler - (..custom - [($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.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 (dictionary.get unboxed ..primitives) - (#.Some primitive) - (_.putfield $class field primitive) - - #.None - (let [$unboxed (type.class unboxed (list))] - ($_ _.compose - (_.checkcast $unboxed) - (_.putfield $class field $unboxed))))]] - (wrap ($_ _.compose - objectG - (_.checkcast $class) - _.dup - valueG - putG))))])) - -(type: Input (Typed Synthesis)) - -(def: input - (Parser Input) - (<s>.tuple (<>.and ..value <s>.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) - (wrap [valueT valueG]) - - (#.Left valueT) - (wrap [valueT ($_ _.compose - valueG - (_.checkcast valueT))])))) - -(def: (prepare-output outputT) - (-> (Type Return) (Bytecode Any)) - (case (type.void? outputT) - (#.Right outputT) - ..unitG - - (#.Left outputT) - (\ _.monad wrap []))) - -(def: invoke::static - Handler - (..custom - [($_ <>.and ..class <s>.text ..return (<>.some ..input)) - (function (_ extension-name generate archive [class method outputT inputsTS]) - (do {! //////.monad} - [inputsTG (monad.map ! (generate-input generate archive) inputsTS)] - (wrap ($_ _.compose - (monad.map _.monad product.right inputsTG) - (_.invokestatic class method (type.method [(list\map product.left inputsTG) outputT (list)])) - (prepare-output outputT)))))])) - -(template [<name> <invoke>] - [(def: <name> - Handler - (..custom - [($_ <>.and ..class <s>.text ..return <s>.any (<>.some ..input)) - (function (_ extension-name generate archive [class method outputT objectS inputsTS]) - (do {! //////.monad} - [objectG (generate archive objectS) - inputsTG (monad.map ! (generate-input generate archive) inputsTS)] - (wrap ($_ _.compose - objectG - (_.checkcast class) - (monad.map _.monad product.right inputsTG) - (<invoke> class method (type.method [(list\map product.left inputsTG) outputT (list)])) - (prepare-output outputT)))))]))] - - [invoke::virtual _.invokevirtual] - [invoke::special _.invokespecial] - [invoke::interface _.invokeinterface] - ) - -(def: invoke::constructor - Handler - (..custom - [($_ <>.and ..class (<>.some ..input)) - (function (_ extension-name generate archive [class inputsTS]) - (do {! //////.monad} - [inputsTG (monad.map ! (generate-input generate archive) inputsTS)] - (wrap ($_ _.compose - (_.new class) - _.dup - (monad.map _.monad product.right inputsTG) - (_.invokespecial class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)]))))))])) - -(def: bundle::member - Bundle - (<| (/////bundle.prefix "member") - (|> (: Bundle /////bundle.empty) - (dictionary.merge (<| (/////bundle.prefix "get") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "static" get::static) - (/////bundle.install "virtual" get::virtual)))) - (dictionary.merge (<| (/////bundle.prefix "put") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "static" put::static) - (/////bundle.install "virtual" put::virtual)))) - (dictionary.merge (<| (/////bundle.prefix "invoke") - (|> (: 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)) - (<s>.tuple (<>.and <s>.text <s>.any))) - -(def: annotation - (Parser (/.Annotation Synthesis)) - (<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter)))) - -(def: argument - (Parser Argument) - (<s>.tuple (<>.and <s>.text ..value))) - -(def: overriden-method-definition - (Parser [(Environment Synthesis) (/.Overriden-Method Synthesis)]) - (<s>.tuple (do <>.monad - [_ (<s>.text! /.overriden-tag) - ownerT ..class - name <s>.text - strict-fp? <s>.bit - annotations (<s>.tuple (<>.some ..annotation)) - vars (<s>.tuple (<>.some ..var)) - self-name <s>.text - arguments (<s>.tuple (<>.some ..argument)) - returnT ..return - exceptionsT (<s>.tuple (<>.some ..class)) - [environment body] (<s>.function 1 - (<s>.tuple <s>.any))] - (wrap [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]])))) - -(def: (normalize-path normalize) - (-> (-> Synthesis Synthesis) - (-> Path Path)) - (function (recur path) - (case path - (^ (//////synthesis.path/then bodyS)) - (//////synthesis.path/then (normalize bodyS)) - - (^template [<tag>] - [(^ (<tag> leftP rightP)) - (<tag> (recur leftP) (recur rightP))]) - ([#//////synthesis.Alt] - [#//////synthesis.Seq]) - - (^template [<tag>] - [(^ (<tag> value)) - path]) - ([#//////synthesis.Pop] - [#//////synthesis.Bind] - [#//////synthesis.Access]) - - _ - (undefined)))) - -(def: (normalize-method-body mapping) - (-> (Dictionary Variable Variable) Synthesis Synthesis) - (function (recur body) - (case body - (^template [<tag>] - [(^ (<tag> value)) - body]) - ([#//////synthesis.Primitive] - [//////synthesis.constant]) - - (^ (//////synthesis.variant [lefts right? sub])) - (//////synthesis.variant [lefts right? (recur sub)]) - - (^ (//////synthesis.tuple members)) - (//////synthesis.tuple (list\map recur members)) - - (^ (//////synthesis.variable var)) - (|> mapping - (dictionary.get var) - (maybe.default var) - //////synthesis.variable) - - (^ (//////synthesis.branch/case [inputS pathS])) - (//////synthesis.branch/case [(recur inputS) (normalize-path recur pathS)]) - - (^ (//////synthesis.branch/let [inputS register outputS])) - (//////synthesis.branch/let [(recur inputS) register (recur outputS)]) - - (^ (//////synthesis.branch/if [testS thenS elseS])) - (//////synthesis.branch/if [(recur testS) (recur thenS) (recur elseS)]) - - (^ (//////synthesis.branch/get [path recordS])) - (//////synthesis.branch/get [path (recur recordS)]) - - (^ (//////synthesis.loop/scope [offset initsS+ bodyS])) - (//////synthesis.loop/scope [offset (list\map recur initsS+) (recur bodyS)]) - - (^ (//////synthesis.loop/recur updatesS+)) - (//////synthesis.loop/recur (list\map recur updatesS+)) - - (^ (//////synthesis.function/abstraction [environment arity bodyS])) - (//////synthesis.function/abstraction [(list\map (function (_ local) - (case local - (^ (//////synthesis.variable local)) - (|> mapping - (dictionary.get local) - (maybe.default local) - //////synthesis.variable) - - _ - local)) - environment) - arity - bodyS]) - - (^ (//////synthesis.function/apply [functionS inputsS+])) - (//////synthesis.function/apply [(recur functionS) (list\map recur inputsS+)]) - - (#//////synthesis.Extension [name inputsS+]) - (#//////synthesis.Extension [name (list\map recur inputsS+)])))) - -(def: $Object (type.class "java.lang.Object" (list))) - -(def: (anonymous-init-method env) - (-> (Environment Synthesis) (Type category.Method)) - (type.method [(list.repeat (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 [store-capturedG (|> env - list.size - list.indices - (monad.map _.monad (.function (_ register) - ($_ _.compose - (_.aload 0) - (_.aload (inc register)) - (_.putfield class (///reference.foreign-name register) $Object)))))] - (method.method method.public "<init>" (anonymous-init-method env) - (list) - (#.Some ($_ _.compose - (_.aload 0) - (monad.map _.monad product.right inputsTG) - (_.invokespecial super-class "<init>" (type.method [(list\map product.left inputsTG) type.void (list)])) - store-capturedG - _.return))))) - -(def: (anonymous-instance generate archive class env) - (-> Phase Archive (Type category.Class) (Environment Synthesis) (Operation (Bytecode Any))) - (do {! //////.monad} - [captureG+ (monad.map ! (generate archive) env)] - (wrap ($_ _.compose - (_.new class) - _.dup - (monad.seq _.monad captureG+) - (_.invokespecial class "<init>" (anonymous-init-method env)))))) - -(def: (returnG returnT) - (-> (Type Return) (Bytecode Any)) - (case (type.void? returnT) - (#.Right returnT) - _.return - - (#.Left returnT) - (case (type.primitive? returnT) - (#.Left returnT) - ($_ _.compose - (_.checkcast returnT) - _.areturn) - - (#.Right returnT) - (cond (or (\ type.equivalence = type.boolean returnT) - (\ type.equivalence = type.byte returnT) - (\ type.equivalence = type.short returnT) - (\ type.equivalence = type.int returnT) - (\ type.equivalence = type.char returnT)) - _.ireturn - - (\ type.equivalence = type.long returnT) - _.lreturn - - (\ type.equivalence = type.float returnT) - _.freturn - - ## (\ type.equivalence = type.double returnT) - _.dreturn)))) - -(def: class::anonymous - Handler - (..custom - [($_ <>.and - ..class - (<s>.tuple (<>.some ..class)) - (<s>.tuple (<>.some ..input)) - (<s>.tuple (<>.some ..overriden-method-definition))) - (function (_ extension-name generate archive [super-class super-interfaces - inputsTS - overriden-methods]) - (do {! //////.monad} - [[context _] (//////generation.with-new-context archive (wrap [])) - #let [[module-id artifact-id] context - anonymous-class-name (///runtime.class-name context) - class (type.class anonymous-class-name (list)) - total-environment (|> overriden-methods - ## Get all the environments. - (list\map product.left) - ## Combine them. - list\join - ## Remove duplicates. - (set.from-list //////synthesis.hash) - set.to-list) - global-mapping (|> total-environment - ## Give them names as "foreign" variables. - list.enumeration - (list\map (function (_ [id capture]) - [capture (#//////variable.Foreign id)])) - (dictionary.from-list //////variable.hash)) - normalized-methods (list\map (function (_ [environment - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - body]]) - (let [local-mapping (|> environment - list.enumeration - (list\map (function (_ [foreign-id capture]) - [(#//////variable.Foreign foreign-id) - (|> global-mapping - (dictionary.get capture) - maybe.assume)])) - (dictionary.from-list //////variable.hash))] - [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - (normalize-method-body local-mapping body)])) - overriden-methods)] - inputsTI (monad.map ! (generate-input generate archive) inputsTS) - method-definitions (monad.map ! (function (_ [ownerT name - strict-fp? annotations vars - self-name arguments returnT exceptionsT - bodyS]) - (do ! - [bodyG (//////generation.with-context artifact-id - (generate archive bodyS))] - (wrap (method.method ($_ modifier\compose - method.public - method.final - (if strict-fp? - method.strict - modifier\identity)) - name - (type.method [(list\map product.right arguments) - returnT - exceptionsT]) - (list) - (#.Some ($_ _.compose - bodyG - (returnG returnT))))))) - normalized-methods) - bytecode (<| (\ ! map (format.run class.writer)) - //////.lift - (class.class version.v6_0 ($_ modifier\compose class.public class.final) - (name.internal anonymous-class-name) - (name.internal (..reflection super-class)) - (list\map (|>> ..reflection name.internal) super-interfaces) - (foreign.variables total-environment) - (list& (..with-anonymous-init class total-environment super-class inputsTI) - method-definitions) - (row.row))) - _ (//////generation.execute! [anonymous-class-name bytecode]) - _ (//////generation.save! (%.nat artifact-id) [anonymous-class-name bytecode])] - (anonymous-instance generate archive class total-environment)))])) - -(def: bundle::class - Bundle - (<| (/////bundle.prefix "class") - (|> (: Bundle /////bundle.empty) - (/////bundle.install "anonymous" class::anonymous) - ))) - -(def: #export bundle - Bundle - (<| (/////bundle.prefix "jvm") - (|> ..bundle::conversion - (dictionary.merge ..bundle::int) - (dictionary.merge ..bundle::long) - (dictionary.merge ..bundle::float) - (dictionary.merge ..bundle::double) - (dictionary.merge ..bundle::char) - (dictionary.merge ..bundle::array) - (dictionary.merge ..bundle::object) - (dictionary.merge ..bundle::member) - (dictionary.merge ..bundle::class) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux deleted file mode 100644 index ab0d0d555..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [lua - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux deleted file mode 100644 index b22dd6d53..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux +++ /dev/null @@ -1,180 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" lua (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" lua #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]] - [// - [synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -(template: (!unary function) - (|>> list _.apply/* (|> (_.var function)))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [inputG (phase archive input) - elseG (phase archive else) - @input (\ ! map _.var (generation.gensym "input")) - conditionalsG (: (Operation (List [Expression Expression])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars - (list\map (|>> .int _.int (_.= @input))) - (list\fold (function (_ clause total) - (if (is? _.nil total) - clause - (_.or clause total))) - _.nil)) - branchG]))) - conditionals)) - #let [closure (_.closure (list @input) - (list\fold (function (_ [test then] else) - (_.if test (_.return then) else)) - (_.return elseG) - conditionalsG))]] - (wrap (_.apply/1 closure inputG))))])) - -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurry _.=))) - (/.install "try" (unary //runtime.lux//try)))) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurry _.bit_and))) - (/.install "or" (binary (product.uncurry _.bit_or))) - (/.install "xor" (binary (product.uncurry _.bit_xor))) - (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) - (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry //runtime.i64//division))) - (/.install "%" (binary (product.uncurry //runtime.i64//remainder))) - (/.install "f64" (unary (_./ (_.float +1.0)))) - (/.install "char" (unary (_.apply/1 (_.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.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry _./))) - (/.install "%" (binary (product.uncurry (function.flip (_.apply/2 (_.var "math.fmod")))))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "i64" (unary (!unary "math.floor"))) - (/.install "encode" (unary (_.apply/2 (_.var "string.format") (_.string "%.17g")))) - (/.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.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary (product.uncurry (function.flip _.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: #export bundle - Bundle - (<| (/.prefix "lux") - (|> lux_procs - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux deleted file mode 100644 index c9c5acec8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux +++ /dev/null @@ -1,199 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" lua (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" lua #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: array::new - (Unary Expression) - (|>> ["n"] list _.table)) - -(def: array::length - (Unary Expression) - (_.the "n")) - -(def: (array::read [indexG arrayG]) - (Binary Expression) - (_.nth (_.+ (_.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 - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(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)] - (wrap (_.apply/1 (<| (_.closure (list $input)) - (_.return (|> (_.var "string.byte") - (_.apply/* (list $input (_.int +1) (_.length $input))) - (_.apply/1 (_.var "table.pack"))))) - inputG))))])) - -(def: utf8::decode - (custom - [<s>.any - (function (_ extension phase archive inputS) - (do {! ////////phase.monad} - [inputG (phase archive inputS)] - (wrap (|> inputG - (_.apply/1 (_.var "table.unpack")) - (_.apply/1 (_.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) - (\ ////////phase.monad wrap (_.var name)))])) - -(def: lua::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* inputsG abstractionG))))])) - -(def: lua::power - (custom - [($_ <>.and <s>.any <s>.any) - (function (_ extension phase archive [powerS baseS]) - (do {! ////////phase.monad} - [powerG (phase archive powerS) - baseG (phase archive baseS)] - (wrap (_.^ powerG baseG))))])) - -(def: lua::import - (custom - [<s>.text - (function (_ extension phase archive module) - (\ ////////phase.monad wrap - (_.require/1 (_.string module))))])) - -(def: lua::function - (custom - [($_ <>.and <s>.i64 <s>.any) - (function (_ extension phase archive [arity abstractionS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - #let [variable (: (-> Text (Operation Var)) - (|>> generation.gensym - (\ ! map _.var)))] - g!inputs (monad.map ! (function (_ _) - (variable "input")) - (list.repeat (.nat arity) []))] - (wrap (<| (_.closure g!inputs) - _.statement - (case (.nat arity) - 0 (_.apply/1 abstractionG //runtime.unit) - 1 (_.apply/* g!inputs abstractionG) - _ (_.apply/1 abstractionG (_.array g!inputs)))))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "lua") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..object) - (dictionary.merge ..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 (_.bool reference.universe)))) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux deleted file mode 100644 index 2f2d75c31..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [php - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux deleted file mode 100644 index ce4ab223c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux +++ /dev/null @@ -1,191 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." set] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" php (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" php #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." case]]] - [// - ["." synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -(template: (!unary function) - (|>> list _.apply/* (|> (_.constant function)))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.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 (\ ! map _.var (generation.gensym "input")) - conditionalsG (: (Operation (List [Expression Expression])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars - (list\map (|>> .int _.int (_.=== @input))) - (list\fold (function (_ clause total) - (if (is? _.null total) - clause - (_.or clause total))) - _.null)) - branchG]))) - conditionals)) - #let [foreigns (|> conditionals - (list\map (|>> product.right synthesis.path/then //case.dependencies)) - (list& (//case.dependencies (synthesis.path/then else))) - list.concat - (set.from_list _.hash) - set.to_list) - @expression (_.constant (reference.artifact [context_module context_artifact])) - directive (_.define_function @expression (list& (_.parameter @input) (list\map _.reference foreigns)) - (list\fold (function (_ [test then] else) - (_.if test (_.return then) else)) - (_.return elseG) - conditionalsG))] - _ (generation.execute! directive) - _ (generation.save! context_artifact directive)] - (wrap (_.apply/* (list& inputG foreigns) @expression))))])) - -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurry _.===))) - (/.install "try" (unary //runtime.lux//try)) - )) - -(def: (left_shift [parameter subject]) - (Binary Expression) - (_.bit_shl (_.% (_.int +64) parameter) subject)) - -(def: i64_procs - Bundle - (<| (/.prefix "i64") - (|> /.empty - (/.install "and" (binary (product.uncurry _.bit_and))) - (/.install "or" (binary (product.uncurry _.bit_or))) - (/.install "xor" (binary (product.uncurry _.bit_xor))) - (/.install "left-shift" (binary ..left_shift)) - (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - (/.install "=" (binary (product.uncurry _.==))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "+" (binary (product.uncurry //runtime.i64//+))) - (/.install "-" (binary (product.uncurry //runtime.i64//-))) - (/.install "*" (binary (product.uncurry //runtime.i64//*))) - (/.install "/" (binary (function (_ [parameter subject]) - (_.intdiv/2 [subject parameter])))) - (/.install "%" (binary (product.uncurry _.%))) - (/.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.uncurry _.==))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry _./))) - (/.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.uncurry _.==))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary (product.uncurry (function.flip _.concat)))) - (/.install "index" (trinary ..text//index)) - (/.install "size" (unary //runtime.text//size)) - (/.install "char" (binary (product.uncurry //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: #export bundle - Bundle - (<| (/.prefix "lux") - (|> /.empty - (dictionary.merge lux_procs) - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux deleted file mode 100644 index d93fd04ff..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux +++ /dev/null @@ -1,142 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" php (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" php #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." 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) - (_.nth 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 - [($_ <>.and <s>.text (<>.some <s>.any)) - (function (_ extension phase archive [constructor inputsS]) - (do {! ////////phase.monad} - [inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.new (_.constant constructor) inputsG))))])) - -(def: object::get - Handler - (custom - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(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) - (\ ////////phase.monad wrap (_.constant name)))])) - -(def: php::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* inputsG abstractionG))))])) - -(def: php::pack - (custom - [($_ <>.and <s>.any <s>.any) - (function (_ extension phase archive [formatS dataS]) - (do {! ////////phase.monad} - [formatG (phase archive formatS) - dataG (phase archive dataS)] - (wrap (_.pack/2 [formatG (_.splat dataG)]))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "php") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..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/lux/tool/compiler/language/lux/phase/extension/generation/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux deleted file mode 100644 index 5639551c6..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [python - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux deleted file mode 100644 index 61a154efc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux +++ /dev/null @@ -1,170 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - [target - ["_" python (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" python #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]] - [// - [synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [inputG (phase archive input) - elseG (phase archive else) - @input (\ ! map _.var (generation.gensym "input")) - conditionalsG (: (Operation (List [(Expression Any) - (Expression Any)])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars - (list\map (|>> .int _.int (_.= @input))) - (list\fold (function (_ clause total) - (if (is? _.none total) - clause - (_.or clause total))) - _.none)) - branchG]))) - conditionals)) - #let [closure (_.lambda (list @input) - (list\fold (function (_ [test then] else) - (_.? test then else)) - elseG - conditionalsG))]] - (wrap (_.apply/* closure (list inputG)))))])) - -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (product.uncurry _.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.uncurry //runtime.i64::and))) - (/.install "or" (binary (product.uncurry //runtime.i64::or))) - (/.install "xor" (binary (product.uncurry //runtime.i64::xor))) - (/.install "left-shift" (binary (product.uncurry //runtime.i64::left_shift))) - (/.install "right-shift" (binary (product.uncurry //runtime.i64::right_shift))) - - (/.install "<" (binary (product.uncurry _.<))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "+" (binary (product.uncurry (..capped _.+)))) - (/.install "-" (binary (product.uncurry (..capped _.-)))) - (/.install "*" (binary (product.uncurry (..capped _.*)))) - (/.install "/" (binary (product.uncurry //runtime.i64::division))) - (/.install "%" (binary (product.uncurry //runtime.i64::remainder))) - (/.install "f64" (unary _.float/1)) - (/.install "char" (unary //runtime.i64::char)) - ))) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry //runtime.f64::/))) - (/.install "%" (binary (function (_ [parameter subject]) - (|> (_.__import__/1 (_.unicode "math")) - (_.do "fmod" (list subject parameter)))))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.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.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary (product.uncurry (function.flip _.+)))) - (/.install "index" (trinary ..text::index)) - (/.install "size" (unary _.len/1)) - (/.install "char" (binary (product.uncurry //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: #export bundle - Bundle - (<| (/.prefix "lux") - (|> lux_procs - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux deleted file mode 100644 index a46bbb9cc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux +++ /dev/null @@ -1,164 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]]] - [target - ["_" python (#+ Expression SVar)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" python #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." 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)) - (_.nth 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 - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(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 - [] - (wrap (_.var name))))])) - -(def: python::import - (custom - [<s>.text - (function (_ extension phase archive module) - (do ////////phase.monad - [] - (wrap (_.apply/* (_.var "__import__") (list (_.string module))))))])) - -(def: python::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* abstractionG inputsG))))])) - -(def: python::function - (custom - [($_ <>.and <s>.i64 <s>.any) - (function (_ extension phase archive [arity abstractionS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - #let [variable (: (-> Text (Operation SVar)) - (|>> generation.gensym - (\ ! map _.var)))] - g!inputs (monad.map ! (function (_ _) (variable "input")) - (list.repeat (.nat arity) []))] - (wrap (_.lambda g!inputs - (case (.nat arity) - 0 (_.apply/1 abstractionG //runtime.unit) - 1 (_.apply/* abstractionG g!inputs) - _ (_.apply/1 abstractionG (_.list g!inputs)))))))])) - -(def: python::exec - (custom - [($_ <>.and <s>.any <s>.any) - (function (_ extension phase archive [codeS globalsS]) - (do {! ////////phase.monad} - [codeG (phase archive codeS) - globalsG (phase archive globalsS)] - (wrap (//runtime.lux::exec codeG globalsG))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "python") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..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/lux/tool/compiler/language/lux/phase/extension/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux deleted file mode 100644 index cd0f6b7cc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [r - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux deleted file mode 100644 index d9178d8c2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux +++ /dev/null @@ -1,178 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." set] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" r (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" r #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." case]]] - [// - ["." synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -## (template: (!unary function) -## (|>> list _.apply/* (|> (_.constant function)))) - -## ## ## TODO: Get rid of this ASAP -## ## (def: lux::syntax_char_case! -## ## (..custom [($_ <>.and -## ## <s>.any -## ## <s>.any -## ## (<>.some (<s>.tuple ($_ <>.and -## ## (<s>.tuple (<>.many <s>.i64)) -## ## <s>.any)))) -## ## (function (_ extension_name phase archive [input else conditionals]) -## ## (do {! /////.monad} -## ## [@input (\ ! map _.var (generation.gensym "input")) -## ## inputG (phase archive input) -## ## elseG (phase archive else) -## ## conditionalsG (: (Operation (List [Expression Expression])) -## ## (monad.map ! (function (_ [chars branch]) -## ## (do ! -## ## [branchG (phase archive branch)] -## ## (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) -## ## branchG]))) -## ## conditionals))] -## ## (wrap (_.let (list [@input inputG]) -## ## (list (list\fold (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.uncurry //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.uncurry _.=/2))) -## ## (/.install "<" (binary (product.uncurry _.</2))) -## ## (/.install "+" (binary (product.uncurry _.+/2))) -## ## (/.install "-" (binary (product.uncurry _.-/2))) -## ## (/.install "*" (binary (product.uncurry _.*/2))) -## ## (/.install "/" (binary (product.uncurry _.//2))) -## ## (/.install "%" (binary (product.uncurry _.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.uncurry _.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: #export bundle - Bundle - (<| (/.prefix "lux") - (|> /.empty - ## (dictionary.merge lux_procs) - (dictionary.merge i64_procs) - ## (dictionary.merge f64_procs) - (dictionary.merge text_procs) - ## (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux deleted file mode 100644 index 2d9148dda..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" r (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" r #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: #export bundle - Bundle - (<| (/.prefix "r") - (|> /.empty - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux deleted file mode 100644 index 12bcfc9b1..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [ruby - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux deleted file mode 100644 index 030b3b239..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux +++ /dev/null @@ -1,185 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - [target - ["_" ruby (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["//" ruby #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)]]] - [// - [synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [inputG (phase archive input) - elseG (phase archive else) - @input (\ ! map _.local (generation.gensym "input")) - conditionalsG (: (Operation (List [Expression Expression])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars - (list\map (|>> .int _.int (_.= @input))) - (list\fold (function (_ clause total) - (if (is? _.nil total) - clause - (_.or clause total))) - _.nil)) - branchG]))) - conditionals)) - #let [closure (_.lambda #.None (list @input) - (list\fold (function (_ [test then] else) - (_.if test (_.return then) else)) - (_.return elseG) - conditionalsG))]] - (wrap (_.apply_lambda/* (list inputG) closure))))])) - -(def: lux_procs - Bundle - (|> /.empty - (/.install "syntax char case!" lux::syntax_char_case!) - (/.install "is" (binary (function (_ [reference subject]) - (_.do "equal?" (list reference) subject)))) - (/.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.uncurry //runtime.i64//and))) - (/.install "or" (binary (product.uncurry //runtime.i64//or))) - (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) - (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) - (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - - (/.install "<" (binary (product.uncurry _.<))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "+" (binary (product.uncurry (..capped _.+)))) - (/.install "-" (binary (product.uncurry (..capped _.-)))) - (/.install "*" (binary (product.uncurry (..capped _.*)))) - (/.install "/" (binary (product.uncurry //runtime.i64//division))) - (/.install "%" (binary (function (_ [parameter subject]) - (_.do "remainder" (list parameter) subject)))) - - (/.install "f64" (unary (_./ (_.float +1.0)))) - (/.install "char" (unary (_.do "chr" (list (_.string "UTF-8"))))) - ))) - -(def: f64_procs - Bundle - (<| (/.prefix "f64") - (|> /.empty - (/.install "+" (binary (product.uncurry _.+))) - (/.install "-" (binary (product.uncurry _.-))) - (/.install "*" (binary (product.uncurry _.*))) - (/.install "/" (binary (product.uncurry _./))) - (/.install "%" (binary (function (_ [parameter subject]) - (_.do "remainder" (list parameter) subject)))) - (/.install "=" (binary (product.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "i64" (unary (_.do "floor" (list)))) - (/.install "encode" (unary (_.do "to_s" (list)))) - (/.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.uncurry _.=))) - (/.install "<" (binary (product.uncurry _.<))) - (/.install "concat" (binary (product.uncurry (function.flip _.+)))) - (/.install "index" (trinary text//index)) - (/.install "size" (unary (_.the "length"))) - (/.install "char" (binary (product.uncurry //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: #export bundle - Bundle - (<| (/.prefix "lux") - (|> lux_procs - (dictionary.merge ..i64_procs) - (dictionary.merge ..f64_procs) - (dictionary.merge ..text_procs) - (dictionary.merge ..io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux deleted file mode 100644 index 206034cd7..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux +++ /dev/null @@ -1,135 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" ruby (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" ruby #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." phase]]]]]]) - -(def: (array::new [size]) - (Unary Expression) - (_.do "new" (list size) (_.local "Array"))) - -(def: array::length - (Unary Expression) - (_.the "size")) - -(def: (array::read [indexG arrayG]) - (Binary Expression) - (_.nth 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 - [($_ <>.and <s>.text <s>.any) - (function (_ extension phase archive [fieldS objectS]) - (do ////////phase.monad - [objectG (phase archive objectS)] - (wrap (_.the fieldS objectG))))])) - -(def: object::do - Handler - (custom - [($_ <>.and <s>.text <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [methodS objectS inputsS]) - (do {! ////////phase.monad} - [objectG (phase archive objectS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.do methodS inputsG objectG))))])) - -(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) - (\ ////////phase.monad wrap (_.local name)))])) - -(def: ruby::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* inputsG abstractionG))))])) - -(def: ruby::import - (custom - [<s>.text - (function (_ extension phase archive module) - (\ ////////phase.monad wrap - (_.require/1 (_.string module))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "ruby") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..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/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux deleted file mode 100644 index 945e90e57..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - ["." / #_ - ["#." common] - ["#." host] - [//// - [generation - [scheme - [runtime (#+ Bundle)]]]]]) - -(def: #export bundle - Bundle - (dictionary.merge /common.bundle - /host.bundle)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux deleted file mode 100644 index 4f1258794..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux +++ /dev/null @@ -1,174 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["." try] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." dictionary] - ["." set] - ["." list ("#\." functor fold)]]] - [math - [number - ["f" frac]]] - ["@" target - ["_" scheme (#+ Expression)]]] - ["." //// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" scheme #_ - ["#." runtime (#+ Operation Phase Handler Bundle Generator)] - ["#." case]]] - [// - ["." synthesis (#+ %synthesis)] - ["." generation] - [/// - ["#" phase]]]]]) - -(def: #export (custom [parser handler]) - (All [s] - (-> [(Parser s) - (-> Text (Generator s))] - Handler)) - (function (_ extension_name phase archive input) - (case (<s>.run parser input) - (#try.Success input') - (handler extension_name phase archive input') - - (#try.Failure error) - (/////.throw extension.invalid_syntax [extension_name %synthesis input])))) - -(template: (!unary function) - (|>> list _.apply/* (|> (_.constant function)))) - -## TODO: Get rid of this ASAP -(def: lux::syntax_char_case! - (..custom [($_ <>.and - <s>.any - <s>.any - (<>.some (<s>.tuple ($_ <>.and - (<s>.tuple (<>.many <s>.i64)) - <s>.any)))) - (function (_ extension_name phase archive [input else conditionals]) - (do {! /////.monad} - [@input (\ ! map _.var (generation.gensym "input")) - inputG (phase archive input) - elseG (phase archive else) - conditionalsG (: (Operation (List [Expression Expression])) - (monad.map ! (function (_ [chars branch]) - (do ! - [branchG (phase archive branch)] - (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) - branchG]))) - conditionals))] - (wrap (_.let (list [@input inputG]) - (list\fold (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.uncurry _.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.uncurry //runtime.i64//and))) - (/.install "or" (binary (product.uncurry //runtime.i64//or))) - (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) - (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) - (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) - (/.install "=" (binary (product.uncurry _.=/2))) - (/.install "<" (binary (product.uncurry _.</2))) - (/.install "+" (binary (product.uncurry (..capped _.+/2)))) - (/.install "-" (binary (product.uncurry (..capped _.-/2)))) - (/.install "*" (binary (product.uncurry (..capped _.*/2)))) - (/.install "/" (binary (product.uncurry //runtime.i64//division))) - (/.install "%" (binary (product.uncurry _.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.uncurry _.=/2))) - (/.install "<" (binary (product.uncurry _.</2))) - (/.install "+" (binary (product.uncurry _.+/2))) - (/.install "-" (binary (product.uncurry _.-/2))) - (/.install "*" (binary (product.uncurry _.*/2))) - (/.install "/" (binary (product.uncurry _.//2))) - (/.install "%" (binary (product.uncurry _.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.uncurry _.string=?/2))) - (/.install "<" (binary (product.uncurry _.string<?/2))) - (/.install "concat" (binary (product.uncurry _.string-append/2))) - (/.install "index" (trinary ..text//index)) - (/.install "size" (unary _.string-length/1)) - (/.install "char" (binary (product.uncurry //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: #export bundle - Bundle - (<| (/.prefix "lux") - (|> /.empty - (dictionary.merge lux_procs) - (dictionary.merge i64_procs) - (dictionary.merge f64_procs) - (dictionary.merge text_procs) - (dictionary.merge io_procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux deleted file mode 100644 index 6072d29e5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux +++ /dev/null @@ -1,108 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<s>" synthesis (#+ Parser)]]] - [data - [collection - ["." dictionary] - ["." list]] - [text - ["%" format (#+ format)]]] - [target - ["_" scheme (#+ Var Expression)]]] - ["." // #_ - ["#." common (#+ custom)] - ["//#" /// #_ - ["/" bundle] - ["/#" // #_ - ["." extension] - [generation - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - ["." reference] - ["//" scheme #_ - ["#." runtime (#+ Operation Phase Handler Bundle - with_vars)]]] - ["/#" // #_ - ["." generation] - ["//#" /// #_ - ["#." 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)) - ))) - -(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 - [] - (wrap (_.var name))))])) - -(def: scheme::apply - (custom - [($_ <>.and <s>.any (<>.some <s>.any)) - (function (_ extension phase archive [abstractionS inputsS]) - (do {! ////////phase.monad} - [abstractionG (phase archive abstractionS) - inputsG (monad.map ! (phase archive) inputsS)] - (wrap (_.apply/* inputsG abstractionG))))])) - -(def: #export bundle - Bundle - (<| (/.prefix "scheme") - (|> /.empty - (dictionary.merge ..array) - (dictionary.merge ..object) - - (/.install "constant" scheme::constant) - (/.install "apply" scheme::apply) - (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux deleted file mode 100644 index 40fb4f89e..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/synthesis.lux +++ /dev/null @@ -1,10 +0,0 @@ -(.module: - [lux #*] - [// - ["." bundle] - [/// - [synthesis (#+ Bundle)]]]) - -(def: #export bundle - Bundle - bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux deleted file mode 100644 index 7b81d9d4a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux +++ /dev/null @@ -1,56 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]]] - ["." / #_ - [runtime (#+ Phase)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: #export (generate archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<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) - - (^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/recur /loop.recur] - [////synthesis.function/abstraction /function.function]) - - (#////synthesis.Extension extension) - (///extension.apply archive generate extension) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux deleted file mode 100644 index 2896e0030..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux +++ /dev/null @@ -1,261 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold monoid)] - ["." set]]] - [math - [number - ["n" nat]]] - [target - ["_" common_lisp (#+ Expression Var/1)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var/1) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register Var/1) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueG (expression archive valueS) - bodyG (expression archive bodyS)] - (wrap (_.let (list [(..register register) valueG]) - (list bodyG))))) - -(def: #export (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)] - (wrap (_.if testG thenG elseG)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueG (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^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]))) - -(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& (_.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 "") inc] - ) - -(def: (alternation @otherwise pre! post!) - (-> _.Tag (Expression Any) (Expression Any) (Expression Any)) - (_.tagbody ($_ list\compose - (list ..save! - pre! - @otherwise) - ..restore! - (list post!)))) - -(def: (pattern_matching' expression archive) - (Generator [Var/1 _.Tag _.Tag Path]) - (function (recur [$output @done @fail pathP]) - (.case pathP - (^ (/////synthesis.path/then bodyS)) - (\ ///////phase.monad map - (function (_ outputV) - (_.progn (list (_.setq $output outputV) - (_.go @done)))) - (expression archive bodyS)) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.setq (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur [$output @done @fail thenP]) - else! (.case elseP - (#.Some elseP) - (recur [$output @done @fail elseP]) - - #.None - (wrap (_.go @fail)))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format> <=>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur [$output @done @fail then])] - (wrap [(<=> [(|> match <format>) - ..peek]) - then!]))) - (#.Cons cons))] - (wrap (list\fold (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]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> @fail false idx #.None)) - - (^ (<simple> idx nextP)) - (|> nextP - [$output @done @fail] recur - (\ ///////phase.monad map (|>> #.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\wrap (..push! (_.elt/2 [..peek (_.int +0)]))) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..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! (recur [$output @done @fail nextP'])] - (///////phase\wrap (_.progn (list (..multi_pop! (n.+ 2 extra_pops)) - next!))))) - - (^ (/////synthesis.path/alt preP postP)) - (do {! ///////phase.monad} - [@otherwise (\ ! map (|>> %.nat (format "lux_case_otherwise") _.tag) /////generation.next) - pre! (recur [$output @done @otherwise preP]) - post! (recur [$output @done @fail postP])] - (wrap (..alternation @otherwise pre! post!))) - - (^ (/////synthesis.path/seq preP postP)) - (do ///////phase.monad - [pre! (recur [$output @done @fail preP]) - post! (recur [$output @done @fail postP])] - (wrap (_.progn (list pre! post!))))))) - -(def: (pattern_matching $output expression archive pathP) - (-> Var/1 (Generator Path)) - (do {! ///////phase.monad} - [@done (\ ! map (|>> %.nat (format "lux_case_done") _.tag) /////generation.next) - @fail (\ ! map (|>> %.nat (format "lux_case_fail") _.tag) /////generation.next) - pattern_matching! (pattern_matching' expression archive [$output @done @fail pathP])] - (wrap (_.tagbody - (list pattern_matching! - @fail - (_.error/1 (_.string ////synthesis/case.pattern_matching_error)) - @done))))) - -(def: #export (case expression archive [valueS pathP]) - (Generator [Synthesis Path]) - (do {! ///////phase.monad} - [initG (expression archive valueS) - $output (\ ! map (|>> %.nat (format "lux_case_output") _.var) /////generation.next) - pattern_matching! (pattern_matching $output expression archive pathP) - #let [storage (|> pathP - ////synthesis/case.storage - (get@ #////synthesis/case.bindings) - set.to_list - (list\map (function (_ register) - [(..register register) - _.nil])))]] - (wrap (_.let (list& [@cursor (_.list/* (list initG))] - [@savepoint (_.list/* (list))] - [@temp _.nil] - [$output _.nil] - storage) - (list pattern_matching! - $output))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux deleted file mode 100644 index 3bc0a0887..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common]]) - -(def: #export bundle - Bundle - common.bundle) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux deleted file mode 100644 index 574995de9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux +++ /dev/null @@ -1,136 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - ["." product] - [number - ["f" frac]] - [collection - ["." dictionary]]] - [target - ["_" common-lisp (#+ Expression)]]] - ["." /// #_ - ["#." runtime (#+ Operation Phase Handler Bundle)] - ["#." primitive] - [// - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - [// - [extension - ["." bundle]]]]]) - -(def: lux-procs - Bundle - (|> bundle.empty - (bundle.install "is" (binary (product.uncurry _.eq))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(def: (i64//left-shift [paramG subjectG]) - (Binary (Expression Any)) - (_.ash (_.rem (_.int +64) paramG) subjectG)) - -(def: (i64//arithmetic-right-shift [paramG subjectG]) - (Binary (Expression Any)) - (_.ash (|> paramG (_.rem (_.int +64)) (_.* (_.int -1))) - subjectG)) - -(def: (i64//logic-right-shift [paramG subjectG]) - (Binary (Expression Any)) - (///runtime.i64//logic-right-shift (_.rem (_.int +64) paramG) subjectG)) - -(def: i64-procs - Bundle - (<| (bundle.prefix "i64") - (|> bundle.empty - (bundle.install "and" (binary (product.uncurry _.logand))) - (bundle.install "or" (binary (product.uncurry _.logior))) - (bundle.install "xor" (binary (product.uncurry _.logxor))) - (bundle.install "left-shift" (binary i64//left-shift)) - (bundle.install "logical-right-shift" (binary i64//logic-right-shift)) - (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _.floor))) - (bundle.install "%" (binary (product.uncurry _.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.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.mod))) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (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.uncurry _.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)) - ($_ _.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: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> lux-procs - (dictionary.merge i64-procs) - (dictionary.merge f64-procs) - (dictionary.merge text-procs) - (dictionary.merge io-procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux deleted file mode 100644 index 2a5896e92..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" common_lisp (#+ Expression Var/1)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionG (expression archive functionS) - argsG+ (monad.map ! (expression archive) argsS+)] - (wrap (_.funcall/+ [functionG argsG+])))) - -(def: capture - (-> Register Var/1) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure inits function_definition) - (-> (List (Expression Any)) (Expression Any) (Operation (Expression Any))) - (case inits - #.Nil - (\ ///////phase.monad wrap function_definition) - - _ - (do {! ///////phase.monad} - [@closure (\ ! map _.var (/////generation.gensym "closure"))] - (wrap (_.labels (list [@closure [(|> (list.enumeration inits) - (list\map (|>> product.left ..capture)) - _.args) - function_definition]]) - (_.funcall/+ [(_.function/1 @closure) inits])))))) - -(def: input - (|>> inc //case.register)) - -(def: #export (function expression archive [environment arity bodyS]) - (Generator (Abstraction Synthesis)) - (do {! ///////phase.monad} - [@scope (\ ! map (|>> %.nat (format "function_scope") _.tag) /////generation.next) - @output (\ ! map (|>> %.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.map ! (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\map ..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/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux deleted file mode 100644 index 7256e926d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux +++ /dev/null @@ -1,69 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]] - [math - [number - ["n" nat]]] - [target - ["_" common_lisp (#+ Expression)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]]) - -(def: #export (scope expression archive [start initsS+ bodyS]) - (Generator (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [@scope (\ ! map (|>> %.nat (format "loop_scope") _.tag) /////generation.next) - @output (\ ! map (|>> %.nat (format "loop_output") _.var) /////generation.next) - initsG+ (monad.map ! (expression archive) initsS+) - bodyG (/////generation.with_anchor [@scope start] - (expression archive bodyS))] - (wrap (_.let (|> initsG+ - list.enumeration - (list\map (function (_ [idx init]) - [(|> idx (n.+ start) //case.register) - init])) - (list& [@output _.nil])) - (list (_.tagbody (list @scope - (_.setq @output bodyG))) - @output)))))) - -(def: #export (recur expression archive argsS+) - (Generator (List Synthesis)) - (do {! ///////phase.monad} - [[tag offset] /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+) - #let [bindings (|> argsO+ - list.enumeration - (list\map (|>> product.left (n.+ offset) //case.register)) - _.args)]] - (wrap (_.progn (list (_.multiple-value-setq bindings (_.values/* argsO+)) - (_.go tag)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux deleted file mode 100644 index 9357156f2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" common_lisp (#+ Expression)]]]) - -(def: #export bit - (-> Bit (Expression Any)) - _.bool) - -(def: #export i64 - (-> (I64 Any) (Expression Any)) - (|>> .int _.int)) - -(def: #export f64 - (-> Frac (Expression Any)) - _.double) - -(def: #export text - (-> Text (Expression Any)) - _.string) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux deleted file mode 100644 index 2e4488b00..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" common_lisp (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System (Expression Any)) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux deleted file mode 100644 index fd7ffc48b..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux +++ /dev/null @@ -1,292 +0,0 @@ -(.module: - [lux (#- Location inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - ["." encoding]] - [collection - ["." list ("#\." functor monoid)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" common_lisp (#+ Expression Computation Literal)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant)] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(def: module_id - 0) - -(template [<name> <base>] - [(type: #export <name> - (<base> [_.Tag Register] (Expression Any) (Expression Any)))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation (Expression Any)))) - -(def: #export 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: #export (variant [lefts right? value]) - (-> (Variant (Expression Any)) (Computation Any)) - (variant' (_.int (.int lefts)) (flag right?) value)) - -(def: #export none - (Computation Any) - (|> ..unit [0 #0] ..variant)) - -(def: #export some - (-> (Expression Any) (Computation Any)) - (|>> [1 #1] ..variant)) - -(def: #export left - (-> (Expression Any) (Computation Any)) - (|>> [0 #0] ..variant)) - -(def: #export right - (-> (Expression Any) (Computation Any)) - (|>> [1 #1] ..variant)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (let [g!name (code.local_identifier name) - code_nameC (code.local_identifier (format "@" name))] - (wrap (list (` (def: #export (~ g!name) - _.Var/1 - (~ runtime_name))) - - (` (def: (~ code_nameC) - (_.Expression Any) - (_.defparameter (~ runtime_name) (~ code))))))) - - (#.Right [name inputs]) - (let [g!name (code.local_identifier name) - code_nameC (code.local_identifier (format "@" name)) - - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` (_.Expression Any))) - inputs)] - (wrap (list (` (def: #export ((~ 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> (as_is ($_ _.then - (_.; (_.set lefts (_.-/2 [last_index_right lefts]))) - (_.; (_.set tuple (_.nth last_index_right tuple)))))] - (template: (!recur <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_shift 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_shift)) - -(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 ($_ list\compose - runtime//adt - runtime//lux - runtime//i64 - runtime//text - runtime//io))) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! (%.nat ..module_id) ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [(%.nat ..module_id) - (|> ..runtime - _.code - (\ encoding.utf8 encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux deleted file mode 100644 index 566fc148e..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" common_lisp (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple expression archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (expression archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (expression archive)) - (///////phase\map _.vector/*)))) - -(def: #export (variant expression archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (|>> [tag right?] //runtime.variant) - (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux deleted file mode 100644 index 051b6357b..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/extension.lux +++ /dev/null @@ -1,65 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - [parser - ["s" code]]] - [data - [collection - ["." list ("#\." functor)]]] - ["." meta] - ["." macro (#+ with_gensyms) - ["." code] - [syntax (#+ syntax:)]]] - ["." /// #_ - ["#." extension] - [// - [synthesis (#+ Synthesis)] - ["." generation] - [/// - ["#" phase]]]]) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export (Nullary of) (-> (Vector 0 of) of)) -(type: #export (Unary of) (-> (Vector 1 of) of)) -(type: #export (Binary of) (-> (Vector 2 of) of)) -(type: #export (Trinary of) (-> (Vector 3 of) of)) -(type: #export (Variadic of) (-> (List of) of)) - -(syntax: (arity: {arity s.nat} {name s.local_identifier} type) - (with_gensyms [g!_ g!extension g!name g!phase g!archive g!inputs g!of g!anchor g!expression g!directive] - (do {! meta.monad} - [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local_identifier name)) (~ g!extension)) - (All [(~ g!anchor) (~ g!expression) (~ g!directive)] - (-> ((~ type) (~ g!expression)) - (generation.Handler (~ g!anchor) (~ g!expression) (~ g!directive)))) - (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!archive) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do ///.monad - [(~+ (|> g!input+ - (list\map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!archive) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) - - (~' _) - (///.throw ///extension.incorrect_arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) - -(arity: 0 nullary ..Nullary) -(arity: 1 unary ..Unary) -(arity: 2 binary ..Binary) -(arity: 3 trinary ..Trinary) - -(def: #export (variadic extension) - (All [anchor expression directive] - (-> (Variadic expression) (generation.Handler anchor expression directive))) - (function (_ extension_name) - (function (_ phase archive inputsS) - (do {! ///.monad} - [inputsI (monad.map ! (phase archive) inputsS)] - (wrap (extension inputsI)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux deleted file mode 100644 index ab89ff708..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js.lux +++ /dev/null @@ -1,116 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" js]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([synthesis.bit] - [synthesis.i64] - [synthesis.f64] - [synthesis.text] - [synthesis.variant] - [synthesis.tuple] - [#synthesis.Reference] - [synthesis.branch/get] - [synthesis.function/apply] - [#synthesis.Extension]) - - (^ (synthesis.branch/case case)) - (/case.case! statement expression archive case) - - (^ (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/recur updates)) - (/loop.recur! statement expression archive updates) - - (^ (synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<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 ..statement expression archive case) - - (^ (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 ..statement expression archive scope) - - (^ (synthesis.loop/recur updates)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (^ (synthesis.function/abstraction abstraction)) - (/function.function ..statement expression archive abstraction) - - (^ (synthesis.function/apply application)) - (/function.apply expression archive application) - - (#synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux deleted file mode 100644 index 50e3ba008..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/case.lux +++ /dev/null @@ -1,321 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." maybe] - ["." text] - [collection - ["." list ("#\." functor fold)]]] - [math - [number - ["n" nat]]] - [target - ["_" js (#+ Expression Computation Var Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["//#" /// #_ - [reference - [variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export (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. - (wrap (_.apply/* (_.closure (list (..register register)) - (_.return bodyO)) - (list valueO))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (statement expression archive bodyS)] - (wrap ($_ _.then - (_.define (..register register) valueO) - bodyO)))) - -(def: #export (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)] - (wrap (_.? testO thenO elseO)))) - -(def: #export (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)] - (wrap (_.if testO - thenO - elseO)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.i32 (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueO - (list.reverse 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)))))) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat Statement) - ($_ _.then - (_.set @temp (|> idx <prep> .int _.i32 (//runtime.sum//get ..peek_cursor <flag>))) - (.if simple? - (_.when (_.= _.null @temp) - ..fail_pm!) - (_.if (_.= _.null @temp) - ..fail_pm! - (push_cursor! @temp)))))] - - [left_choice _.null (<|)] - [right_choice (_.string "") inc] - ) - -(def: (alternation pre! post!) - (-> Statement Statement Statement) - ($_ _.then - (_.do_while (_.boolean false) - ($_ _.then - ..save_cursor! - pre!)) - ($_ _.then - ..restore_cursor! - post!))) - -(def: (optimized_pattern_matching recur pathP) - (-> (-> Path (Operation Statement)) - (-> Path (Operation (Maybe Statement)))) - (.case pathP - (^template [<simple> <choice>] - [(^ (<simple> idx nextP)) - (|> nextP - recur - (\ ///////phase.monad map (|>> (_.then (<choice> true idx)) #.Some)))]) - ([/////synthesis.simple_left_side ..left_choice] - [/////synthesis.simple_right_side ..right_choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (#.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! (recur thenP)] - (wrap (#.Some ($_ _.then - (_.define (..register register) (_.at (_.i32 +0) ..peek_cursor)) - then!)))) - - ## Extra optimization - (^template [<pm> <getter>] - [(^ (/////synthesis.path/seq - (<pm> lefts) - (/////synthesis.!bind_top register thenP))) - (do ///////phase.monad - [then! (recur thenP)] - (wrap (#.Some ($_ _.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! (recur thenP)] - (wrap (#.Some ($_ _.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! (recur nextP')] - (wrap (#.Some ($_ _.then - (multi_pop_cursor! (n.+ 2 extra_pops)) - next!))))) - - _ - (///////phase\wrap #.None))) - -(def: (pattern_matching' statement expression archive) - (-> Phase! Phase Archive - (-> Path (Operation Statement))) - (function (recur pathP) - (do ///////phase.monad - [outcome (optimized_pattern_matching recur pathP)] - (.case outcome - (#.Some outcome) - (wrap outcome) - - #.None - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap pop_cursor!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.define (..register register) ..peek_cursor)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail_pm!))] - (wrap (.if when - (_.if ..peek_cursor - then! - else!) - (_.if ..peek_cursor - else! - then!)))) - - (#/////synthesis.I64_Fork cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(//runtime.i64//= (//primitive.i64 (.int match)) - ..peek_cursor) - then!]))) - (#.Cons cons))] - (wrap (_.cond clauses ..fail_pm!))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [cases (monad.map ! (function (_ [match then]) - (\ ! map (|>> [(list (<format> match))]) (recur then))) - (#.Cons cons))] - (wrap (_.switch ..peek_cursor - cases - (#.Some ..fail_pm!))))]) - ([#/////synthesis.F64_Fork //primitive.f64] - [#/////synthesis.Text_Fork //primitive.text]) - - (^template [<complex> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx))]) - ([/////synthesis.side/left ..left_choice] - [/////synthesis.side/right ..right_choice]) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (push_cursor! (<getter> (_.i32 (.int lefts)) ..peek_cursor)))]) - ([/////synthesis.member/left //runtime.tuple//left] - [/////synthesis.member/right //runtime.tuple//right]) - - (^template [<tag> <combinator>] - [(^ (<tag> leftP rightP)) - (do ///////phase.monad - [left! (recur leftP) - right! (recur rightP)] - (wrap (<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)] - (wrap ($_ _.then - (_.do_while (_.boolean false) - pattern_matching!) - (_.throw (_.string ////synthesis/case.pattern_matching_error)))))) - -(def: #export (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)] - (wrap ($_ _.then - (_.declare @temp) - (_.define @cursor (_.array (list stack_init))) - (_.define @savepoint (_.array (list))) - pattern_matching!)))) - -(def: #export (case statement expression archive [valueS pathP]) - (-> Phase! (Generator [Synthesis Path])) - (do ///////phase.monad - [pattern_matching! (..case! statement expression archive [valueS pathP])] - (wrap (_.apply/* (_.closure (list) pattern_matching!) (list))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux deleted file mode 100644 index 660ac4991..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/function.lux +++ /dev/null @@ -1,122 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" js (#+ Expression Computation Var Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* functionO argsO+)))) - -(def: capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure @self inits body!) - (-> Var (List Expression) Statement [Statement Expression]) - (case inits - #.Nil - [(_.function! @self (list) body!) - @self] - - _ - [(_.function! @self - (|> (list.enumeration inits) - (list\map (|>> product.left ..capture))) - (_.return (_.function @self (list) body!))) - (_.apply/* @self inits)])) - -(def: @curried - (_.var "curried")) - -(def: input - (|>> inc //case.register)) - -(def: @@arguments - (_.var "arguments")) - -(def: (@scope function_name) - (-> Context Text) - (format (///reference.artifact function_name) "_scope")) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[function_name body!] (/////generation.with_new_context archive - (do ! - [scope (\ ! map ..@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\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments)))) - initialize_self! - (list.indices arity))] - environment (monad.map ! (expression archive) environment) - #let [[definition instantiation] (with_closure @self environment - ($_ _.then - (_.define @num_args (_.the "length" @@arguments)) - (_.cond (list [(|> @num_args (_.= arityO)) - ($_ _.then - initialize! - (_.with_label (_.label @scope) - (_.do_while (_.boolean true) - body!)))] - [(|> @num_args (_.> arityO)) - (let [arity_inputs (|> (_.array (list)) - (_.the "slice") - (_.do "call" (list @@arguments (_.i32 +0) arityO))) - extra_inputs (|> (_.array (list)) - (_.the "slice") - (_.do "call" (list @@arguments arityO)))] - (_.return (|> @self - (apply_poly arity_inputs) - (apply_poly extra_inputs))))]) - ## (|> @num_args (_.< arityO)) - (let [all_inputs (|> (_.array (list)) - (_.the "slice") - (_.do "call" (list @@arguments)))] - ($_ _.then - (_.define @curried all_inputs) - (_.return (_.closure (list) - (let [@missing all_inputs] - (_.return (apply_poly (_.do "concat" (list @missing) @curried) - @self)))))))) - ))] - _ (/////generation.execute! definition) - _ (/////generation.save! (product.right function_name) definition)] - (wrap instantiation))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux deleted file mode 100644 index 135cfeb74..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/loop.lux +++ /dev/null @@ -1,90 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [math - [number - ["n" nat]]] - [target - ["_" js (#+ Computation Var Expression Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." case] - ["///#" //// #_ - [synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [reference - [variable (#+ Register)]]]]]) - -(def: @scope - (-> Nat Text) - (|>> %.nat (format "scope"))) - -(def: (setup initial? offset bindings body) - (-> Bit Register (List Expression) Statement Statement) - (|> bindings - list.enumeration - (list\map (function (_ [register value]) - (let [variable (//case.register (n.+ offset register))] - (if initial? - (_.define variable value) - (_.set variable value))))) - list.reverse - (list\fold _.then body))) - -(def: #export (scope! statement expression archive [start initsS+ bodyS]) - (Generator! (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (statement expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [@scope (\ ! map ..@scope /////generation.next) - initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor [start @scope] - (statement expression archive bodyS))] - (wrap (..setup true start initsO+ - (_.with_label (_.label @scope) - (_.do_while (_.boolean true) - body!))))))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [loop! (scope! statement expression archive [start initsS+ bodyS])] - (wrap (_.apply/* (_.closure (list) loop!) (list)))))) - -(def: @temp - (_.var "lux_recur_values")) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [[offset @scope] /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap ($_ _.then - (_.define @temp (_.array argsO+)) - (..setup false offset - (|> argsO+ - list.enumeration - (list\map (function (_ [idx _]) - (_.at (_.i32 (.int idx)) @temp)))) - (_.continue_at (_.label @scope))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux deleted file mode 100644 index db00d6439..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" js (#+ Computation)]]] - ["." // #_ - ["#." runtime]]) - -(def: #export bit - _.boolean) - -(def: #export (i64 value) - (-> (I64 Any) Computation) - (//runtime.i64 (|> value //runtime.high .int _.i32) - (|> value //runtime.low .int _.i32))) - -(def: #export f64 - _.number) - -(def: #export text - _.string) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux deleted file mode 100644 index 6361e3d09..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" js (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux deleted file mode 100644 index c307f4302..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux +++ /dev/null @@ -1,784 +0,0 @@ -(.module: - [lux (#- i64) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - [target - ["_" js (#+ Expression Var Computation Statement)]] - [tool - [compiler - [language - [lux - ["$" version]]]]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> [Register Text] Expression Statement))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation Statement))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation Statement))) - -(def: #export high - (-> (I64 Any) (I64 Any)) - (i64.right_shift 32)) - -(def: #export low - (-> (I64 Any) (I64 Any)) - (let [mask (dec (i64.left_shift 32 1))] - (|>> (i64.and mask)))) - -(def: #export unit - Computation - (_.string /////synthesis.unit)) - -(def: #export (flag value) - (-> Bit Computation) - (if value - (_.string "") - _.null)) - -(def: (feature name definition) - (-> Var (-> Var Expression) Statement) - (_.define name (definition name))) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (macro.with_gensyms [g!_ runtime] - (let [runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - Var - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!name)) - (~ code)))))))) - - (#.Right [name inputs]) - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) Computation) - (_.apply/* (~ runtime_name) (list (~+ inputsC))))) - - (` (def: (~ (code.local_identifier (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> (as_is ($_ _.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)) - ($_ _.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)) - ($_ _.then - (_.define last_index_right (..last_index tuple)) - (_.define right_index (_.+ (_.i32 +1) lefts)) - (_.cond (list [(_.= last_index_right right_index) - (_.return (_.at right_index tuple))] - [(_.> last_index_right right_index) - ## Needs recursion. - <recur>]) - (_.return (_.do "slice" (list right_index) tuple))) - ))))) - -(def: #export variant_tag_field "_lux_tag") -(def: #export variant_flag_field "_lux_flag") -(def: #export variant_value_field "_lux_value") - -(runtime: variant//new - (let [@this (_.var "this")] - (with_vars [tag is_last value] - (_.closure (list tag is_last value) - ($_ _.then - (_.set (_.the ..variant_tag_field @this) tag) - (_.set (_.the ..variant_flag_field @this) is_last) - (_.set (_.the ..variant_value_field @this) value) - ))))) - -(def: #export (variant tag last? value) - (-> Expression Expression Expression Computation) - (_.new ..variant//new (list tag last? value))) - -(runtime: (sum//get sum wants_last wanted_tag) - (let [no_match! (_.return _.null) - sum_tag (|> sum (_.the ..variant_tag_field)) - sum_flag (|> sum (_.the ..variant_flag_field)) - sum_value (|> sum (_.the ..variant_value_field)) - is_last? (_.= ..unit sum_flag) - extact_match! (_.return sum_value) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.then - (_.set wanted_tag (_.- sum_tag wanted_tag)) - (_.set sum sum_value)) - no_match!) - extrac_sub_variant! (_.return (..variant (_.- wanted_tag sum_tag) sum_flag sum_value))] - (<| (_.while (_.boolean true)) - (_.cond (list [(_.= wanted_tag sum_tag) - (_.if (_.= wants_last sum_flag) - extact_match! - test_recursion!)] - [(_.< wanted_tag sum_tag) - test_recursion!] - [(_.= ..unit wants_last) - extrac_sub_variant!]) - no_match!)))) - -(def: none - Computation - (..variant (_.i32 +0) (flag #0) unit)) - -(def: some - (-> Expression Computation) - (..variant (_.i32 +1) (flag #1))) - -(def: left - (-> Expression Computation) - (..variant (_.i32 +0) (flag #0))) - -(def: right - (-> Expression Computation) - (..variant (_.i32 +1) (flag #1))) - -(def: runtime//structure - Statement - ($_ _.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] - ($_ _.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 - ($_ _.then - @lux//try - @lux//program_args - )) - -(def: #export i64_low_field Text "_lux_low") -(def: #export i64_high_field Text "_lux_high") - -(runtime: i64//new - (let [@this (_.var "this")] - (with_vars [high low] - (_.closure (list high low) - ($_ _.then - (_.set (_.the ..i64_high_field @this) high) - (_.set (_.the ..i64_low_field @this) low) - ))))) - -(def: #export (i64 high low) - (-> Expression Expression Computation) - (_.new ..i64//new (list high low))) - -(runtime: i64//2^16 - (_.left_shift (_.i32 +16) (_.i32 +1))) - -(runtime: i64//2^32 - (_.* i64//2^16 i64//2^16)) - -(runtime: i64//2^64 - (_.* i64//2^32 i64//2^32)) - -(runtime: i64//2^63 - (|> i64//2^64 (_./ (_.i32 +2)))) - -(runtime: (i64//unsigned_low i64) - (_.return (_.? (|> i64 (_.the ..i64_low_field) (_.>= (_.i32 +0))) - (|> i64 (_.the ..i64_low_field)) - (|> i64 (_.the ..i64_low_field) (_.+ i64//2^32))))) - -(runtime: (i64//to_number i64) - (_.return (|> i64 - (_.the ..i64_high_field) - (_.* i64//2^32) - (_.+ (i64//unsigned_low i64))))) - -(runtime: i64//zero - (..i64 (_.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] - ($_ _.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))) - )))) - -(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))))) - -(runtime: (i64//negate value) - (_.return (_.? (i64//= i64//min value) - i64//min - (i64//+ i64//one (i64//not value))))) - -(runtime: i64//-one - (i64//negate i64//one)) - -(runtime: (i64//from_number value) - (_.return (<| (_.? (_.not_a_number? value) - i64//zero) - (_.? (_.<= (_.negate i64//2^63) value) - i64//min) - (_.? (|> value (_.+ (_.i32 +1)) (_.>= i64//2^63)) - i64//max) - (_.? (|> value (_.< (_.i32 +0))) - (|> value _.negate i64//from_number i64//negate)) - (..i64 (|> value (_./ i64//2^32) _.to_i32) - (|> value (_.% i64//2^32) _.to_i32))))) - -(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_shift input shift) - ($_ _.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_shift input shift) - ($_ _.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_shift input shift) - ($_ _.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 - ($_ _.then - @i64//and - @i64//or - @i64//xor - @i64//not - @i64//left_shift - @i64//arithmetic_right_shift - @i64//right_shift - )) - -(runtime: (i64//- parameter subject) - (_.return (i64//+ (i64//negate 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] - ($_ _.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?] - ($_ _.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)))) - -(runtime: (i64/// parameter subject) - (let [negative? (function (_ value) - (i64//< i64//zero value)) - valid_division_check [(i64//= i64//zero parameter) - (_.throw (_.string "Cannot divide by zero!"))] - short_circuit_check [(i64//= i64//zero subject) - (_.return i64//zero)]] - (_.cond (list valid_division_check - short_circuit_check - - [(i64//= i64//min subject) - (_.cond (list [(_.or (i64//= i64//one parameter) - (i64//= i64//-one parameter)) - (_.return i64//min)] - [(i64//= i64//min parameter) - (_.return i64//one)]) - (with_vars [approximation] - (let [subject/2 (..i64//arithmetic_right_shift subject (_.i32 +1))] - ($_ _.then - (_.define approximation (i64//left_shift (i64/// 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))))))))] - [(i64//= i64//min parameter) - (_.return i64//zero)] - - [(negative? subject) - (_.return (_.? (negative? parameter) - (i64/// (i64//negate parameter) - (i64//negate subject)) - (i64//negate (i64/// parameter - (i64//negate subject)))))] - - [(negative? parameter) - (_.return (i64//negate (i64/// (i64//negate parameter) subject)))]) - (with_vars [result remainder] - ($_ _.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//from_number approximate) - approx_remainder (i64//* parameter approximate_result)] - ($_ _.then - (_.define approximate (|> (i64//to_number remainder) - (_./ (i64//to_number parameter)) - (_.apply/1 (_.var "Math.floor")) - (_.apply/2 (_.var "Math.max") (_.i32 +1)))) - (_.define log2 (|> approximate - (_.apply/1 (_.var "Math.log")) - (_./ (_.var "Math.LN2")) - (_.apply/1 (_.var "Math.ceil")))) - (_.define delta (_.? (_.<= (_.i32 +48) log2) - (_.i32 +1) - (_.apply/2 (_.var "Math.pow") - (_.i32 +2) - (_.- (_.i32 +48) - log2)))) - (_.define approximate_result approximate_result') - (_.define approximate_remainder approx_remainder) - (_.while (_.or (negative? approximate_remainder) - (i64//< approximate_remainder - remainder)) - ($_ _.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 - ($_ _.then - @i64//2^16 - @i64//2^32 - @i64//2^64 - @i64//2^63 - @i64//unsigned_low - @i64//new - @i64//zero - @i64//min - @i64//max - @i64//one - @i64//= - @i64//+ - @i64//negate - @i64//to_number - @i64//from_number - @i64//- - @i64//* - @i64//< - @i64/// - @i64//% - runtime//bit - )) - -(runtime: (text//index start part text) - (with_vars [idx] - ($_ _.then - (_.define idx (|> text (_.do "indexOf" (list part (i64//to_number start))))) - (_.return (_.? (_.= (_.i32 -1) idx) - ..none - (..some (i64//from_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] - ($_ _.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//from_number result)))))) - -(def: runtime//text - Statement - ($_ _.then - @text//index - @text//clip - @text//char - )) - -(runtime: (io//log message) - (let [console (_.var "console") - print (_.var "print") - end! (_.return ..unit)] - (_.cond (list [(|> console _.type_of (_.= (_.string "undefined")) _.not - (_.and (_.the "log" console))) - ($_ _.then - (_.statement (|> console (_.do "log" (list message)))) - end!)] - [(|> print _.type_of (_.= (_.string "undefined")) _.not) - ($_ _.then - (_.statement (_.apply/1 print (_.? (_.= (_.string "string") - (_.type_of message)) - message - (_.apply/1 (_.var "JSON.stringify") message)))) - end!)]) - end!))) - -(runtime: (io//error message) - (_.throw message)) - -(def: runtime//io - Statement - ($_ _.then - @io//log - @io//error - )) - -(runtime: (js//get object field) - (with_vars [temp] - ($_ _.then - (_.define temp (_.at field object)) - (_.return (_.? (_.= _.undefined temp) - ..none - (..some temp)))))) - -(runtime: (js//set object field input) - ($_ _.then - (_.set (_.at field object) input) - (_.return object))) - -(runtime: (js//delete object field) - ($_ _.then - (_.delete (_.at field object)) - (_.return object))) - -(def: runtime//js - Statement - ($_ _.then - @js//get - @js//set - @js//delete - )) - -(runtime: (array//write idx value array) - ($_ _.then - (_.set (_.at (_.the ..i64_low_field idx) array) value) - (_.return array))) - -(runtime: (array//delete idx array) - ($_ _.then - (_.delete (_.at (_.the ..i64_low_field idx) array)) - (_.return array))) - -(def: runtime//array - Statement - ($_ _.then - @array//write - @array//delete - )) - -(def: runtime - Statement - ($_ _.then - runtime//structure - runtime//i64 - runtime//text - runtime//io - runtime//js - runtime//array - runtime//lux - )) - -(def: module_id - 0) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux deleted file mode 100644 index a90b81f7d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/js/structure.lux +++ /dev/null @@ -1,37 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" js (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple generate archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap //runtime.unit) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (do {! ///////phase.monad} - [elemsT+ (monad.map ! (generate archive) elemsS+)] - (wrap (_.array elemsT+))))) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant (_.i32 (.int tag)) - (//runtime.flag right?)) - (generate archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux deleted file mode 100644 index bb908e4c9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm.lux +++ /dev/null @@ -1,72 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]]] - ["." / #_ - [runtime (#+ Phase)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." function] - ["#." case] - ["#." loop] - ["//#" /// #_ - ["#." extension] - [// - ["." synthesis] - [/// - ["." reference] - ["#" phase ("#\." monad)]]]]]) - -(def: #export (generate archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (///\wrap (<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/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/recur updates)) - (/loop.recur 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/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux deleted file mode 100644 index 010f97349..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux +++ /dev/null @@ -1,265 +0,0 @@ -(.module: - [lux (#- Type if let case int) - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - [number - ["." i32] - ["n" nat]] - [collection - ["." list ("#\." fold)]]] - [target - [jvm - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - ["." type (#+ Type) - [category (#+ Method)]]]]] - ["." // #_ - ["#." type] - ["#." runtime (#+ Operation Phase Generator)] - ["#." value] - ["#." structure] - [//// - ["." synthesis (#+ Path Synthesis)] - ["." generation] - [/// - ["." phase ("operation\." monad)] - [reference - [variable (#+ Register)]]]]]) - -(def: equals-name - "equals") - -(def: equals-type - (type.method [(list //type.value) type.boolean (list)])) - -(def: (pop-alt stack-depth) - (-> Nat (Bytecode Any)) - (.case stack-depth - 0 (_\wrap []) - 1 _.pop - 2 _.pop2 - _ ## (n.> 2) - ($_ _.compose - _.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: double - (-> Frac (Bytecode Any)) - (|>> _.double)) - -(def: peek - (Bytecode Any) - ($_ _.compose - _.dup - (//runtime.get //runtime.stack-head))) - -(def: pop - (Bytecode Any) - ($_ _.compose - (//runtime.get //runtime.stack-tail) - (_.checkcast //type.stack))) - -(def: (left-projection lefts) - (-> Nat (Bytecode Any)) - ($_ _.compose - (_.checkcast //type.tuple) - (..int lefts) - (.case lefts - 0 - _.aaload - - lefts - //runtime.left-projection))) - -(def: (right-projection lefts) - (-> Nat (Bytecode Any)) - ($_ _.compose - (_.checkcast //type.tuple) - (..int lefts) - //runtime.right-projection)) - -(def: (path' stack-depth @else @end phase archive path) - (-> Nat Label Label (Generator Path)) - (.case path - #synthesis.Pop - (operation\wrap ..pop) - - (#synthesis.Bind register) - (operation\wrap ($_ _.compose - ..peek - (_.astore register))) - - (#synthesis.Then bodyS) - (do phase.monad - [bodyG (phase archive bodyS)] - (wrap ($_ _.compose - (..pop-alt stack-depth) - bodyG - (_.goto @end)))) - - (^template [<pattern> <right?>] - [(^ (<pattern> lefts)) - (operation\wrap - (do _.monad - [@success _.new-label - @fail _.new-label] - ($_ _.compose - ..peek - (_.checkcast //type.variant) - (//structure.tag lefts <right?>) - (//structure.flag <right?>) - //runtime.case - _.dup - (_.ifnull @fail) - (_.goto @success) - (_.set-label @fail) - _.pop - (_.goto @else) - (_.set-label @success) - //runtime.push)))]) - ([synthesis.side/left false] - [synthesis.side/right true]) - - (^template [<pattern> <projection>] - [(^ (<pattern> lefts)) - (operation\wrap ($_ _.compose - ..peek - (<projection> lefts) - //runtime.push))]) - ([synthesis.member/left ..left-projection] - [synthesis.member/right ..right-projection]) - - ## Extra optimization - (^ (synthesis.path/seq - (synthesis.member/left 0) - (synthesis.!bind-top register thenP))) - (do phase.monad - [thenG (path' stack-depth @else @end phase archive thenP)] - (wrap ($_ _.compose - ..peek - (_.checkcast //type.tuple) - _.iconst-0 - _.aaload - (_.astore register) - thenG))) - - ## Extra optimization - (^template [<pm> <projection>] - [(^ (synthesis.path/seq - (<pm> lefts) - (synthesis.!bind-top register thenP))) - (do phase.monad - [then! (path' stack-depth @else @end phase archive thenP)] - (wrap ($_ _.compose - ..peek - (_.checkcast //type.tuple) - (..int lefts) - <projection> - (_.astore register) - then!)))]) - ([synthesis.member/left //runtime.left-projection] - [synthesis.member/right //runtime.right-projection]) - - (#synthesis.Alt leftP rightP) - (do phase.monad - [@alt-else //runtime.forge-label - left! (path' (inc stack-depth) @alt-else @end phase archive leftP) - right! (path' stack-depth @else @end phase archive rightP)] - (wrap ($_ _.compose - _.dup - left! - (_.set-label @alt-else) - _.pop - right!))) - - (#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)] - (wrap ($_ _.compose - left! - right!))) - - _ - (undefined) - )) - -(def: (path @end phase archive path) - (-> Label (Generator Path)) - (do phase.monad - [@else //runtime.forge-label - pathG (..path' 1 @else @end phase archive path)] - (wrap ($_ _.compose - pathG - (_.set-label @else) - _.pop - //runtime.pm-failure - _.aconst-null - (_.goto @end))))) - -(def: #export (if phase archive [conditionS thenS elseS]) - (Generator [Synthesis Synthesis Synthesis]) - (do phase.monad - [conditionG (phase archive conditionS) - thenG (phase archive thenS) - elseG (phase archive elseS)] - (wrap (do _.monad - [@else _.new-label - @end _.new-label] - ($_ _.compose - conditionG - (//value.unwrap type.boolean) - (_.ifeq @else) - thenG - (_.goto @end) - (_.set-label @else) - elseG - (_.set-label @end)))))) - -(def: #export (let phase archive [inputS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do phase.monad - [inputG (phase archive inputS) - bodyG (phase archive bodyS)] - (wrap ($_ _.compose - inputG - (_.astore register) - bodyG)))) - -(def: #export (get phase archive [path recordS]) - (Generator [(List synthesis.Member) Synthesis]) - (do phase.monad - [recordG (phase archive recordS)] - (wrap (list\fold (function (_ step so-far) - (.let [next (.case step - (#.Left lefts) - (..left-projection lefts) - - (#.Right lefts) - (..right-projection lefts))] - (_.compose so-far next))) - recordG - (list.reverse path))))) - -(def: #export (case phase archive [valueS path]) - (Generator [Synthesis Path]) - (do phase.monad - [@end //runtime.forge-label - valueG (phase archive valueS) - pathG (..path @end phase archive path)] - (wrap ($_ _.compose - _.aconst-null - valueG - //runtime.push - pathG - (_.set-label @end))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux deleted file mode 100644 index 659dc0799..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux +++ /dev/null @@ -1,30 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." io (#+ IO)] - ["." try (#+ Try)]] - [data - [binary (#+ Binary)] - [text - ["%" format (#+ format)]]] - [world - ["." file (#+ File)]]]) - -(def: extension ".class") - -(def: #export (write-class! name bytecode) - (-> Text Binary (IO Text)) - (let [file-path (format name ..extension)] - (do io.monad - [outcome (do (try.with @) - [file (: (IO (Try (File IO))) - (file.get-file io.monad file.default file-path))] - (\ file over-write bytecode))] - (wrap (case outcome - (#try.Success definition) - file-path - - (#try.Failure error) - error))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux deleted file mode 100644 index a456644b8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux +++ /dev/null @@ -1,134 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad (#+ do)]] - [data - [number - ["." i32] - ["n" nat]] - [collection - ["." list ("#\." monoid functor)] - ["." row]] - ["." format #_ - ["#" binary]]] - [target - [jvm - ["." version] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." field (#+ Field)] - ["." method (#+ Method)] - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - ["." class (#+ Class)] - ["." type (#+ Type) - [category (#+ Return' Value')] - ["." reflection]] - ["." constant - [pool (#+ Resource)]] - [encoding - ["." name (#+ External Internal)] - ["." unsigned]]]] - [tool - [compiler - [meta - ["." archive (#+ Archive)]]]]] - ["." / #_ - ["#." abstract] - [field - [constant - ["#." arity]] - [variable - ["#." foreign] - ["#." partial]]] - [method - ["#." init] - ["#." new] - ["#." implementation] - ["#." reset] - ["#." apply]] - ["/#" // #_ - ["#." runtime (#+ Operation Phase Generator)] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis Abstraction Apply)] - ["." generation] - [/// - ["." arity (#+ Arity)] - ["." phase] - [reference - [variable (#+ Register)]]]]]]) - -(def: #export (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 (: (List (Resource Field)) - (list& /arity.constant - (list\compose (/foreign.variables environment) - (/partial.variables arity)))) - methods (: (List (Resource Method)) - (list& (/init.method classT environment arity) - (/reset.method classT environment arity) - (if (arity.multiary? arity) - (|> (n.min arity /arity.maximum) - list.indices - (list\map (|>> inc (/apply.method classT environment arity @begin body))) - (list& (/implementation.method arity @begin body))) - (list (/implementation.method' //runtime.apply::name arity @begin body)))))] - (do phase.monad - [instance (/new.instance generate archive classT environment arity)] - (wrap [fields methods instance])))) - -(def: modifier - (Modifier Class) - ($_ modifier\compose - class.public - class.final)) - -(def: this-offset 1) - -(def: internal - (All [category] - (-> (Type (<| Return' Value' category)) - Internal)) - (|>> type.reflection reflection.reflection name.internal)) - -(def: #export (abstraction generate archive [environment arity bodyS]) - (Generator Abstraction) - (do phase.monad - [@begin //runtime.forge-label - [function-context bodyG] (generation.with-new-context archive - (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.lift (class.class version.v6_0 - ..modifier - (name.internal function-class) - (..internal /abstract.class) (list) - fields - methods - (row.row))) - #let [bytecode (format.run class.writer class)] - _ (generation.execute! [function-class bytecode]) - _ (generation.save! function-class [function-class bytecode])] - (wrap instance))) - -(def: #export (apply generate archive [abstractionS inputsS]) - (Generator Apply) - (do {! phase.monad} - [abstractionG (generate archive abstractionS) - inputsG (monad.map ! (generate archive) inputsS)] - (wrap ($_ _.compose - abstractionG - (|> inputsG - (list.chunk /arity.maximum) - (monad.map _.monad - (function (_ batchG) - ($_ _.compose - (_.checkcast /abstract.class) - (monad.seq _.monad batchG) - (_.invokevirtual /abstract.class //runtime.apply::name (//runtime.apply::type (list.size batchG))) - )))) - )))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux deleted file mode 100644 index 0b4885180..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux +++ /dev/null @@ -1,23 +0,0 @@ -(.module: - [lux (#- Type) - [data - [text - ["%" format]]] - [target - [jvm - ["." type (#+ Type) - [category (#+ Method)]]]]] - [// - [field - [constant - ["." arity]]]]) - -(def: #export artifact_id - 1) - -(def: #export class - (type.class (%.nat artifact_id) (list))) - -(def: #export init - (Type Method) - (type.method [(list arity.type) type.void (list)])) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux deleted file mode 100644 index f3b4a4720..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux +++ /dev/null @@ -1,25 +0,0 @@ -(.module: - [lux (#- Type type) - [data - [collection - ["." row]]] - [target - [jvm - ["." field (#+ Field)] - ["." modifier (#+ Modifier) ("#\." monoid)] - [type (#+ Type) - [category (#+ Value)]] - [constant - [pool (#+ Resource)]]]]]) - -(def: modifier - (Modifier Field) - ($_ modifier\compose - field.public - field.static - field.final - )) - -(def: #export (constant name type) - (-> Text (Type Value) (Resource Field)) - (field.field ..modifier name type (row.row))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux deleted file mode 100644 index 011535ce9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux +++ /dev/null @@ -1,21 +0,0 @@ -(.module: - [lux (#- type) - [target - [jvm - ["." type] - ["." field (#+ Field)] - [constant - [pool (#+ Resource)]]]]] - ["." // - [///////// - [arity (#+ Arity)]]]) - -(def: #export name "arity") -(def: #export type type.int) - -(def: #export minimum Arity 1) -(def: #export maximum Arity 8) - -(def: #export constant - (Resource Field) - (//.constant ..name ..type)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux deleted file mode 100644 index 478f9d454..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux +++ /dev/null @@ -1,55 +0,0 @@ -(.module: - [lux (#- Type type) - [data - [collection - ["." list ("#\." functor)] - ["." row]]] - [target - [jvm - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." field (#+ Field)] - ["_" bytecode (#+ Bytecode)] - [type (#+ Type) - [category (#+ Value Class)]] - [constant - [pool (#+ Resource)]]]]] - ["." //// #_ - ["#." type] - ["#." reference] - [////// - [reference - [variable (#+ Register)]]]]) - -(def: #export type ////type.value) - -(def: #export (get class name) - (-> (Type Class) Text (Bytecode Any)) - ($_ _.compose - ////reference.this - (_.getfield class name ..type) - )) - -(def: #export (put naming class register value) - (-> (-> Register Text) (Type Class) Register (Bytecode Any) (Bytecode Any)) - ($_ _.compose - ////reference.this - value - (_.putfield class (naming register) ..type))) - -(def: modifier - (Modifier Field) - ($_ modifier\compose - field.private - field.final - )) - -(def: #export (variable name type) - (-> Text (Type Value) (Resource Field)) - (field.field ..modifier name type (row.row))) - -(def: #export (variables naming amount) - (-> (-> Register Text) Nat (List (Resource Field))) - (|> amount - list.indices - (list\map (function (_ register) - (..variable (naming register) ..type))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux deleted file mode 100644 index 1c6bf6455..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux (#- Type) - [data - [collection - ["." list] - ["." row]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." field (#+ Field)] - [constant - [pool (#+ Resource)]] - [type (#+ Type) - [category (#+ Value Class)]]]]] - ["." // - ["///#" //// #_ - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - [reference - [variable (#+ Register)]]]]]]) - -(def: #export (closure environment) - (-> (Environment Synthesis) (List (Type Value))) - (list.repeat (list.size environment) //.type)) - -(def: #export (get class register) - (-> (Type Class) Register (Bytecode Any)) - (//.get class (/////reference.foreign-name register))) - -(def: #export (put class register value) - (-> (Type Class) Register (Bytecode Any) (Bytecode Any)) - (//.put /////reference.foreign-name class register value)) - -(def: #export variables - (-> (Environment Synthesis) (List (Resource Field))) - (|>> list.size (//.variables /////reference.foreign-name))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux deleted file mode 100644 index ff1599a0c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux +++ /dev/null @@ -1,58 +0,0 @@ -(.module: - [lux (#- Type) - [abstract - ["." monad]] - [data - [number - ["n" nat]] - [collection - ["." list ("#\." functor)] - ["." row]]] - [target - [jvm - ["." field (#+ Field)] - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - [type (#+ Type) - [category (#+ Class)]] - [constant - [pool (#+ Resource)]]]]] - ["." / #_ - ["#." count] - ["/#" // - ["/#" // #_ - [constant - ["#." arity]] - ["//#" /// #_ - ["#." reference] - [////// - ["." arity (#+ Arity)] - [reference - [variable (#+ Register)]]]]]]]) - -(def: #export (initial amount) - (-> Nat (Bytecode Any)) - ($_ _.compose - (|> _.aconst-null - (list.repeat amount) - (monad.seq _.monad)) - (_\wrap []))) - -(def: #export (get class register) - (-> (Type Class) Register (Bytecode Any)) - (//.get class (/////reference.partial-name register))) - -(def: #export (put class register value) - (-> (Type Class) Register (Bytecode Any) (Bytecode Any)) - (//.put /////reference.partial-name class register value)) - -(def: #export variables - (-> Arity (List (Resource Field))) - (|>> (n.- ///arity.minimum) (//.variables /////reference.partial-name))) - -(def: #export (new arity) - (-> Arity (Bytecode Any)) - (if (arity.multiary? arity) - ($_ _.compose - /count.initial - (initial (n.- ///arity.minimum arity))) - (_\wrap []))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux deleted file mode 100644 index dbafd7ee5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux +++ /dev/null @@ -1,30 +0,0 @@ -(.module: - [lux (#- type) - [control - ["." try]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - [encoding - [name (#+ External)] - ["." signed]] - ["." type]]]] - ["." ///// #_ - ["#." abstract]]) - -(def: #export field "partials") -(def: #export type type.int) - -(def: #export initial - (Bytecode Any) - (|> +0 signed.s1 try.assume _.bipush)) - -(def: this - _.aload_0) - -(def: #export value - (Bytecode Any) - ($_ _.compose - ..this - (_.getfield /////abstract.class ..field ..type) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux deleted file mode 100644 index a6de97cc3..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [target - [jvm - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." method (#+ Method)]]]]) - -(def: #export modifier - (Modifier Method) - ($_ modifier\compose - method.public - method.strict - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux deleted file mode 100644 index 581cce970..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux +++ /dev/null @@ -1,156 +0,0 @@ -(.module: - [lux (#- Type type) - [abstract - ["." monad (#+ do)]] - [control - ["." try]] - [data - [number - ["n" nat] - ["i" int] - ["." i32]] - [collection - ["." list ("#\." monoid functor)]]] - [target - [jvm - ["_" bytecode (#+ Label Bytecode) ("#\." monad)] - ["." method (#+ Method)] - [constant - [pool (#+ Resource)]] - [encoding - ["." signed]] - ["." type (#+ Type) - ["." category (#+ Class)]]]]] - ["." // - ["#." reset] - ["#." implementation] - ["#." init] - ["/#" // #_ - ["#." abstract] - [field - [constant - ["#." arity]] - [variable - ["#." partial - ["#/." count]] - ["#." foreign]]] - ["/#" // #_ - ["#." runtime] - ["#." value] - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - [arity (#+ Arity)] - [reference - [variable (#+ Register)]]]]]]]) - -(def: (increment by) - (-> Nat (Bytecode Any)) - ($_ _.compose - (<| _.int .i64 by) - _.iadd)) - -(def: (inputs offset amount) - (-> Register Nat (Bytecode Any)) - ($_ _.compose - (|> amount - list.indices - (monad.map _.monad (|>> (n.+ offset) _.aload))) - (_\wrap []) - )) - -(def: (apply offset amount) - (-> Register Nat (Bytecode Any)) - (let [arity (n.min amount ///arity.maximum)] - ($_ _.compose - (_.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)) - (_\wrap [])) - ))) - -(def: this-offset 1) - -(def: #export (method class environment function-arity @begin body apply-arity) - (-> (Type Class) (Environment Synthesis) Arity Label (Bytecode Any) Arity (Resource Method)) - (let [num-partials (dec function-arity) - over-extent (i.- (.int apply-arity) - (.int function-arity))] - (method.method //.modifier ////runtime.apply::name - (////runtime.apply::type apply-arity) - (list) - (#.Some (case num-partials - 0 ($_ _.compose - ////reference.this - (..inputs ..this-offset apply-arity) - (_.invokevirtual class //implementation.name (//implementation.type function-arity)) - _.areturn) - _ (do _.monad - [@default _.new-label - @labelsH _.new-label - @labelsT (|> _.new-label - (list.repeat (dec num-partials)) - (monad.seq _.monad)) - #let [cases (|> (list\compose (#.Cons [@labelsH @labelsT]) - (list @default)) - list.enumeration - (list\map (function (_ [stage @case]) - (let [current-partials (|> (list.indices stage) - (list\map (///partial.get class)) - (monad.seq _.monad)) - already-partial? (n.> 0 stage) - exact-match? (i.= over-extent (.int stage)) - has-more-than-necessary? (i.> over-extent (.int stage))] - ($_ _.compose - (_.set-label @case) - (cond exact-match? - ($_ _.compose - ////reference.this - (if already-partial? - (_.invokevirtual class //reset.name (//reset.type class)) - (_\wrap [])) - current-partials - (..inputs ..this-offset apply-arity) - (_.invokevirtual class //implementation.name (//implementation.type function-arity)) - _.areturn) - - has-more-than-necessary? - (let [inputs-to-completion (|> function-arity (n.- stage)) - inputs-left (|> apply-arity (n.- inputs-to-completion))] - ($_ _.compose - ////reference.this - (_.invokevirtual class //reset.name (//reset.type class)) - current-partials - (..inputs ..this-offset inputs-to-completion) - (_.invokevirtual class //implementation.name (//implementation.type function-arity)) - (apply (n.+ ..this-offset inputs-to-completion) inputs-left) - _.areturn)) - - ## (i.< over-extent (.int stage)) - (let [current-environment (|> (list.indices (list.size environment)) - (list\map (///foreign.get class)) - (monad.seq _.monad)) - missing-partials (|> _.aconst-null - (list.repeat (|> num-partials (n.- apply-arity) (n.- stage))) - (monad.seq _.monad))] - ($_ _.compose - (_.new class) - _.dup - current-environment - ///partial/count.value - (..increment apply-arity) - current-partials - (..inputs ..this-offset apply-arity) - missing-partials - (_.invokevirtual class //init.name (//init.type environment function-arity)) - _.areturn))))))) - (monad.seq _.monad))]] - ($_ _.compose - ///partial/count.value - (_.tableswitch (try.assume (signed.s4 +0)) @default [@labelsH @labelsT]) - cases))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux deleted file mode 100644 index 000bdf569..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux (#- Type type) - [data - [collection - ["." list]]] - [target - [jvm - ["." method (#+ Method)] - ["_" bytecode (#+ Label Bytecode)] - [constant - [pool (#+ Resource)]] - ["." type (#+ Type) - ["." category]]]]] - ["." // - ["//#" /// #_ - ["#." type] - [////// - [arity (#+ Arity)]]]]) - -(def: #export name "impl") - -(def: #export (type arity) - (-> Arity (Type category.Method)) - (type.method [(list.repeat arity ////type.value) - ////type.value - (list)])) - -(def: #export (method' name arity @begin body) - (-> Text Arity Label (Bytecode Any) (Resource Method)) - (method.method //.modifier name - (..type arity) - (list) - (#.Some ($_ _.compose - (_.set-label @begin) - body - _.areturn - )))) - -(def: #export method - (-> Arity Label (Bytecode Any) (Resource Method)) - (method' ..name)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux deleted file mode 100644 index fe8b824c9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux +++ /dev/null @@ -1,97 +0,0 @@ -(.module: - [lux (#- Type type) - [abstract - ["." monad]] - [control - ["." try]] - [data - [number - ["n" nat]] - [collection - ["." list ("#\." monoid functor)]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." method (#+ Method)] - [encoding - ["." unsigned]] - [constant - [pool (#+ Resource)]] - ["." type (#+ Type) - ["." category (#+ Class Value)]]]]] - ["." // - ["#." implementation] - ["/#" // #_ - ["#." abstract] - [field - [constant - ["#." arity]] - [variable - ["#." foreign] - ["#." partial]]] - ["/#" // #_ - ["#." type] - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - ["." arity (#+ Arity)] - [reference - [variable (#+ Register)]]]]]]]) - -(def: #export name "<init>") - -(def: (partials arity) - (-> Arity (List (Type Value))) - (list.repeat (dec arity) ////type.value)) - -(def: #export (type environment arity) - (-> (Environment Synthesis) Arity (Type category.Method)) - (type.method [(list\compose (///foreign.closure environment) - (if (arity.multiary? arity) - (list& ///arity.type (..partials arity)) - (list))) - type.void - (list)])) - -(def: no-partials (|> 0 unsigned.u1 try.assume _.bipush)) - -(def: #export (super environment-size arity) - (-> Nat Arity (Bytecode Any)) - (let [arity-register (inc environment-size)] - ($_ _.compose - (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\map (function (_ register) - (put register - (_.aload (offset register))))) - (monad.seq _.monad))) - -(def: #export (method class environment arity) - (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) - (let [environment-size (list.size environment) - offset-foreign (: (-> Register Register) - (n.+ 1)) - offset-arity (: (-> Register Register) - (|>> offset-foreign (n.+ environment-size))) - offset-partial (: (-> Register Register) - (|>> offset-arity (n.+ 1)))] - (method.method //.modifier ..name - (..type environment arity) - (list) - (#.Some ($_ _.compose - ////reference.this - (..super environment-size arity) - (store-all environment-size (///foreign.put class) offset-foreign) - (store-all (dec arity) (///partial.put class) offset-partial) - _.return))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux deleted file mode 100644 index 7bf1b0bd8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux +++ /dev/null @@ -1,80 +0,0 @@ -(.module: - [lux (#- Type type) - [abstract - ["." monad (#+ do)]] - [data - [number - ["n" nat]] - [collection - ["." list]]] - [target - [jvm - ["." field (#+ Field)] - ["." method (#+ Method)] - ["_" bytecode (#+ Bytecode)] - ["." constant - [pool (#+ Resource)]] - [type (#+ Type) - ["." category (#+ Class Value Return)]]]] - [tool - [compiler - [meta - ["." archive (#+ Archive)]]]]] - ["." // - ["#." init] - ["#." implementation] - ["/#" // #_ - [field - [constant - ["#." arity]] - [variable - ["#." foreign] - ["#." partial]]] - ["/#" // #_ - [runtime (#+ Operation Phase)] - ["#." value] - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - ["." arity (#+ Arity)] - ["." phase]]]]]]) - -(def: #export (instance' foreign-setup class environment arity) - (-> (List (Bytecode Any)) (Type Class) (Environment Synthesis) Arity (Bytecode Any)) - ($_ _.compose - (_.new class) - _.dup - (monad.seq _.monad foreign-setup) - (///partial.new arity) - (_.invokespecial class //init.name (//init.type environment arity)))) - -(def: #export (instance generate archive class environment arity) - (-> Phase Archive (Type Class) (Environment Synthesis) Arity (Operation (Bytecode Any))) - (do {! phase.monad} - [foreign* (monad.map ! (generate archive) environment)] - (wrap (instance' foreign* class environment arity)))) - -(def: #export (method class environment arity) - (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) - (let [after-this (: (-> Nat Nat) - (n.+ 1)) - environment-size (list.size environment) - after-environment (: (-> Nat Nat) - (|>> after-this (n.+ environment-size))) - after-arity (: (-> Nat Nat) - (|>> after-environment (n.+ 1)))] - (method.method //.modifier //init.name - (//init.type environment arity) - (list) - (#.Some ($_ _.compose - ////reference.this - (//init.super environment-size arity) - (monad.map _.monad (function (_ register) - (///foreign.put class register (_.aload (after-this register)))) - (list.indices environment-size)) - (monad.map _.monad (function (_ register) - (///partial.put class register (_.aload (after-arity register)))) - (list.indices (n.- ///arity.minimum arity))) - _.areturn))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux deleted file mode 100644 index 9793da801..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux +++ /dev/null @@ -1,49 +0,0 @@ -(.module: - [lux (#- Type type) - [data - [collection - ["." list ("#\." functor)]]] - [target - [jvm - ["." method (#+ Method)] - ["_" bytecode (#+ Bytecode)] - [constant - [pool (#+ Resource)]] - ["." type (#+ Type) - ["." category (#+ Class)]]]]] - ["." // - ["#." new] - ["/#" // #_ - [field - [variable - ["#." foreign]]] - ["/#" // #_ - ["#." reference] - [//// - [analysis (#+ Environment)] - [synthesis (#+ Synthesis)] - [/// - ["." arity (#+ Arity)]]]]]]) - -(def: #export name "reset") - -(def: #export (type class) - (-> (Type Class) (Type category.Method)) - (type.method [(list) class (list)])) - -(def: (current-environment class) - (-> (Type Class) (Environment Synthesis) (List (Bytecode Any))) - (|>> list.size - list.indices - (list\map (///foreign.get class)))) - -(def: #export (method class environment arity) - (-> (Type Class) (Environment Synthesis) Arity (Resource Method)) - (method.method //.modifier ..name - (..type class) - (list) - (#.Some ($_ _.compose - (if (arity.multiary? arity) - (//new.instance' (..current-environment class environment) class environment arity) - ////reference.this) - _.areturn)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux deleted file mode 100644 index 0e7a2c776..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux +++ /dev/null @@ -1,160 +0,0 @@ -(.module: - [lux (#- Definition) - ["." ffi (#+ import: do-to object)] - [abstract - [monad (#+ do)]] - [control - pipe - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." io (#+ IO io)] - [concurrency - ["." atom (#+ Atom atom)]]] - [data - [binary (#+ Binary)] - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)]] - [collection - ["." array] - ["." dictionary (#+ Dictionary)] - ["." row]] - ["." format #_ - ["#" binary]]] - [target - [jvm - ["." loader (#+ Library)] - ["_" bytecode (#+ Bytecode)] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." field (#+ Field)] - ["." method (#+ Method)] - ["." version] - ["." class (#+ Class)] - ["." encoding #_ - ["#/." name]] - ["." type - ["." descriptor]]]] - [tool - [compiler - ["." name]]]] - ["." // #_ - ["#." runtime (#+ Definition)]] - ) - -(import: java/lang/reflect/Field - (get [#? java/lang/Object] #try #? java/lang/Object)) - -(import: (java/lang/Class a) - (getField [java/lang/String] #try java/lang/reflect/Field)) - -(import: java/lang/Object - (getClass [] (java/lang/Class java/lang/Object))) - -(import: java/lang/ClassLoader) - -(def: value::field "value") -(def: value::type (type.class "java.lang.Object" (list))) -(def: value::modifier ($_ modifier\compose field.public field.final field.static)) - -(def: init::type (type.method [(list) type.void (list)])) -(def: init::modifier ($_ modifier\compose method.public method.static method.strict)) - -(exception: #export (cannot-load {class Text} {error Text}) - (exception.report - ["Class" class] - ["Error" error])) - -(exception: #export (invalid-field {class Text} {field Text} {error Text}) - (exception.report - ["Class" class] - ["Field" field] - ["Error" error])) - -(exception: #export (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.throw ..invalid-value [class-name])) - - (#try.Failure error) - (exception.throw ..cannot-load [class-name error])) - - (#try.Failure error) - (exception.throw ..invalid-field [class-name ..value::field error]))) - -(def: class-path-separator ".") - -(def: (evaluate! library loader eval-class valueG) - (-> Library java/lang/ClassLoader Text (Bytecode Any) (Try [Any Definition])) - (let [bytecode-name (text.replace-all class-path-separator .module-separator eval-class) - bytecode (class.class version.v6_0 - class.public - (encoding/name.internal bytecode-name) - (encoding/name.internal "java.lang.Object") (list) - (list (field.field ..value::modifier ..value::field ..value::type (row.row))) - (list (method.method ..init::modifier "<clinit>" ..init::type - (list) - (#.Some - ($_ _.compose - valueG - (_.putstatic (type.class bytecode-name (list)) ..value::field ..value::type) - _.return)))) - (row.row))] - (io.run (do {! (try.with io.monad)} - [bytecode (\ ! map (format.run class.writer) - (io.io bytecode)) - _ (loader.store eval-class bytecode library) - class (loader.load eval-class loader) - value (\ io.monad wrap (class-value eval-class class))] - (wrap [value - [eval-class bytecode]]))))) - -(def: (execute! library loader temp-label [class-name class-bytecode]) - (-> Library java/lang/ClassLoader Text Definition (Try Any)) - (io.run (do (try.with io.monad) - [existing-class? (|> (atom.read library) - (\ io.monad map (function (_ library) - (dictionary.key? library class-name))) - (try.lift io.monad) - (: (IO (Try Bit)))) - _ (if existing-class? - (wrap []) - (loader.store class-name class-bytecode library))] - (loader.load class-name loader)))) - -(def: (define! library loader [module name] valueG) - (-> Library java/lang/ClassLoader Name (Bytecode Any) (Try [Text Any Definition])) - (let [class-name (format (text.replace-all .module-separator class-path-separator module) - class-path-separator (name.normalize name) - "___" (%.nat (text\hash name)))] - (do try.monad - [[value definition] (evaluate! library loader class-name valueG)] - (wrap [class-name value definition])))) - -(def: #export host - (IO //runtime.Host) - (io (let [library (loader.new-library []) - loader (loader.memory library)] - (: //runtime.Host - (implementation - (def: (evaluate! temp-label valueG) - (let [eval-class (|> temp-label name.normalize (text.replace-all " " "$"))] - (\ try.monad map product.left - (..evaluate! library loader eval-class valueG)))) - - (def: execute! - (..execute! library loader)) - - (def: define! - (..define! library loader))))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux deleted file mode 100644 index 2640f28ce..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - ["." product] - [number - ["n" nat]] - [collection - ["." list ("#\." functor)]]] - [target - [jvm - ["_" bytecode (#+ Label Bytecode) ("#\." monad)]]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." value] - [//// - ["." synthesis (#+ Path Synthesis)] - ["." generation] - [/// - ["." phase] - [reference - [variable (#+ Register)]]]]]) - -(def: (invariant? register changeS) - (-> Register Synthesis Bit) - (case changeS - (^ (synthesis.variable/local var)) - (n.= register var) - - _ - false)) - -(def: no-op - (_\wrap [])) - -(def: #export (recur translate archive updatesS) - (Generator (List Synthesis)) - (do {! phase.monad} - [[@begin offset] generation.anchor - updatesG (|> updatesS - list.enumeration - (list\map (function (_ [index updateS]) - [(n.+ offset index) updateS])) - (monad.map ! (function (_ [register updateS]) - (if (invariant? register updateS) - (wrap [..no-op - ..no-op]) - (do ! - [fetchG (translate archive updateS) - #let [storeG (_.astore register)]] - (wrap [fetchG storeG]))))))] - (wrap ($_ _.compose - ## 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\map product.left) - (monad.seq _.monad)) - (|> updatesG - list.reverse - (list\map product.right) - (monad.seq _.monad)) - (_.goto @begin))))) - -(def: #export (scope translate archive [offset initsS+ iterationS]) - (Generator [Nat (List Synthesis) Synthesis]) - (do {! phase.monad} - [@begin //runtime.forge-label - initsI+ (monad.map ! (translate archive) initsS+) - iterationG (generation.with-anchor [@begin offset] - (translate archive iterationS)) - #let [initializationG (|> (list.enumeration initsI+) - (list\map (function (_ [index initG]) - ($_ _.compose - initG - (_.astore (n.+ offset index))))) - (monad.seq _.monad))]] - (wrap ($_ _.compose - initializationG - (_.set-label @begin) - iterationG)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux deleted file mode 100644 index b23d41726..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux +++ /dev/null @@ -1,120 +0,0 @@ -(.module: - [lux (#- i64) - ["." ffi (#+ import:)] - [abstract - [monad (#+ do)]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." type] - [encoding - ["." signed]]]]] - ["." // #_ - ["#." 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: #export (bit value) - (-> Bit (Bytecode Any)) - (_.getstatic $Boolean (if value "TRUE" "FALSE") $Boolean)) - -(def: wrap-i64 - (_.invokestatic $Long "valueOf" (type.method [(list type.long) $Long (list)]))) - -(def: #export (i64 value) - (-> (I64 Any) (Bytecode Any)) - (case (.int value) - (^template [<int> <instruction>] - [<int> - (do _.monad - [_ <instruction>] - ..wrap-i64)]) - ([+0 _.lconst-0] - [+1 _.lconst-1]) - - (^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 type.double) $Double (list)]))) - -(import: java/lang/Double - (#static doubleToRawLongBits #manual [double] int)) - -(def: #export (f64 value) - (-> Frac (Bytecode Any)) - (case value - (^template [<int> <instruction>] - [<int> - (do _.monad - [_ <instruction>] - ..wrap-f64)]) - ([+1.0 _.dconst-1]) - - (^template [<int> <instruction>] - [<int> - (do _.monad - [_ <instruction> - _ _.f2d] - ..wrap-f64)]) - ([+2.0 _.fconst-2]) - - (^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: #export text - _.string) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux deleted file mode 100644 index 6166f14c1..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux +++ /dev/null @@ -1,143 +0,0 @@ -(.module: - [lux (#- Definition) - [abstract - [monad (#+ do)]] - [control - ["." try]] - [data - [collection - ["." row]] - ["." format #_ - ["#" binary]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." method (#+ Method)] - ["." version] - ["." class (#+ Class)] - [encoding - ["." name]] - ["." type - ["." reflection]]]]] - ["." // - ["#." runtime (#+ Definition)] - ["#." function/abstract]]) - -(def: #export class "LuxProgram") - -(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 ..^Args) type.void (list)])) - -(def: main::modifier - (Modifier Method) - ($_ modifier\compose - method.public - method.static - method.strict - )) - -(def: program::modifier - (Modifier Class) - ($_ modifier\compose - class.public - class.final - )) - -(def: nil //runtime.none-injection) - -(def: amount-of-inputs - (Bytecode Any) - ($_ _.compose - _.aload-0 - _.arraylength)) - -(def: decrease - (Bytecode Any) - ($_ _.compose - _.iconst-1 - _.isub)) - -(def: head - (Bytecode Any) - ($_ _.compose - _.dup - _.aload-0 - _.swap - _.aaload - _.swap - _.dup-x2 - _.pop)) - -(def: pair - (Bytecode Any) - ($_ _.compose - _.iconst-2 - (_.anewarray ^Object) - _.dup-x1 - _.swap - _.iconst-0 - _.swap - _.aastore - _.dup-x1 - _.swap - _.iconst-1 - _.swap - _.aastore)) - -(def: cons //runtime.right-injection) - -(def: input-list - (Bytecode Any) - (do _.monad - [@loop _.new-label - @end _.new-label] - ($_ _.compose - ..nil - ..amount-of-inputs - (_.set-label @loop) - ..decrease - _.dup - (_.iflt @end) - ..head - ..pair - ..cons - _.swap - (_.goto @loop) - (_.set-label @end) - _.pop))) - -(def: feed-inputs //runtime.apply) - -(def: run-io - (Bytecode Any) - ($_ _.compose - (_.checkcast //function/abstract.class) - _.aconst-null - //runtime.apply)) - -(def: #export (program program) - (-> (Bytecode Any) Definition) - (let [super-class (|> ..^Object type.reflection reflection.reflection name.internal) - main (method.method ..main::modifier "main" ..main::type - (list) - (#.Some ($_ _.compose - program - ..input-list - ..feed-inputs - ..run-io - _.return)))] - [..class - (<| (format.run class.writer) - try.assume - (class.class version.v6_0 - ..program::modifier - (name.internal ..class) - super-class - (list) - (list) - (list main) - (row.row)))])) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux deleted file mode 100644 index edffd87ff..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux +++ /dev/null @@ -1,66 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [data - [text - ["%" format (#+ format)]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." type] - [encoding - ["." unsigned]]]]] - ["." // #_ - ["#." runtime (#+ Operation)] - ["#." value] - ["#." type] - ["//#" /// #_ - [// - ["." generation] - [/// - ["#" phase ("operation\." monad)] - [reference - ["." variable (#+ Register Variable)]] - [meta - [archive (#+ Archive)]]]]]]) - -(def: #export this - (Bytecode Any) - _.aload-0) - -(template [<name> <prefix>] - [(def: #export <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 (\ ! map //runtime.class-name - (generation.context archive))] - (wrap ($_ _.compose - ..this - (_.getfield (type.class bytecode-name (list)) - (..foreign-name variable) - //type.value))))) - -(def: #export (variable archive variable) - (-> Archive Variable (Operation (Bytecode Any))) - (case variable - (#variable.Local variable) - (operation\wrap (_.aload variable)) - - (#variable.Foreign variable) - (..foreign archive variable))) - -(def: #export (constant archive name) - (-> Archive Name (Operation (Bytecode Any))) - (do {! ////.monad} - [bytecode-name (\ ! map //runtime.class-name - (generation.remember archive name))] - (wrap (_.getstatic (type.class bytecode-name (list)) //value.field //type.value)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux deleted file mode 100644 index 1c31c7ed9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux +++ /dev/null @@ -1,610 +0,0 @@ -(.module: - [lux (#- Type Definition case false true try) - [abstract - ["." monad (#+ do)] - ["." enum]] - [control - ["." try]] - [data - [binary (#+ Binary)] - [collection - ["." list ("#\." functor)] - ["." row]] - ["." format #_ - ["#" binary]] - [text - ["%" format (#+ format)]]] - [math - [number - ["n" nat] - ["." i32] - ["." i64]]] - [target - ["." jvm #_ - ["_" bytecode (#+ Label Bytecode)] - ["." modifier (#+ Modifier) ("#\." monoid)] - ["." field (#+ Field)] - ["." method (#+ Method)] - ["#/." version] - ["." class (#+ Class)] - ["." constant - [pool (#+ Resource)]] - [encoding - ["." name]] - ["." type (#+ Type) - ["." category (#+ Return' Value')] - ["." reflection]]]]] - ["." // #_ - ["#." type] - ["#." value] - ["#." function #_ - ["#" abstract] - [field - [constant - ["#/." arity]] - [variable - [partial - ["#/." count]]]]] - ["//#" /// #_ - [// - ["." version] - ["." synthesis] - ["." generation] - [/// - ["#" phase] - [arity (#+ Arity)] - [reference - [variable (#+ Register)]] - [meta - [io (#+ lux_context)] - [archive (#+ Archive)]]]]]]) - -(type: #export Byte_Code Binary) - -(type: #export Definition [Text Byte_Code]) - -(type: #export Anchor [Label Register]) - -(template [<name> <base>] - [(type: #export <name> - (<base> Anchor (Bytecode Any) Definition))] - - [Operation generation.Operation] - [Phase generation.Phase] - [Handler generation.Handler] - [Bundle generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation (Bytecode Any)))) - -(type: #export Host - (generation.Host (Bytecode Any) Definition)) - -(def: #export (class_name [module id]) - (-> generation.Context Text) - (format lux_context - "/" (%.nat version.version) - "/" (%.nat module) - "/" (%.nat id))) - -(def: artifact_id - 0) - -(def: #export class - (type.class (%.nat ..artifact_id) (list))) - -(def: procedure - (-> Text (Type category.Method) (Bytecode Any)) - (_.invokestatic ..class)) - -(def: modifier - (Modifier Method) - ($_ modifier\compose - method.public - method.static - method.strict - )) - -(def: this - (Bytecode Any) - _.aload_0) - -(def: #export (get index) - (-> (Bytecode Any) (Bytecode Any)) - ($_ _.compose - index - _.aaload)) - -(def: (set! index value) - (-> (Bytecode Any) (Bytecode Any) (Bytecode Any)) - ($_ _.compose - ## A - _.dup ## AA - index ## AAI - value ## AAIV - _.aastore ## A - )) - -(def: #export unit (_.string synthesis.unit)) - -(def: variant::name "variant") -(def: variant::type (type.method [(list //type.tag //type.flag //type.value) //type.variant (list)])) -(def: #export variant (..procedure ..variant::name ..variant::type)) - -(def: variant_tag _.iconst_0) -(def: variant_last? _.iconst_1) -(def: variant_value _.iconst_2) - -(def: variant::method - (let [new_variant ($_ _.compose - _.iconst_3 - (_.anewarray //type.value)) - $tag ($_ _.compose - _.iload_0 - (//value.wrap type.int)) - $last? _.aload_1 - $value _.aload_2] - (method.method ..modifier ..variant::name - ..variant::type - (list) - (#.Some ($_ _.compose - new_variant ## A[3] - (..set! ..variant_tag $tag) ## A[3] - (..set! ..variant_last? $last?) ## A[3] - (..set! ..variant_value $value) ## A[3] - _.areturn))))) - -(def: #export left_flag _.aconst_null) -(def: #export right_flag ..unit) - -(def: #export left_injection - (Bytecode Any) - ($_ _.compose - _.iconst_0 - ..left_flag - _.dup2_x1 - _.pop2 - ..variant)) - -(def: #export right_injection - (Bytecode Any) - ($_ _.compose - _.iconst_1 - ..right_flag - _.dup2_x1 - _.pop2 - ..variant)) - -(def: #export some_injection ..right_injection) - -(def: #export none_injection - (Bytecode Any) - ($_ _.compose - _.iconst_0 - ..left_flag - ..unit - ..variant)) - -(def: (risky $unsafe) - (-> (Bytecode Any) (Bytecode Any)) - (do _.monad - [@try _.new_label - @handler _.new_label] - ($_ _.compose - (_.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 //type.text) //type.variant (list)])) -(def: #export decode_frac (..procedure ..decode_frac::name ..decode_frac::type)) - -(def: decode_frac::method - (method.method ..modifier ..decode_frac::name - ..decode_frac::type - (list) - (#.Some - (..risky - ($_ _.compose - _.aload_0 - (_.invokestatic //type.frac "parseDouble" (type.method [(list //type.text) type.double (list)])) - (//value.wrap type.double) - ))))) - -(def: #export 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 //type.value) type.void (list)]) - print! (function (_ method) (_.invokevirtual ^PrintStream method print_type))] - ($_ _.compose - out (_.string "LUX LOG: ") (print! "print") - out _.swap (print! "println")))) - -(def: exception_constructor (type.method [(list //type.text) type.void (list)])) -(def: (illegal_state_exception message) - (-> Text (Bytecode Any)) - (let [^IllegalStateException (type.class "java.lang.IllegalStateException" (list))] - ($_ _.compose - (_.new ^IllegalStateException) - _.dup - (_.string message) - (_.invokespecial ^IllegalStateException "<init>" ..exception_constructor)))) - -(def: failure::type - (type.method [(list) type.void (list)])) - -(def: (failure name message) - (-> Text Text (Resource Method)) - (method.method ..modifier name - ..failure::type - (list) - (#.Some - ($_ _.compose - (..illegal_state_exception message) - _.athrow)))) - -(def: pm_failure::name "pm_failure") -(def: #export pm_failure (..procedure ..pm_failure::name ..failure::type)) - -(def: pm_failure::method - (..failure ..pm_failure::name "Invalid expression for pattern-matching.")) - -(def: #export stack_head _.iconst_0) -(def: #export stack_tail _.iconst_1) - -(def: push::name "push") -(def: push::type (type.method [(list //type.stack //type.value) //type.stack (list)])) -(def: #export push (..procedure ..push::name ..push::type)) - -(def: push::method - (method.method ..modifier ..push::name - ..push::type - (list) - (#.Some - (let [new_stack_frame! ($_ _.compose - _.iconst_2 - (_.anewarray //type.value)) - $head _.aload_1 - $tail _.aload_0] - ($_ _.compose - new_stack_frame! - (..set! ..stack_head $head) - (..set! ..stack_tail $tail) - _.areturn))))) - -(def: case::name "case") -(def: case::type (type.method [(list //type.variant //type.tag //type.flag) //type.value (list)])) -(def: #export case (..procedure ..case::name ..case::type)) - -(def: case::method - (method.method ..modifier ..case::name ..case::type - (list) - (#.Some - (do _.monad - [@loop _.new_label - @perfect_match! _.new_label - @tags_match! _.new_label - @maybe_nested _.new_label - @mismatch! _.new_label - #let [::tag ($_ _.compose - (..get ..variant_tag) - (//value.unwrap type.int)) - ::last? (..get ..variant_last?) - ::value (..get ..variant_value) - - $variant _.aload_0 - $tag _.iload_1 - $last? _.aload_2 - - not_found _.aconst_null - - update_$tag _.isub - update_$variant ($_ _.compose - $variant ::value - (_.checkcast //type.variant) - _.astore_0) - recur (: (-> Label (Bytecode Any)) - (function (_ @loop_start) - ($_ _.compose - ## tag, sumT - update_$variant ## tag, sumT - update_$tag ## sub_tag - (_.goto @loop_start)))) - - super_nested_tag ($_ _.compose - ## tag, sumT - _.swap ## sumT, tag - _.isub) - super_nested ($_ _.compose - ## tag, sumT - super_nested_tag ## super_tag - $variant ::last? ## super_tag, super_last - $variant ::value ## super_tag, super_last, super_value - ..variant)]] - ($_ _.compose - $tag - (_.set_label @loop) - $variant ::tag - _.dup2 (_.if_icmpeq @tags_match!) - _.dup2 (_.if_icmpgt @maybe_nested) - $last? (_.ifnull @mismatch!) ## tag, sumT - super_nested ## super_variant - _.areturn - (_.set_label @tags_match!) ## tag, sumT - $last? ## tag, sumT, wants_last? - $variant ::last? ## tag, sumT, wants_last?, is_last? - (_.if_acmpeq @perfect_match!) ## tag, sumT - (_.set_label @maybe_nested) ## tag, sumT - $variant ::last? ## tag, sumT, last? - (_.ifnull @mismatch!) ## tag, sumT - (recur @loop) - (_.set_label @perfect_match!) ## tag, sumT - ## _.pop2 - $variant ::value - _.areturn - (_.set_label @mismatch!) ## tag, sumT - ## _.pop2 - not_found - _.areturn - ))))) - -(def: projection_type (type.method [(list //type.tuple //type.offset) //type.value (list)])) - -(def: left_projection::name "left") -(def: #export left_projection (..procedure ..left_projection::name ..projection_type)) - -(def: right_projection::name "right") -(def: #export right_projection (..procedure ..right_projection::name ..projection_type)) - -(def: projection::method2 - [(Resource Method) (Resource Method)] - (let [$tuple _.aload_0 - $tuple::size ($_ _.compose - $tuple _.arraylength) - - $lefts _.iload_1 - - $last_right ($_ _.compose - $tuple::size _.iconst_1 _.isub) - - update_$lefts ($_ _.compose - $lefts $last_right _.isub - _.istore_1) - update_$tuple ($_ _.compose - $tuple $last_right _.aaload (_.checkcast //type.tuple) - _.astore_0) - recur (: (-> Label (Bytecode Any)) - (function (_ @loop) - ($_ _.compose - update_$lefts - update_$tuple - (_.goto @loop)))) - - left_projection::method - (method.method ..modifier ..left_projection::name ..projection_type - (list) - (#.Some - (do _.monad - [@loop _.new_label - @recursive _.new_label - #let [::left ($_ _.compose - $lefts _.aaload)]] - ($_ _.compose - (_.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 ..projection_type - (list) - (#.Some - (do _.monad - [@loop _.new_label - @not_tail _.new_label - @slice _.new_label - #let [$right ($_ _.compose - $lefts - _.iconst_1 - _.iadd) - $::nested ($_ _.compose - $tuple _.swap _.aaload) - super_nested ($_ _.compose - $tuple - $right - $tuple::size - (_.invokestatic (type.class "java.util.Arrays" (list)) "copyOfRange" - (type.method [(list //type.tuple //type.index //type.index) //type.tuple (list)])))]] - ($_ _.compose - (_.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: #export apply::name "apply") - -(def: #export (apply::type arity) - (-> Arity (Type category.Method)) - (type.method [(list.repeat arity //type.value) //type.value (list)])) - -(def: #export apply - (_.invokevirtual //function.class ..apply::name (..apply::type 1))) - -(def: try::name "try") -(def: try::type (type.method [(list //function.class) //type.variant (list)])) -(def: #export try (..procedure ..try::name ..try::type)) - -(def: false _.iconst_0) -(def: true _.iconst_1) - -(def: try::method - (method.method ..modifier ..try::name ..try::type - (list) - (#.Some - (do _.monad - [@try _.new_label - @handler _.new_label - #let [$unsafe ..this - unit _.aconst_null - - ^StringWriter (type.class "java.io.StringWriter" (list)) - string_writer ($_ _.compose - (_.new ^StringWriter) - _.dup - (_.invokespecial ^StringWriter "<init>" (type.method [(list) type.void (list)]))) - - ^PrintWriter (type.class "java.io.PrintWriter" (list)) - print_writer ($_ _.compose - ## WTW - (_.new ^PrintWriter) ## WTWP - _.dup_x1 ## WTPWP - _.swap ## WTPPW - ..true ## WTPPWZ - (_.invokespecial ^PrintWriter "<init>" (type.method [(list (type.class "java.io.Writer" (list)) type.boolean) type.void (list)])) - ## WTP - )]] - ($_ _.compose - (_.try @try @handler @handler //type.error) - (_.set_label @try) - $unsafe unit ..apply - ..right_injection _.areturn - (_.set_label @handler) ## T - string_writer ## TW - _.dup_x1 ## WTW - print_writer ## WTP - (_.invokevirtual //type.error "printStackTrace" (type.method [(list ^PrintWriter) type.void (list)])) ## W - (_.invokevirtual ^StringWriter "toString" (type.method [(list) //type.text (list)])) ## 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 Any) - (let [class (..reflection ..class) - modifier (: (Modifier Class) - ($_ modifier\compose - class.public - class.final)) - bytecode (<| (format.run class.writer) - try.assume - (class.class jvm/version.v6_0 - modifier - (name.internal class) - (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)) - (row.row)))] - (do ////.monad - [_ (generation.execute! [class bytecode])] - (generation.save! ..artifact_id [class bytecode])))) - -(def: generate_function - (Operation Any) - (let [apply::method+ (|> (enum.range n.enum - (inc //function/arity.minimum) - //function/arity.maximum) - (list\map (function (_ arity) - (method.method method.public ..apply::name (..apply::type arity) - (list) - (#.Some - (let [previous_inputs (|> arity - list.indices - (monad.map _.monad _.aload))] - ($_ _.compose - previous_inputs - (_.invokevirtual //function.class ..apply::name (..apply::type (dec arity))) - (_.checkcast //function.class) - (_.aload arity) - (_.invokevirtual //function.class ..apply::name (..apply::type //function/arity.minimum)) - _.areturn)))))) - (list& (method.method (modifier\compose method.public method.abstract) - ..apply::name (..apply::type //function/arity.minimum) - (list) - #.None))) - <init>::method (method.method method.public "<init>" //function.init - (list) - (#.Some - (let [$partials _.iload_1] - ($_ _.compose - ..this - (_.invokespecial ^Object "<init>" (type.method [(list) type.void (list)])) - ..this - $partials - (_.putfield //function.class //function/count.field //function/count.type) - _.return)))) - modifier (: (Modifier Class) - ($_ modifier\compose - class.public - class.abstract)) - class (..reflection //function.class) - partial_count (: (Resource Field) - (field.field (modifier\compose field.public field.final) - //function/count.field - //function/count.type - (row.row))) - bytecode (<| (format.run class.writer) - try.assume - (class.class jvm/version.v6_0 - modifier - (name.internal class) - (name.internal (..reflection ^Object)) (list) - (list partial_count) - (list& <init>::method apply::method+) - (row.row)))] - (do ////.monad - [_ (generation.execute! [class bytecode])] - (generation.save! //function.artifact_id [class bytecode])))) - -(def: #export generate - (Operation Any) - (do ////.monad - [_ ..generate_runtime] - ..generate_function)) - -(def: #export 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. - (\ ////.monad map (i64.left_shift shift) generation.next))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux deleted file mode 100644 index b89bbca35..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux +++ /dev/null @@ -1,94 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - [number - ["." i32]] - [collection - ["." list]]] - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." type] - [encoding - ["." signed]]]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - [/// - ["." phase]]]]) - -(def: $Object - (type.class "java.lang.Object" (list))) - -(def: #export (tuple generate archive membersS) - (Generator (Tuple Synthesis)) - (case membersS - #.Nil - (\ phase.monad wrap //runtime.unit) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (do {! phase.monad} - [membersI (|> membersS - list.enumeration - (monad.map ! (function (_ [idx member]) - (do ! - [memberI (generate archive member)] - (wrap (do _.monad - [_ _.dup - _ (_.int (.i64 idx)) - _ memberI] - _.aastore))))))] - (wrap (do {! _.monad} - [_ (_.int (.i64 (list.size membersS))) - _ (_.anewarray $Object)] - (monad.seq ! membersI)))))) - -(def: #export (tag lefts right?) - (-> Nat Bit (Bytecode Any)) - (case (if right? - (.inc lefts) - lefts) - 0 _.iconst-0 - 1 _.iconst-1 - 2 _.iconst-2 - 3 _.iconst-3 - 4 _.iconst-4 - 5 _.iconst-5 - tag (case (signed.s1 (.int tag)) - (#try.Success value) - (_.bipush value) - - (#try.Failure _) - (case (signed.s2 (.int tag)) - (#try.Success value) - (_.sipush value) - - (#try.Failure _) - (_.int (.i64 tag)))))) - -(def: #export (flag right?) - (-> Bit (Bytecode Any)) - (if right? - //runtime.right-flag - //runtime.left-flag)) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (do phase.monad - [valueI (generate archive valueS)] - (wrap (do _.monad - [_ (..tag lefts right?) - _ (..flag right?) - _ valueI] - (_.invokestatic //runtime.class "variant" - (type.method [(list type.int $Object $Object) - (type.array $Object) - (list)])))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux deleted file mode 100644 index 954740d2d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux +++ /dev/null @@ -1,22 +0,0 @@ -(.module: - [lux #* - [target - [jvm - ["." type]]]]) - -(def: #export frac (type.class "java.lang.Double" (list))) -(def: #export text (type.class "java.lang.String" (list))) - -(def: #export value (type.class "java.lang.Object" (list))) - -(def: #export tag type.int) -(def: #export flag ..value) -(def: #export variant (type.array ..value)) - -(def: #export offset type.int) -(def: #export index ..offset) -(def: #export tuple (type.array ..value)) - -(def: #export stack (type.array ..value)) - -(def: #export error (type.class "java.lang.Throwable" (list))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux deleted file mode 100644 index 206af53b8..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux +++ /dev/null @@ -1,48 +0,0 @@ -(.module: - [lux (#- Type type) - [target - [jvm - ["_" bytecode (#+ Bytecode)] - ["." type (#+ Type) ("#\." equivalence) - [category (#+ Primitive)] - ["." box]]]]]) - -(def: #export field "value") - -(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>] - [(def: (<name> type) - (-> (Type Primitive) Text) - (`` (cond (~~ (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: #export (wrap type) - (-> (Type Primitive) (Bytecode Any)) - (let [wrapper (type.class (primitive-wrapper type) (list))] - (_.invokestatic wrapper "valueOf" - (type.method [(list type) wrapper (list)])))) - -(def: #export (unwrap type) - (-> (Type Primitive) (Bytecode Any)) - (let [wrapper (type.class (primitive-wrapper type) (list))] - ($_ _.compose - (_.checkcast wrapper) - (_.invokevirtual wrapper (primitive-unwrap type) (type.method [(list) type (list)]))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux deleted file mode 100644 index 3f64c53bf..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux +++ /dev/null @@ -1,118 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" lua]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([synthesis.bit] - [synthesis.i64] - [synthesis.f64] - [synthesis.text] - [synthesis.variant] - [synthesis.tuple] - [#synthesis.Reference] - [synthesis.branch/get] - [synthesis.function/apply] - [#synthesis.Extension]) - - (^ (synthesis.branch/case case)) - (/case.case! statement expression archive case) - - (^ (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 //////phase.monad - [[inits scope!] (/loop.scope! statement expression archive false scope)] - (wrap scope!)) - - (^ (synthesis.loop/recur updates)) - (/loop.recur! statement expression archive updates) - - (^ (synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<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 ..statement expression archive case) - - (^ (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 ..statement expression archive scope) - - (^ (synthesis.loop/recur updates)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (^ (synthesis.function/abstraction abstraction)) - (/function.function ..statement expression archive abstraction) - - (^ (synthesis.function/apply application)) - (/function.apply expression archive application) - - (#synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux deleted file mode 100644 index 6a2101fe3..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/case.lux +++ /dev/null @@ -1,279 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [target - ["_" lua (#+ Expression Var Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (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. - (wrap (|> bodyO - _.return - (_.closure (list (..register register))) - (_.apply/* (list valueO)))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (statement expression archive bodyS)] - (wrap ($_ _.then - (_.local/1 (..register register) valueO) - bodyO)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueO - (list.reverse pathP))))) - -(def: #export (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)] - (wrap (|> (_.if testO - (_.return thenO) - (_.return elseO)) - (_.closure (list)) - (_.apply/* (list)))))) - -(def: #export (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)] - (wrap (_.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 - (_.nth (_.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) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat Statement) - ($_ _.then - (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) - (.if simple? - (_.when (_.= _.nil @temp) - fail!) - (_.if (_.= _.nil @temp) - fail! - (..push! @temp)))))] - - [left_choice _.nil (<|)] - [right_choice (_.string "") inc] - ) - -(def: (alternation pre! post!) - (-> Statement Statement Statement) - ($_ _.then - (_.while (_.bool true) - ($_ _.then - ..save! - pre!)) - ($_ _.then - ..restore! - post!))) - -(def: (pattern_matching' statement expression archive) - (-> Phase! Phase Archive Path (Operation Statement)) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.local/1 (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(_.= (|> match <format>) - ..peek) - then!]))) - (#.Cons cons))] - (wrap (_.cond clauses ..fail!)))]) - ([#/////synthesis.I64_Fork (<| _.int .int)] - [#/////synthesis.F64_Fork _.float] - [#/////synthesis.Text_Fork _.string]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (///////phase\map (_.then (<choice> true idx)) (recur nextP))]) - ([/////synthesis.side/left /////synthesis.simple_left_side ..left_choice] - [/////synthesis.side/right /////synthesis.simple_right_side ..right_choice]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (|> ..peek (_.nth (_.int +1)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..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! (recur thenP)] - (///////phase\wrap ($_ _.then - (_.local/1 (..register register) ..peek_and_pop) - then!))) - - (^template [<tag> <combinator>] - [(^ (<tag> preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP)] - (wrap (<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)] - (wrap ($_ _.then - (_.while (_.bool true) - pattern_matching!) - (_.statement (|> (_.var "error") (_.apply/* (list (_.string ////synthesis/case.pattern_matching_error))))))))) - -(def: #export dependencies - (-> Path (List Var)) - (|>> ////synthesis/case.storage - (get@ #////synthesis/case.dependencies) - set.to_list - (list\map (function (_ variable) - (.case variable - (#///////variable.Local register) - (..register register) - - (#///////variable.Foreign register) - (..capture register)))))) - -(def: #export (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)] - (wrap ($_ _.then - (_.local (list @temp)) - (_.local/1 @cursor (_.array (list stack_init))) - (_.local/1 @savepoint (_.array (list))) - pattern_matching!)))) - -(def: #export (case statement expression archive [valueS pathP]) - (-> Phase! (Generator [Synthesis Path])) - (|> [valueS pathP] - (..case! statement expression archive) - (\ ///////phase.monad map - (|>> (_.closure (list)) - (_.apply/* (list)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux deleted file mode 100644 index 55490d3f2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/function.lux +++ /dev/null @@ -1,136 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" lua (#+ Var Expression Label Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* argsO+ functionO)))) - -(def: capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure inits @self @args body!) - (-> (List Expression) Var (List Var) Statement [Statement Expression]) - (case inits - #.Nil - [(_.function @self @args body!) - @self] - - _ - (let [@inits (|> (list.enumeration inits) - (list\map (|>> product.left ..capture)))] - [(_.function @self @inits - ($_ _.then - (_.local_function @self @args body!) - (_.return @self))) - (_.apply/* inits @self)]))) - -(def: input - (|>> inc //case.register)) - -(def: (@scope function_name) - (-> Context Label) - (_.label (format (///reference.artifact function_name) "_scope"))) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[function_name body!] (/////generation.with_new_context archive - (do ! - [@scope (\ ! map ..@scope - (/////generation.context archive))] - (/////generation.with_anchor [1 @scope] - (statement expression archive bodyS)))) - closureO+ (monad.map ! (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\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.local/1 (..input post) (_.nth (|> post inc .int _.int) @curried)))) - initialize_self! - (list.indices arity)) - pack (|>> (list) _.array) - unpack (_.apply/1 (_.var "table.unpack")) - @var_args (_.var "...")] - #let [[definition instantiation] (with_closure closureO+ @self (list @var_args) - ($_ _.then - (_.local/1 @curried (pack @var_args)) - (_.local/1 @num_args (_.length @curried)) - (_.cond (list [(|> @num_args (_.= arityO)) - ($_ _.then - initialize! - (_.set_label @scope) - body!)] - [(|> @num_args (_.> arityO)) - (let [arity_inputs (_.apply/5 (_.var "table.move") - @curried - (_.int +1) - arityO - (_.int +1) - (_.array (list))) - extra_inputs (_.apply/5 (_.var "table.move") - @curried - (_.+ (_.int +1) arityO) - @num_args - (_.int +1) - (_.array (list)))] - (_.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")] - ($_ _.then - (_.local/1 @extra_args (pack @var_args)) - (_.return (|> (_.array (list)) - (_.apply/5 (_.var "table.move") - @curried - (_.int +1) - @num_args - (_.int +1)) - (_.apply/5 (_.var "table.move") - @extra_args - (_.int +1) - (_.length @extra_args) - (_.+ (_.int +1) @num_args)) - unpack - (_.apply/1 @self)))))))) - ))] - _ (/////generation.execute! definition) - _ (/////generation.save! (product.right function_name) definition)] - (wrap instantiation))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux deleted file mode 100644 index e95fc0f49..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux +++ /dev/null @@ -1,118 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)] - ["." set]]] - [math - [number - ["n" nat]]] - [target - ["_" lua (#+ Var Expression Label Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ 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\map (|>> product.left (n.+ offset) //case.register)))] - (if as_expression? - body - ($_ _.then - (if initial? - (_.let variables (_.multi bindings)) - (_.set variables (_.multi bindings))) - body)))) - -(def: #export (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 - #.Nil - (|> bodyS - (statement expression archive) - (\ ///////phase.monad map (|>> [(list)]))) - - ## true loop - _ - (do {! ///////phase.monad} - [@scope (\ ! map ..@scope /////generation.next) - initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor [start @scope] - (statement expression archive bodyS))] - (wrap [initsO+ - (..setup true start initsO+ as_expression? - ($_ _.then - (_.set_label @scope) - body!))])))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [[[artifact_module artifact_id] [initsO+ scope!]] (/////generation.with_new_context archive - (scope! statement expression archive true [start initsS+ bodyS])) - #let [@loop (_.var (///reference.artifact [artifact_module artifact_id])) - locals (|> initsO+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register))) - [directive instantiation] (: [Statement Expression] - (case (|> (synthesis.path/then bodyS) - //case.dependencies - (set.from_list _.hash) - (set.difference (set.from_list _.hash locals)) - set.to_list) - #.Nil - [(_.function @loop locals - scope!) - @loop] - - foreigns - (let [@context (_.var (format (_.code @loop) "_context"))] - [(_.function @context foreigns - ($_ _.then - (<| (_.local_function @loop locals) - scope!) - (_.return @loop) - )) - (|> @context (_.apply/* foreigns))])))] - _ (/////generation.execute! directive) - _ (/////generation.save! artifact_id directive)] - (wrap (|> instantiation (_.apply/* initsO+)))))) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [[offset @scope] /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (..setup false offset argsO+ false (_.go_to @scope))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux deleted file mode 100644 index 6cce70f05..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" lua (#+ Literal)]]]) - -(template [<name> <type> <implementation>] - [(def: #export <name> - (-> <type> Literal) - <implementation>)] - - [bit Bit _.bool] - [i64 (I64 Any) (|>> .int _.int)] - [f64 Frac _.float] - [text Text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux deleted file mode 100644 index 72a54569c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" lua (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux deleted file mode 100644 index 0da87ff6a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux +++ /dev/null @@ -1,431 +0,0 @@ -(.module: - [lux (#- Location inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" lua (#+ Expression Location Var Computation Literal Label Statement)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> [Register Label] Expression Statement))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation Statement))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation Statement))) - -(def: #export unit - (_.string /////synthesis.unit)) - -(def: (flag value) - (-> Bit Literal) - (if value - ..unit - _.nil)) - -(def: #export variant_tag_field "_lux_tag") -(def: #export variant_flag_field "_lux_flag") -(def: #export 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: #export (variant tag last? value) - (-> Nat Bit Expression Literal) - (variant' (_.int (.int tag)) - (flag last?) - value)) - -(def: #export none - Literal - (..variant 0 #0 ..unit)) - -(def: #export some - (-> Expression Literal) - (..variant 1 #1)) - -(def: #export left - (-> Expression Literal) - (..variant 0 #0)) - -(def: #export right - (-> Expression Literal) - (..variant 1 #1)) - -(def: (feature name definition) - (-> Var (-> Var Statement) Statement) - (definition name)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(def: module_id - 0) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - Var - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!name)) - (_.set (~ g!name) (~ code)))))))))) - - (#.Right [name inputs]) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) Computation) - (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!_)) - (..with_vars [(~+ inputsC)] - (_.function (~ g!_) (list (~+ inputsC)) - (~ code)))))))))))))))) - -(def: (nth index table) - (-> Expression Expression Location) - (_.nth (_.+ (_.int +1) index) table)) - -(def: last_index - (|>> _.length (_.- (_.int +1)))) - -(with_expansions [<recur> (as_is ($_ _.then - (_.set (list lefts) (_.- last_index_right lefts)) - (_.set (list tuple) (..nth last_index_right tuple))))] - (runtime: (tuple//left lefts tuple) - (with_vars [last_index_right] - (<| (_.while (_.bool true)) - ($_ _.then - (_.local/1 last_index_right (..last_index tuple)) - (_.if (_.> lefts last_index_right) - ## No need for recursion - (_.return (..nth lefts tuple)) - ## Needs recursion - <recur>))))) - - (runtime: (tuple//right lefts tuple) - (with_vars [last_index_right right_index] - (<| (_.while (_.bool true)) - ($_ _.then - (_.local/1 last_index_right (..last_index tuple)) - (_.local/1 right_index (_.+ (_.int +1) lefts)) - (_.cond (list [(_.= last_index_right right_index) - (_.return (..nth right_index tuple))] - [(_.> 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 wants_last wanted_tag) - (let [no_match! (_.return _.nil) - sum_tag (_.the ..variant_tag_field sum) - sum_flag (_.the ..variant_flag_field sum) - sum_value (_.the ..variant_value_field sum) - is_last? (_.= ..unit sum_flag) - extact_match! (_.return sum_value) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.then - (_.set (list wanted_tag) (_.- sum_tag wanted_tag)) - (_.set (list sum) sum_value)) - no_match!) - extrac_sub_variant! (_.return (variant' (_.- wanted_tag sum_tag) sum_flag sum_value))] - (<| (_.while (_.bool true)) - (_.cond (list [(_.= sum_tag wanted_tag) - (_.if (_.= wants_last sum_flag) - extact_match! - test_recursion!)] - [(_.< wanted_tag sum_tag) - test_recursion!] - [(_.= ..unit wants_last) - extrac_sub_variant!]) - no_match!)))) - -(def: runtime//adt - Statement - ($_ _.then - @tuple//left - @tuple//right - @sum//get - )) - -(runtime: (lux//try risky) - (with_vars [success value] - ($_ _.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] - ($_ _.then - (_.let (list tail) ..none) - (<| (_.for_step idx (_.length raw) (_.int +1) (_.int -1)) - (_.set (list tail) (..some (_.array (list (_.nth idx raw) - tail))))) - (_.return tail)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program_args - )) - -(def: cap_shift - (_.% (_.int +64))) - -(runtime: (i64//left_shift param subject) - (_.return (_.bit_shl (..cap_shift param) subject))) - -(runtime: (i64//right_shift param subject) - (let [mask (|> (_.int +1) - (_.bit_shl (_.- param (_.int +64))) - (_.- (_.int +1)))] - ($_ _.then - (_.set (list param) (..cap_shift param)) - (_.return (|> subject - (_.bit_shr param) - (_.bit_and mask)))))) - -(runtime: (i64//division param subject) - (with_vars [floored] - ($_ _.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 - ($_ _.then - @i64//left_shift - @i64//right_shift - @i64//division - @i64//remainder - )) - -(def: (find_byte_index subject param start) - (-> Expression Expression Expression Expression) - (_.apply/4 (_.var "string.find") subject param start (_.bool #1))) - -(def: (char_index subject byte_index) - (-> Expression Expression Expression) - (|> byte_index - (_.apply/3 (_.var "utf8.len") subject (_.int +1)))) - -(def: (byte_index subject char_index) - (-> Expression Expression Expression) - (|> char_index - (_.+ (_.int +1)) - (_.apply/2 (_.var "utf8.offset") subject))) - -(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> ($_ _.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> ($_ _.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/3 (_.var "string.sub") text (_.+ (_.int +1) offset) (_.+ offset length))) - <normal> (_.return (_.apply/3 (_.var "string.sub") - text - (..byte_index text offset) - (|> (_.+ offset length) - ## (_.+ (_.int +1)) - (..byte_index text) - (_.- (_.int +1)))))] - (for {@.lua <normal>} - (_.if ..on_rembulan? - <rembulan> - <normal>)))) - -(runtime: (text//size subject) - (with_expansions [<rembulan> (_.return (_.apply/1 (_.var "string.len") subject)) - <normal> (_.return (_.apply/1 (_.var "utf8.len") subject))] - (for {@.lua <normal>} - (_.if ..on_rembulan? - <rembulan> - <normal>)))) - -(runtime: (text//char idx text) - (with_expansions [<rembulan> (with_vars [char] - ($_ _.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] - ($_ _.then - (_.local/1 offset (_.apply/2 (_.var "utf8.offset") text idx)) - (_.if (_.= _.nil offset) - (_.statement (_.error/1 (_.string "[Lux Error] Cannot get char from text."))) - (_.return (_.apply/2 (_.var "utf8.codepoint") text offset)))))] - (for {@.lua <normal>} - (_.if ..on_rembulan? - <rembulan> - <normal>)))) - -(def: runtime//text - Statement - ($_ _.then - @text//index - @text//clip - @text//size - @text//char - )) - -(runtime: (array//write idx value array) - ($_ _.then - (_.set (list (..nth idx array)) value) - (_.return array))) - -(def: runtime//array - Statement - ($_ _.then - @array//write - )) - -(def: runtime - Statement - ($_ _.then - ..runtime//adt - ..runtime//lux - ..runtime//i64 - ..runtime//text - ..runtime//array - )) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux deleted file mode 100644 index 0d96fe6df..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" lua (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple generate archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (generate archive)) - (///////phase\map _.array)))) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant tag right?) - (generate archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux deleted file mode 100644 index 654c07bdf..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" php]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([////synthesis.bit] - [////synthesis.i64] - [////synthesis.f64] - [////synthesis.text] - [////synthesis.variant] - [////synthesis.tuple] - [#////synthesis.Reference] - [////synthesis.branch/get] - [////synthesis.function/apply] - [#////synthesis.Extension]) - - (^ (////synthesis.branch/case case)) - (/case.case! statement expression archive case) - - (^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/recur /loop.recur!]) - - (^ (////synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: #export (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<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) - - (^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]) - - (^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/recur _)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (#////synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux deleted file mode 100644 index 728902418..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/case.lux +++ /dev/null @@ -1,297 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["i" int]]] - [target - ["_" php (#+ Expression Var Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueG (expression archive valueS) - bodyG (expression archive bodyS)] - (wrap (|> bodyG - (list (_.set (..register register) valueG)) - _.array/* - (_.nth (_.int +1)))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - body! (statement expression archive bodyS)] - (wrap ($_ _.then - (_.set! (..register register) valueO) - body!)))) - -(def: #export (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)] - (wrap (_.? testG thenG elseG)))) - -(def: #export (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)] - (wrap (_.if test! - then! - else!)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueG (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueG - (list.reverse 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 - (_.nth (|> @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)))]))) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat Statement) - ($_ _.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 "") inc] - ) - -(def: (alternation pre! post!) - (-> Statement Statement Statement) - ($_ _.then - (_.do_while (_.bool false) - ($_ _.then - ..save! - pre!)) - ($_ _.then - ..restore! - post!))) - -(def: (pattern_matching' statement expression archive) - (Generator! Path) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.set! (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(_.=== (|> match <format>) - ..peek) - then!]))) - (#.Cons cons))] - (wrap (_.cond clauses ..fail!)))]) - ([#/////synthesis.I64_Fork //primitive.i64] - [#/////synthesis.F64_Fork //primitive.f64] - [#/////synthesis.Text_Fork //primitive.text]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - recur - (\ ///////phase.monad map (_.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\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..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! (recur thenP)] - (///////phase\wrap ($_ _.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! (recur nextP')] - ## (///////phase\wrap ($_ _.then - ## (..multi_pop! (n.+ 2 extra_pops)) - ## next!)))) - - (^template [<tag> <combinator>] - [(^ (<tag> preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP)] - (wrap (<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)] - (wrap ($_ _.then - (_.do_while (_.bool false) - iteration!) - (_.throw (_.new (_.constant "Exception") (list (_.string ////synthesis/case.pattern_matching_error)))))))) - -(def: (gensym prefix) - (-> Text (Operation Text)) - (\ ///////phase.monad map (|>> %.nat (format prefix)) /////generation.next)) - -(def: #export dependencies - (-> Path (List Var)) - (|>> ////synthesis/case.storage - (get@ #////synthesis/case.dependencies) - set.to_list - (list\map (function (_ variable) - (.case variable - (#///////variable.Local register) - (..register register) - - (#///////variable.Foreign register) - (..capture register)))))) - -(def: #export (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)] - (wrap ($_ _.then - (_.set! @cursor (_.array/* (list stack_init))) - (_.set! @savepoint (_.array/* (list))) - pattern_matching!)))) - -(def: #export (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)) - directive (_.define_function @case (list\map _.parameter @dependencies+) case!)] - _ (/////generation.execute! directive) - _ (/////generation.save! case_artifact directive)] - (wrap (_.apply/* @dependencies+ @case)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux deleted file mode 100644 index 3bc0a0887..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common]]) - -(def: #export bundle - Bundle - common.bundle) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux deleted file mode 100644 index 2a4c4c50d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux +++ /dev/null @@ -1,111 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." function]] - [data - ["." product] - ["." text] - [number - ["f" frac]] - [collection - ["." dictionary]]] - [target - ["_" php (#+ Expression)]]] - ["." /// #_ - ["#." runtime (#+ Operation Phase Handler Bundle)] - ["#." primitive] - [// - [extension (#+ Nullary Unary Binary Trinary - nullary unary binary trinary)] - [// - [extension - ["." bundle]]]]]) - -(def: lux-procs - Bundle - (|> bundle.empty - (bundle.install "is" (binary (product.uncurry _.=))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(def: i64-procs - Bundle - (<| (bundle.prefix "i64") - (|> bundle.empty - (bundle.install "and" (binary (product.uncurry _.bit-and))) - (bundle.install "or" (binary (product.uncurry _.bit-or))) - (bundle.install "xor" (binary (product.uncurry _.bit-xor))) - (bundle.install "left-shift" (binary (product.uncurry _.bit-shl))) - (bundle.install "logical-right-shift" (binary (product.uncurry ///runtime.i64//logic-right-shift))) - (bundle.install "arithmetic-right-shift" (binary (product.uncurry _.bit-shr))) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - ))) - -(def: int-procs - Bundle - (<| (bundle.prefix "int") - (|> bundle.empty - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.%))) - (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.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.%))) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "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.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "concat" (binary (product.uncurry _.concat))) - (bundle.install "index" (trinary text//index)) - (bundle.install "size" (unary _.strlen/1)) - (bundle.install "char" (binary (function (text//char [text idx]) - (|> text (_.nth 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: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> lux-procs - (dictionary.merge i64-procs) - (dictionary.merge int-procs) - (dictionary.merge frac-procs) - (dictionary.merge text-procs) - (dictionary.merge io-procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux deleted file mode 100644 index 1194cfe9a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/function.lux +++ /dev/null @@ -1,115 +0,0 @@ -(.module: - [lux (#- Global function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" php (#+ Var Global Expression Argument Label Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Phase! Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionG (expression archive functionS) - argsG+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/*' argsG+ functionG)))) - -(def: capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: input - (|>> inc //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 - #.Nil - [($_ _.then - (_.set! @selfL (_.closure (list (_.reference @selfL)) (list) body!)) - (_.set! @selfG @selfL)) - @selfG] - - _ - (let [@inits (|> (list.enumeration inits) - (list\map (|>> product.left ..capture)))] - [(_.set! @selfG (_.closure (list) (list\map _.parameter @inits) - ($_ _.then - (_.set! @selfL (_.closure (list& (_.reference @selfL) (list\map _.reference @inits)) - (list) - body!)) - (_.return @selfL)))) - (_.apply/* inits @selfG)]))) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[function_name body!] (/////generation.with_new_context archive - (do ! - [@scope (\ ! map ..@scope - (/////generation.context archive))] - (/////generation.with_anchor [1 @scope] - (statement expression archive bodyS)))) - closureG+ (monad.map ! (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\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.set! (..input post) (_.nth (|> post .int _.int) @curried)))) - initialize_self! - (list.indices arity))] - #let [[definition instantiation] (..with_closure closureG+ @selfG @selfL - ($_ _.then - (_.set! @num_args (_.func_num_args/0 [])) - (_.set! @curried (_.func_get_args/0 [])) - (_.cond (list [(|> @num_args (_.=== arityG)) - ($_ _.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)) - ($_ _.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)] - (wrap instantiation))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux deleted file mode 100644 index b1fb94050..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/loop.lux +++ /dev/null @@ -1,121 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set (#+ Set)]]] - [math - [number - ["n" nat]]] - [target - ["_" php (#+ Var Expression Label Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Phase! Generator Generator!)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]]) - -(def: @scope - (-> Nat Label) - (|>> %.nat (format "scope") _.label)) - -(def: (setup offset bindings body) - (-> Register (List Expression) Statement Statement) - (|> bindings - list.enumeration - (list\map (function (_ [register value]) - (let [variable (//case.register (n.+ offset register))] - (_.set! variable value)))) - list.reverse - (list\fold _.then body))) - -(def: #export (scope! statement expression archive [start initsS+ bodyS]) - (Generator! (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (statement expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [@scope (\ ! map ..@scope /////generation.next) - initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor [start @scope] - (statement expression archive bodyS))] - (wrap (..setup start initsO+ - ($_ _.then - (_.set_label @scope) - body!)))))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (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\map (|>> product.left (n.+ start) //case.register _.parameter))) - @loop (_.constant (///reference.artifact [loop_module loop_artifact])) - loop_variables (set.from_list _.hash (list\map product.right locals)) - referenced_variables (: (-> Synthesis (Set Var)) - (|>> synthesis.path/then - //case.dependencies - (set.from_list _.hash))) - [directive instantiation] (: [Statement Expression] - (case (|> (list\map referenced_variables initsS+) - (list\fold set.union (referenced_variables bodyS)) - (set.difference loop_variables) - set.to_list) - #.Nil - [(_.define_function @loop (list) scope!) - @loop] - - foreigns - [(<| (_.define_function @loop (list\map _.parameter foreigns)) - (_.return (_.closure (list\map _.parameter foreigns) (list) scope!))) - (_.apply/* foreigns @loop)]))] - _ (/////generation.execute! directive) - _ (/////generation.save! loop_artifact directive)] - (wrap (_.apply/* (list) instantiation))))) - -(def: @temp - (_.var "lux_recur_values")) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [[offset @scope] /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap ($_ _.then - (_.set! @temp (_.array/* argsO+)) - (..setup offset - (|> argsO+ - list.enumeration - (list\map (function (_ [idx _]) - (_.nth (_.int (.int idx)) @temp)))) - (_.go_to @scope)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux deleted file mode 100644 index 242519aa9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux +++ /dev/null @@ -1,31 +0,0 @@ -(.module: - [lux (#- i64) - [control - [pipe (#+ cond> new>)]] - [math - [number - ["." frac]]] - [target - ["_" php (#+ Literal Expression)]]] - ["." // #_ - ["#." runtime]]) - -(def: #export bit - (-> Bit Literal) - _.bool) - -(def: #export (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: #export f64 - (-> Frac Literal) - _.float) - -(def: #export text - (-> Text Literal) - _.string) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux deleted file mode 100644 index de532a9dc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" php (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.global) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux deleted file mode 100644 index 041993fb5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux +++ /dev/null @@ -1,609 +0,0 @@ -(.module: - [lux (#- Location inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" php (#+ Expression Label Constant Var Computation Literal Statement)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> [Nat Label] Expression Statement))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation Statement))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation Statement))) - -(def: #export unit - (_.string /////synthesis.unit)) - -(def: (flag value) - (-> Bit Literal) - (if value - ..unit - _.null)) - -(def: (feature name definition) - (-> Constant (-> Constant Statement) Statement) - (definition name)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(def: module_id - 0) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.constant (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - Var - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!name)) - (_.define (~ g!name) (~ code)))))))))) - - (#.Right [name inputs]) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) Computation) - (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!_)) - (..with_vars [(~+ inputsC)] - (_.define_function (~ g!_) - (list (~+ (list\map (|>> (~) [false] (`)) inputsC))) - (~ code)))))))))))))))) - -(runtime: (io//log! message) - ($_ _.then - (_.echo message) - (_.echo (_.string text.new_line)) - (_.return ..unit))) - -(runtime: (io//throw! message) - ($_ _.then - (_.throw (_.new (_.constant "Exception") (list message))) - (_.return ..unit))) - -(def: runtime//io - Statement - ($_ _.then - @io//log! - @io//throw! - )) - -(def: #export tuple_size_field - "_lux_size") - -(def: tuple_size - (_.nth (_.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) - ($_ _.then - (_.set! (_.nth idx array) value) - (_.return array))) - -(def: runtime//array - Statement - ($_ _.then - @array//length - @array//write - )) - -(def: jphp_last_index - (|>> ..tuple_size (_.- (_.int +1)))) - -(def: normal_last_index - (|>> _.count/1 (_.- (_.int +1)))) - -(with_expansions [<recur> (as_is ($_ _.then - (_.set! lefts (_.- last_index_right lefts)) - (_.set! tuple (_.nth last_index_right tuple))))] - (runtime: (tuple//make size values) - (_.if ..jphp? - ($_ _.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)) - ($_ _.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 (_.nth 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] - ($_ _.then - (_.set! size (..array//length input)) - (_.set! index (_.int +0)) - (_.set! output (_.array/* (list))) - (<| (_.while (|> index (_.+ offset) (_.< size))) - ($_ _.then - (_.set! (_.nth index output) (_.nth (_.+ 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)) - ($_ _.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 (_.nth 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: #export variant_tag_field "_lux_tag") -(def: #export variant_flag_field "_lux_flag") -(def: #export 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: #export (variant tag last? value) - (-> Nat Bit Expression Computation) - (sum//make (_.int (.int tag)) - (..flag last?) - value)) - -(def: #export none - Computation - (..variant 0 #0 ..unit)) - -(def: #export some - (-> Expression Computation) - (..variant 1 #1)) - -(def: #export left - (-> Expression Computation) - (..variant 0 #0)) - -(def: #export right - (-> Expression Computation) - (..variant 1 #1)) - -(runtime: (sum//get sum wantsLast wantedTag) - (let [no_match! (_.return _.null) - sum_tag (_.nth (_.string ..variant_tag_field) sum) - ## sum_tag (_.nth (_.int +0) sum) - sum_flag (_.nth (_.string ..variant_flag_field) sum) - ## sum_flag (_.nth (_.int +1) sum) - sum_value (_.nth (_.string ..variant_value_field) sum) - ## sum_value (_.nth (_.int +2) sum) - is_last? (_.=== ..unit sum_flag) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.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 - ($_ _.then - @tuple//make - @tuple//left - @tuple//slice - @tuple//right - @sum//make - @sum//get - )) - -(runtime: (lux//try op) - (with_vars [value] - (_.try ($_ _.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] - ($_ _.then - (_.set! tail ..none) - (<| (_.for_each (_.array_reverse/1 inputs) head) - (_.set! tail (..some (_.array/* (list head tail))))) - (_.return tail)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program_args - )) - -(def: #export high - (-> (I64 Any) (I64 Any)) - (i64.right_shift 32)) - -(def: #export low - (-> (I64 Any) (I64 Any)) - (let [mask (dec (i64.left_shift 32 1))] - (|>> (i64.and mask)))) - -(runtime: (i64//right_shift 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)))] - ($_ _.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_shift (_.int +16)) - low_16 (_.bit_and (_.int (.int (hex "FFFF")))) - - cap_16 low_16 - hh (..i64//right_shift (_.int +48)) - hl (|>> (..i64//right_shift (_.int +32)) cap_16) - lh (|>> (..i64//right_shift (_.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] - ($_ _.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_shift (_.int +16)) - low_16 (_.bit_and (_.int (.int (hex "FFFF")))) - - cap_16 low_16 - hh (..i64//right_shift (_.int +48)) - hl (|>> (..i64//right_shift (_.int +32)) cap_16) - lh (|>> (..i64//right_shift (_.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] - ($_ _.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 - ($_ _.then - @i64//right_shift - @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? - ($_ _.then - (_.set! idx (_.strpos/3 [subject param start])) - (_.if (_.=== (_.bool false) idx) - (_.return ..none) - (_.return (..some idx)))) - ($_ _.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 - (_.nth (_.int +1))))) - (_.throw (_.new (_.constant "Exception") (list (_.string "[Lux Error] Cannot get char from text.")))))) - -(def: runtime//text - Statement - ($_ _.then - @text//size - @text//index - @text//clip - @text//char - )) - -(runtime: (f64//decode value) - (with_vars [output] - ($_ _.then - (_.set! output (_.floatval/1 value)) - (_.if (_.=== (_.float +0.0) output) - (_.if ($_ _.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 - ($_ _.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 - ($_ _.then - check_necessary_conditions! - runtime//array - runtime//adt - runtime//lux - runtime//i64 - runtime//f64 - runtime//text - runtime//io - )) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux deleted file mode 100644 index 5f7a4e358..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/php/structure.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - [collection - ["." list]]] - [target - ["_" php (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple expression archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (expression archive singletonS) - - _ - (let [size (_.int (.int (list.size elemsS+)))] - (|> elemsS+ - (monad.map ///////phase.monad (expression archive)) - (///////phase\map (|>> _.array/* - (//runtime.tuple//make size))))))) - -(def: #export (variant expression archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant tag right?) - (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux deleted file mode 100644 index 2e86ad107..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python.lux +++ /dev/null @@ -1,112 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" python]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." function] - ["#." case] - ["#." loop] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([////synthesis.bit] - [////synthesis.i64] - [////synthesis.f64] - [////synthesis.text] - [////synthesis.variant] - [////synthesis.tuple] - [#////synthesis.Reference] - [////synthesis.branch/get] - [////synthesis.function/apply] - [#////synthesis.Extension]) - - (^ (////synthesis.branch/case case)) - (/case.case! false statement expression archive case) - - (^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/recur /loop.recur!]) - - (^ (////synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: #export (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<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 ..statement expression archive case) - - (^ (////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 ..statement expression archive scope) - - (^ (////synthesis.loop/recur updates)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (^ (////synthesis.function/abstraction abstraction)) - (/function.function ..statement expression archive abstraction) - - (^ (////synthesis.function/apply application)) - (/function.apply expression archive application) - - (#////synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux deleted file mode 100644 index 28ffbb624..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/case.lux +++ /dev/null @@ -1,317 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [control - [exception (#+ exception:)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat] - ["i" int]]] - [target - ["_" python (#+ Expression SVar Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export (gensym prefix) - (-> Text (Operation SVar)) - (///////phase\map (|>> %.nat (format prefix) _.var) /////generation.next)) - -(def: #export register - (-> Register SVar) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register SVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (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. - (wrap (_.apply/* (_.lambda (list (..register register)) - bodyO) - (list valueO))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (statement expression archive bodyS)] - (wrap ($_ _.then - (_.set (list (..register register)) valueO) - bodyO)))) - -(def: #export (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)] - (wrap (_.? testO thenO elseO)))) - -(def: #export (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)] - (wrap (_.if test! - then! - else!)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple::left] - [#.Right //runtime.tuple::right]))] - (method source))) - valueO - (list.reverse 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) - (_.nth (_.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))) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat (Statement Any)) - ($_ _.then - (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum::get ..peek <flag>))) - (.if simple? - (_.when (_.= _.none @temp) - fail_pm!) - (_.if (_.= _.none @temp) - fail_pm! - (..push! @temp)) - )))] - - [left_choice _.none (<|)] - [right_choice (_.string "") inc] - ) - -(def: (with_looping in_closure? g!once body!) - (-> Bit SVar (Statement Any) (Statement Any)) - (.if in_closure? - (_.while (_.bool true) - body! - #.None) - ($_ _.then - (_.set (list g!once) (_.bool true)) - (_.while g!once - ($_ _.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)) - ($_ _.then - (..with_looping in_closure? g!once - ($_ _.then - ..save! - pre!)) - ..restore! - post!)) - -(def: (pattern_matching' in_closure? statement expression archive) - (-> Bit Phase! Phase Archive Path (Operation (Statement Any))) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.set (list (..register register)) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail_pm!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (\ ! map - (|>> [(_.= (|> match <format>) - ..peek)]) - (recur then))) - (#.Cons cons))] - (wrap (_.cond clauses - ..fail_pm!)))]) - ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)] - [#/////synthesis.F64_Fork (<| //primitive.f64)] - [#/////synthesis.Text_Fork (<| //primitive.text)]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - recur - (///////phase\map (_.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\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..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! (recur thenP)] - (///////phase\wrap ($_ _.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! (recur nextP')] - (///////phase\wrap ($_ _.then - (..multi_pop! (n.+ 2 extra_pops)) - next!)))) - - (^ (/////synthesis.path/seq preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP)] - (wrap (_.then pre! post!))) - - (^ (/////synthesis.path/alt preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP) - g!once (..gensym "once")] - (wrap (..alternation in_closure? g!once pre! post!)))))) - -(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 (..gensym "once")] - (wrap ($_ _.then - (..with_looping in_closure? g!once - pattern_matching!) - (_.raise (_.Exception/1 (_.string case.pattern_matching_error))))))) - -(def: #export dependencies - (-> Path (List SVar)) - (|>> case.storage - (get@ #case.dependencies) - set.to_list - (list\map (function (_ variable) - (.case variable - (#///////variable.Local register) - (..register register) - - (#///////variable.Foreign register) - (..capture register)))))) - -(def: #export (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)] - (wrap ($_ _.then - (_.set (list @cursor) (_.list (list stack_init))) - (_.set (list @savepoint) (_.list (list))) - pattern_matching! - )))) - -(def: #export (case statement expression archive [valueS pathP]) - (-> Phase! (Generator [Synthesis Path])) - (do ///////phase.monad - [[[case_module case_artifact] pattern_matching!] (/////generation.with_new_context archive - (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)) - directive (_.def @case @dependencies+ - pattern_matching!)] - _ (/////generation.execute! directive) - _ (/////generation.save! case_artifact directive)] - (wrap (_.apply/* @case @dependencies+)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux deleted file mode 100644 index cc670d277..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/function.lux +++ /dev/null @@ -1,111 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" python (#+ SVar Expression Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." reference] - ["#." case] - ["#." loop] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase] - [reference - [variable (#+ Register Variable)]] - [meta - [archive (#+ Archive) - ["." artifact]]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* functionO argsO+)))) - -(def: #export capture - (-> Register SVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure function_id @function inits function_definition) - (-> artifact.ID SVar (List (Expression Any)) (Statement Any) (Operation (Expression Any))) - (case inits - #.Nil - (do ///////phase.monad - [_ (/////generation.execute! function_definition) - _ (/////generation.save! function_id function_definition)] - (wrap @function)) - - _ - (do {! ///////phase.monad} - [#let [directive (_.def @function - (|> (list.enumeration inits) - (list\map (|>> product.left ..capture))) - ($_ _.then - function_definition - (_.return @function)))] - _ (/////generation.execute! directive) - _ (/////generation.save! function_id directive)] - (wrap (_.apply/* @function inits))))) - -(def: input - (|>> inc //case.register)) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[[function_module function_artifact] body!] (/////generation.with_new_context archive - (/////generation.with_anchor 1 - (statement expression archive bodyS))) - environment (monad.map ! (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_poly (list) args func)) - initialize_self! (_.set (list (//case.register 0)) @self) - initialize! (list\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried)))) - initialize_self! - (list.indices arity))]] - (with_closure function_artifact @self environment - (_.def @self (list (_.poly @curried)) - ($_ _.then - (_.set (list @num_args) (_.len/1 @curried)) - (_.cond (list [(|> @num_args (_.= arityO)) - (<| (_.then initialize!) - //loop.set_scope - body!)] - [(|> @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")] - ($_ _.then - (_.def @next (list (_.poly @missing)) - (_.return (|> @self (apply_poly (|> @curried (_.+ @missing)))))) - (_.return @next) - ))) - ))) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux deleted file mode 100644 index 0f932ee38..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/loop.lux +++ /dev/null @@ -1,121 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat]]] - [target - ["_" python (#+ Expression SVar Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["." synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [reference - ["#." variable (#+ Register)]]]]]]]) - -(def: (setup offset bindings body) - (-> Register (List (Expression Any)) (Statement Any) (Statement Any)) - (|> bindings - list.enumeration - (list\map (function (_ [register value]) - (_.set (list (//case.register (n.+ offset register))) - value))) - list.reverse - (list\fold _.then body))) - -(def: #export (set_scope body!) - (-> (Statement Any) (Statement Any)) - (_.while (_.bool true) - body! - #.None)) - -(def: #export (scope! statement expression archive [start initsS+ bodyS]) - (Generator! (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (statement expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor start - (statement expression archive bodyS))] - (wrap (<| (..setup start initsO+) - ..set_scope - body!))))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [initsO+ (monad.map ! (expression archive) initsS+) - [[loop_module loop_artifact] body!] (/////generation.with_new_context archive - (/////generation.with_anchor start - (statement expression archive bodyS))) - #let [@loop (_.var (///reference.artifact [loop_module loop_artifact])) - locals (|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register))) - actual_loop (<| (_.def @loop locals) - ..set_scope - body!) - [directive instantiation] (: [(Statement Any) (Expression Any)] - (case (|> (synthesis.path/then bodyS) - //case.dependencies - (set.from_list _.hash) - (set.difference (set.from_list _.hash locals)) - set.to_list) - #.Nil - [actual_loop - @loop] - - foreigns - [(_.def @loop foreigns - ($_ _.then - actual_loop - (_.return @loop) - )) - (_.apply/* @loop foreigns)]))] - _ (/////generation.execute! directive) - _ (/////generation.save! loop_artifact directive)] - (wrap (_.apply/* instantiation initsO+))))) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [offset /////generation.anchor - @temp (//case.gensym "lux_recur_values") - argsO+ (monad.map ! (expression archive) argsS+) - #let [re_binds (|> argsO+ - list.enumeration - (list\map (function (_ [idx _]) - (_.nth (_.int (.int idx)) @temp))))]] - (wrap ($_ _.then - (_.set (list @temp) (_.list argsO+)) - (..setup offset re_binds - _.continue))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux deleted file mode 100644 index ec8889281..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" python (#+ Expression)]]] - ["." // #_ - ["#." runtime]]) - -(template [<type> <name> <implementation>] - [(def: #export <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/lux/tool/compiler/language/lux/phase/generation/python/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux deleted file mode 100644 index 1fe57fb8c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" python (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System (Expression Any)) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux deleted file mode 100644 index b77d0c915..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux +++ /dev/null @@ -1,455 +0,0 @@ -(.module: - [lux (#- inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["f" frac] - ["." i64]]] - ["@" target - ["_" python (#+ Expression SVar Computation Literal Statement)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["$" version] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> Register (Expression Any) (Statement Any)))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation (Statement Any)))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation (Statement Any)))) - -(type: #export (Generator i) - (-> Phase Archive i (Operation (Expression Any)))) - -(def: prefix - "LuxRuntime") - -(def: #export - 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: #export (variant tag last? value) - (-> Nat Bit (Expression Any) Literal) - (variant' (_.int (.int tag)) - (flag last?) - value)) - -(def: #export none - Literal - (..variant 0 #0 unit)) - -(def: #export some - (-> (Expression Any) Literal) - (..variant 1 #1)) - -(def: #export left - (-> (Expression Any) Literal) - (..variant 0 #0)) - -(def: #export right - (-> (Expression Any) Literal) - (..variant 1 #1)) - -(def: (runtime_name name) - (-> Text SVar) - (let [identifier (format ..prefix - "_" (%.nat $.version) - "_" (%.nat (text\hash name)))] - (_.var identifier))) - -(def: (feature name definition) - (-> SVar (-> SVar (Statement Any)) (Statement Any)) - (definition name)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (case declaration - (#.Left name) - (macro.with_gensyms [g!_] - (let [nameC (code.local_identifier name) - code_nameC (code.local_identifier (format "@" name)) - runtime_nameC (` (runtime_name (~ (code.text name))))] - (wrap (list (` (def: #export (~ nameC) SVar (~ runtime_nameC))) - (` (def: (~ code_nameC) - (Statement Any) - (..feature (~ runtime_nameC) - (function ((~ g!_) (~ g!_)) - (_.set (list (~ g!_)) (~ code)))))))))) - - (#.Right [name inputs]) - (macro.with_gensyms [g!_] - (let [nameC (code.local_identifier name) - code_nameC (code.local_identifier (format "@" name)) - runtime_nameC (` (runtime_name (~ (code.text name)))) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` (_.Expression Any))) - inputs)] - (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) - (-> (~+ inputs_typesC) (Computation Any)) - (_.apply/* (~ runtime_nameC) (list (~+ inputsC))))) - (` (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/* op (list ..unit)))) - (list [(list (_.var "Exception")) exception - (_.return (..left (_.str/1 exception)))])))) - -(runtime: (lux::program_args program_args) - (with_vars [inputs value] - ($_ _.then - (_.set (list inputs) ..none) - (<| (_.for_in value (_.apply/* (_.var "reversed") (list program_args))) - (_.set (list inputs) - (..some (_.list (list value inputs))))) - (_.return inputs)))) - -(runtime: (lux::exec code globals) - ($_ _.then - (_.exec code (#.Some globals)) - (_.return ..unit))) - -(def: runtime::lux - (Statement Any) - ($_ _.then - @lux::try - @lux::program_args - @lux::exec - )) - -(runtime: (io::log! message) - ($_ _.then - (_.print message) - (_.return ..unit))) - -(runtime: (io::throw! message) - (_.raise (_.Exception/1 message))) - -(def: runtime::io - (Statement Any) - ($_ _.then - @io::log! - @io::throw! - )) - -(def: last_index - (|>> _.len/1 (_.- (_.int +1)))) - -(with_expansions [<recur> (as_is ($_ _.then - (_.set (list lefts) (_.- last_index_right lefts)) - (_.set (list tuple) (_.nth last_index_right tuple))))] - (runtime: (tuple::left lefts tuple) - (with_vars [last_index_right] - (_.while (_.bool true) - ($_ _.then - (_.set (list last_index_right) (..last_index tuple)) - (_.if (_.> lefts last_index_right) - ## No need for recursion - (_.return (_.nth lefts tuple)) - ## Needs recursion - <recur>)) - #.None))) - - (runtime: (tuple::right lefts tuple) - (with_vars [last_index_right right_index] - (_.while (_.bool true) - ($_ _.then - (_.set (list last_index_right) (..last_index tuple)) - (_.set (list right_index) (_.+ (_.int +1) lefts)) - (_.cond (list [(_.= last_index_right right_index) - (_.return (_.nth right_index tuple))] - [(_.> last_index_right right_index) - ## Needs recursion. - <recur>]) - (_.return (_.slice_from right_index tuple)))) - #.None)))) - -(runtime: (sum::get sum wantsLast wantedTag) - (let [no_match! (_.return _.none) - sum_tag (_.nth (_.int +0) sum) - sum_flag (_.nth (_.int +1) sum) - sum_value (_.nth (_.int +2) sum) - is_last? (_.= ..unit sum_flag) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.then - (_.set (list wantedTag) (_.- sum_tag wantedTag)) - (_.set (list sum) sum_value)) - no_match!)] - (_.while (_.bool true) - (_.cond (list [(_.= wantedTag sum_tag) - (_.if (_.= wantsLast sum_flag) - (_.return sum_value) - test_recursion!)] - - [(_.< wantedTag sum_tag) - test_recursion!] - - [(_.= ..unit wantsLast) - (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) - - no_match!) - #.None))) - -(def: runtime::adt - (Statement Any) - ($_ _.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] - (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>] - [(_.if (|> input <scenario>) - ($_ _.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_shift param subject) - (_.return (|> subject - (_.bit_shl (_.% (_.int +64) param)) - ..i64::64))) - -(runtime: (i64::right_shift param subject) - ($_ _.then - (_.set (list param) (_.% (_.int +64) param)) - (_.return (_.? (_.= (_.int +0) param) - subject - (|> subject - ..as_nat - (_.bit_shr param)))))) - -(runtime: (i64::division param subject) - (with_vars [floored] - ($_ _.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) - floored)))))) - -(runtime: (i64::remainder param subject) - (_.return (_.- (|> subject (..i64::division param) (_.* param)) - subject))) - -(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) - ($_ _.then - @i64::64 - @i64::left_shift - @i64::right_shift - @i64::division - @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 (_.var "Exception")) ex - (_.return ..none)])))) - -(def: runtime::f64 - (Statement Any) - ($_ _.then - @f64::/ - @f64::decode - )) - -(runtime: (text::index start param subject) - (with_vars [idx] - ($_ _.then - (_.set (list idx) (|> subject (_.do "find" (list param start)))) - (_.return (_.? (_.= (_.int -1) idx) - ..none - (..some (..i64::64 idx))))))) - -(def: inc - (|>> (_.+ (_.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 (..inc idx)) _.ord/1 ..i64::64)) - (_.raise (_.Exception/1 (_.unicode "[Lux Error] Cannot get char from text."))))) - -(def: runtime::text - (Statement Any) - ($_ _.then - @text::index - @text::clip - @text::char - )) - -(runtime: (array::write idx value array) - ($_ _.then - (_.set (list (_.nth idx array)) value) - (_.return array))) - -(def: runtime::array - (Statement Any) - ($_ _.then - @array::write - )) - -(def: runtime - (Statement Any) - ($_ _.then - runtime::lux - runtime::io - runtime::adt - runtime::i64 - runtime::f64 - runtime::text - runtime::array - )) - -(def: module_id - 0) - -(def: #export generate - (Operation [Registry Output]) - (/////generation.with_buffer - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux deleted file mode 100644 index c5edce4a7..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" python (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple generate archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (generate archive)) - (///////phase\map _.list)))) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant tag right?) - (generate archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux deleted file mode 100644 index b4b3e6423..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r.lux +++ /dev/null @@ -1,58 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [target - ["_" r]]] - ["." / #_ - [runtime (#+ Phase)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: #export (generate archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<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) - - (^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/recur /loop.recur] - [////synthesis.function/abstraction /function.function]) - - (#////synthesis.Extension extension) - (///extension.apply archive generate extension) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux deleted file mode 100644 index fe4e4a7c2..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/case.lux +++ /dev/null @@ -1,239 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [macro - ["." template]] - [math - [number - ["i" int]]] - [target - ["_" r (#+ Expression SVar)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register SVar) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register SVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (expression archive bodyS)] - (wrap (_.block - ($_ _.then - (_.set! (..register register) valueO) - bodyO))))) - -(def: #export (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)] - (wrap (_.if testO thenO elseO)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple::left] - [#.Right //runtime.tuple::right]))] - (method source))) - valueO - (list.reverse 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_nth! (next var) value var)) - -(def: (pop! var) - (-> SVar Expression) - (_.set_nth! (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 (_.nth (top $savepoint) $savepoint))) - -(def: peek - Expression - (|> $cursor (_.nth (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 (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop_cursor!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.set! (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format> <=>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(<=> (|> match <format>) - ..peek) - then!]))) - (#.Cons cons))] - (wrap (list\fold (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 _.=]) - - (^template [<pm> <flag> <prep>] - [(^ (<pm> idx)) - (///////phase\wrap ($_ _.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 inc]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (_.nth (_.int +1) ..peek)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..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 (recur leftP) - rightO (recur rightP)] - (wrap ($_ _.then - leftO - rightO))) - - (^ (/////synthesis.path/alt leftP rightP)) - (do {! ///////phase.monad} - [leftO (recur leftP) - rightO (recur rightP)] - (wrap (_.try ($_ _.then - ..save_cursor! - leftO) - #.None - (#.Some (..catch ($_ _.then - ..restore_cursor! - rightO))) - #.None))) - ))) - -(def: (pattern_matching expression archive pathP) - (Generator Path) - (do ///////phase.monad - [pattern_matching! (pattern_matching' expression archive pathP)] - (wrap (_.try pattern_matching! - #.None - (#.Some (..catch (_.stop (_.string "Invalid expression for pattern-matching.")))) - #.None)))) - -(def: #export (case expression archive [valueS pathP]) - (Generator [Synthesis Path]) - (do {! ///////phase.monad} - [valueO (expression archive valueS)] - (<| (\ ! map (|>> ($_ _.then - (_.set! $cursor (_.list (list valueO))) - (_.set! $savepoint (_.list (list)))) - _.block)) - (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux deleted file mode 100644 index c89ffaf0a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/function.lux +++ /dev/null @@ -1,116 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" r (#+ Expression SVar)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]] - [meta - [archive - ["." artifact]]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply argsO+ functionO)))) - -(def: (with_closure function_id $function inits function_definition) - (-> artifact.ID SVar (List Expression) Expression (Operation Expression)) - (case inits - #.Nil - (do ///////phase.monad - [_ (/////generation.execute! function_definition) - _ (/////generation.save! (%.nat function_id) - function_definition)] - (wrap $function)) - - _ - (do ///////phase.monad - [#let [closure_definition (_.set! $function - (_.function (|> inits - list.size - list.indices - (list\map //case.capture)) - ($_ _.then - function_definition - $function)))] - _ (/////generation.execute! closure_definition) - _ (/////generation.save! (%.nat function_id) closure_definition)] - (wrap (_.apply inits $function))))) - -(def: $curried (_.var "curried")) -(def: $missing (_.var "missing")) - -(def: (input_declaration register) - (-> Register Expression) - (_.set! (|> register inc //case.register) - (|> $curried (_.nth (|> register inc .int _.int))))) - -(def: #export (function expression archive [environment arity bodyS]) - (Generator (Abstraction Synthesis)) - (do {! ///////phase.monad} - [[[function_module function_artifact] bodyO] (/////generation.with_new_context archive - (do ! - [$self (\ ! map (|>> ///reference.artifact _.var) - (/////generation.context archive))] - (/////generation.with_anchor $self - (expression archive bodyS)))) - closureO+ (monad.map ! (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) - ($_ _.then - (_.set! $curried (_.list (list _.var_args))) - (_.set! $num_args (_.length $curried)) - (_.cond (list [(|> $num_args (_.= arityO)) - ($_ _.then - (_.set! (//case.register 0) $self) - (|> arity - list.indices - (list\map input_declaration) - (list\fold _.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) - ($_ _.then - (_.set! $missing (_.list (list _.var_args))) - (|> $self - (apply_poly (_.apply (list $curried $missing) - (_.var "append")))))))))))) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux deleted file mode 100644 index c8f8bd1d5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/loop.lux +++ /dev/null @@ -1,64 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set (#+ Set)]]] - [math - [number - ["n" nat]]] - [target - ["_" r]]] - ["." // #_ - [runtime (#+ Operation Phase Generator)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]]) - -(def: #export (scope expression archive [offset initsS+ bodyS]) - (Generator (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [$scope (\ ! map _.var (/////generation.gensym "loop_scope")) - initsO+ (monad.map ! (expression archive) initsS+) - bodyO (/////generation.with_anchor $scope - (expression archive bodyS))] - (wrap (_.block - ($_ _.then - (_.set! $scope - (_.function (|> initsS+ - list.size - list.indices - (list\map (|>> (n.+ offset) //case.register))) - bodyO)) - (_.apply initsO+ $scope))))))) - -(def: #export (recur expression archive argsS+) - (Generator (List Synthesis)) - (do {! ///////phase.monad} - [$scope /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply argsO+ $scope)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux deleted file mode 100644 index efbd569f4..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" r (#+ Expression)]]] - ["." // #_ - ["#." runtime]]) - -(template [<name> <type> <code>] - [(def: #export <name> - (-> <type> Expression) - <code>)] - - [bit Bit _.bool] - [i64 (I64 Any) (|>> .int //runtime.i64)] - [f64 Frac _.float] - [text Text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux deleted file mode 100644 index 85ccd90dc..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux +++ /dev/null @@ -1,339 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - [number] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [r #+ Expression]))) - [///] - (/// [".T" runtime] - [".T" case] - [".T" function] - [".T" loop])) - -## [Types] -(type: #export Translator - (-> ls.Synthesis (Meta Expression))) - -(type: #export Proc - (-> Translator (List ls.Synthesis) (Meta Expression))) - -(type: #export Bundle - (Dict Text Proc)) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 Expression) Expression)) -(type: #export Unary (-> (Vector +1 Expression) Expression)) -(type: #export Binary (-> (Vector +2 Expression) Expression)) -(type: #export Trinary (-> (Vector +3 Expression) Expression)) -(type: #export Variadic (-> (List Expression) Expression)) - -## [Utils] -(def: #export (install name unnamed) - (-> Text (-> Text Proc) - (-> Bundle Bundle)) - (dict.put name (unnamed name))) - -(def: #export (prefix prefix bundle) - (-> Text Bundle Bundle) - (|> bundle - dict.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dict.from-list text.Hash<Text>))) - -(def: (wrong-arity proc expected actual) - (-> Text Nat Nat Text) - (format "Wrong number of arguments for " (%t proc) "\n" - "Expected: " (|> expected .int %i) "\n" - " Actual: " (|> actual .int %i))) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!proc g!name g!translate g!inputs] - (do {@ macro.monad} - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!proc)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Expression) - (-> Text ..Proc)) - (function ((~ g!_) (~ g!name)) - (function ((~ g!_) (~ g!translate) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do macro.Monad<Meta> - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!translate) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) - - (~' _) - (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) - -(arity: nullary +0) -(arity: unary +1) -(arity: binary +2) -(arity: trinary +3) - -(def: #export (variadic proc) - (-> Variadic (-> Text Proc)) - (function (_ proc-name) - (function (_ translate inputsS) - (do {@ macro.Monad<Meta>} - [inputsI (monad.map @ translate inputsS)] - (wrap (proc inputsI)))))) - -## [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: #export (Wrong-Syntax {message Text}) - message) - -(def: #export (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.run inputsS ($_ p.seq 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//recur - (-> Text Proc) - (function (_ proc-name) - (function (_ translate inputsS) - (loopT.translate-recur translate inputsS)))) - -(def: lux-procs - Bundle - (|> (dict.new text.Hash<Text>) - (install "is" (binary lux//is)) - (install "try" (unary lux//try)) - (install "if" (trinary lux//if)) - (install "loop" lux//loop) - (install "recur" lux//recur) - )) - -## [[Bits]] -(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] - ) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> (runtimeT.int64-low paramO) subjectO))] - - [bit//left-shift runtimeT.bit//left-shift] - [bit//arithmetic-right-shift runtimeT.bit//arithmetic-right-shift] - [bit//logical-right-shift runtimeT.bit//logical-right-shift] - ) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash<Text>) - (install "and" (binary bit//and)) - (install "or" (binary bit//or)) - (install "xor" (binary bit//xor)) - (install "left-shift" (binary bit//left-shift)) - (install "logical-right-shift" (binary bit//logical-right-shift)) - (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) - ))) - -## [[Numbers]] -(host.import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(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] - ) - -(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//%] - ) - -(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.<] - ) - -(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.new 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//to-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.new 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.new 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//to-float input)]) - (r.global "quit"))) - -(def: (void code) - (-> Expression Expression) - (r.block (r.then code runtimeT.unit))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new 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: #export procedures - Bundle - (<| (prefix "lux") - (|> lux-procs - (dict.merge bit-procs) - (dict.merge int-procs) - (dict.merge frac-procs) - (dict.merge text-procs) - (dict.merge io-procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux deleted file mode 100644 index 3bd33955f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do]) - (data [text] - text/format - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro "macro/" Monad<Meta>]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host [ruby #+ Ruby Expression Statement]))) - [///] - (/// [".T" runtime]) - (// ["@" common])) - -## (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> -## [] -## (wrap name)) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: (lua//call proc translate inputs) -## (-> Text @.Proc) -## (case inputs -## (^ (list& functionS argsS+)) -## (do {@ macro.Monad<Meta>} -## [functionO (translate functionS) -## argsO+ (monad.map @ translate argsS+)] -## (wrap (lua.apply functionO argsO+))) - -## _ -## (&.throw @.Wrong-Syntax (@.wrong-syntax proc inputs)))) - -## (def: lua-procs -## @.Bundle -## (|> (dict.new 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& tableS [_ (#.Text field)] argsS+)) -## (do {@ macro.Monad<Meta>} -## [tableO (translate tableS) -## argsO+ (monad.map @ translate argsS+)] -## (wrap (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.new text.Hash<Text>) -## (@.install "call" table//call) -## (@.install "get" (@.binary table//get)) -## (@.install "set" (@.trinary table//set))))) - -(def: #export procedures - @.Bundle - (<| (@.prefix "lua") - (dict.new text.Hash<Text>) - ## (|> lua-procs - ## (dict.merge table-procs)) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux deleted file mode 100644 index c986bc2a0..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" r (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux deleted file mode 100644 index ac0efe5ef..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux +++ /dev/null @@ -1,854 +0,0 @@ -(.module: - [lux (#- Location inc i64) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["n" nat] - ["i" int ("#\." interval)] - ["." i64]]] - ["@" target - ["_" r (#+ SVar Expression)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant)] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(def: module_id - 0) - -(template [<name> <base>] - [(type: #export <name> - (<base> _.SVar _.Expression _.Expression))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(def: #export 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))) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - _.SVar - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - _.Expression - (_.set! (~ runtime_name) (~ code))))))) - - (#.Right [name inputs]) - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) _.Expression) - (_.apply (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - _.Expression - (..with_vars [(~+ inputsC)] - (_.set! (~ runtime_name) - (_.function (list (~+ inputsC)) - (~ code)))))))))))))) - -(def: #export variant_tag_field "luxVT") -(def: #export variant_flag_field "luxVF") -(def: #export variant_value_field "luxVV") - -(def: #export (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: #export (variant tag last? value) - (-> Nat Bit Expression Expression) - (adt::variant (_.int (.int tag)) - (flag last?) - value)) - -(def: #export none - Expression - (variant 0 #0 ..unit)) - -(def: #export some - (-> Expression Expression) - (variant 1 #1)) - -(def: #export left - (-> Expression Expression) - (variant 0 #0)) - -(def: #export right - (-> Expression Expression) - (variant 1 #1)) - -(def: high_shift (_.bit_shl (_.int +32))) - -(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: #export i64_high_field "luxIH") -(def: #export i64_low_field "luxIL") - -(runtime: (i64::unsigned_low input) - (with_vars [low] - ($_ _.then - (_.set! low (|> input (_.nth (_.string ..i64_low_field)))) - (_.if (|> low (_.>= (_.int +0))) - low - (|> low (_.+ f2^32)))))) - -(runtime: (i64::to_float input) - (let [high (|> input - (_.nth (_.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_shift 32)) - -(def: low_32 - (-> Nat Nat) - (|>> (i64.and (hex "FFFFFFFF")))) - -(def: #export (i64 value) - (-> Int Expression) - (let [value (.nat value)] - (i64::new (|> value ..high_32 ..cap_32 _.int) - (|> value ..low_32 ..cap_32 _.int)))) - -(def: #export (lux_i64 high low) - (-> Int Int Int) - (|> high - (i64.left_shift 32) - (i64.or low))) - -(template [<name> <value>] - [(runtime: <name> - (..i64 <value>))] - - [i64::zero +0] - [i64::one +1] - [i64::min i\bottom] - [i64::max i\top] - ) - -(def: #export i64_high (_.nth (_.string ..i64_high_field))) -(def: #export i64_low (_.nth (_.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] - ($_ _.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))))] - ($_ _.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 (: (-> (-> 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::negate input) - (_.if (|> input (i64::= i64::min)) - i64::min - (|> input i64::not (i64::+ i64::one)))) - -(runtime: i64::-one - (i64::negate i64::one)) - -(runtime: (i64::- param subject) - (i64::+ (i64::negate param) subject)) - -(runtime: (i64::< reference sample) - (with_vars [r_? s_?] - ($_ _.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::from_float input) - (_.cond (list [(_.apply (list input) (_.var "is.nan")) - i64::zero] - [(|> input (_.<= (_.negate f2^63))) - i64::min] - [(|> input (_.+ (_.float +1.0)) (_.>= f2^63)) - i64::max] - [(|> input (_.< (_.float +0.0))) - (|> input _.negate i64::from_float i64::negate)]) - (i64::new (|> input (_./ f2^32)) - (|> input (_.%% f2^32))))) - -(runtime: (i64::* param subject) - (with_vars [sH sL pH pL - x00 x16 x32 x48] - ($_ _.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::negate param) - (i64::negate subject)) - (i64::negate (i64::* param - (i64::negate subject))))] - - [negative_param? - (i64::negate (i64::* (i64::negate param) - subject))]) - ($_ _.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! ($_ _.then (_.set! s48 _s48) (_.set! s32 _s32) (_.set! s16 _s16) (_.set! s00 _s00)) - set_param_chunks! ($_ _.then (_.set! p48 _p48) (_.set! p32 _p32) (_.set! p16 _p16) (_.set! p00 _p00))] - ($_ _.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_shift shift input) - ($_ _.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_shift_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_shift shift input) - ($_ _.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_shift_32 shift)) - low (|> (i64_low input) - (_.bit_ushr shift) - (_.bit_or mid))] - (i64::new high low))]) - (let [low (|> (i64_high input) - (i64::arithmetic_right_shift_32 (|> shift (_.- (_.int +32))))) - high (_.if (|> (i64_high input) (_.>= (_.int +0))) - (_.int +0) - (_.int -1))] - (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] - ($_ _.then - (_.set! approximation - (|> subject - (i64::arithmetic_right_shift (_.int +1)) - (i64::/ param) - (i64::left_shift (_.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::negate subject) - (i64::/ (i64::negate param))) - (|> (i64::negate subject) - (i64::/ param) - i64::negate))] - - [(negative? param) - (|> param - i64::negate - (i64::/ subject) - i64::negate)]) - (with_vars [result remainder approximate approximate_result log2 approximate_remainder] - ($_ _.then - (_.set! result i64::zero) - (_.set! remainder subject) - (_.while (|> (|> remainder (i64::< param)) - (_.or (|> remainder (i64::= param)))) - (let [calc_rough_estimate (_.apply (list (|> (i64::to_float remainder) (_./ (i64::to_float param)))) - (_.var "floor")) - calc_approximate_result (i64::from_float approximate) - calc_approximate_remainder (|> approximate_result (i64::* param)) - delta (_.if (|> (_.float +48.0) (_.<= log2)) - (_.float +1.0) - (_.** (|> log2 (_.- (_.float +48.0))) - (_.float +2.0)))] - ($_ _.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)))) - ($_ _.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 ($_ _.then - (_.set! value (_.apply (list ..unit) op)) - (..right value)) - #.None - (#.Some (_.function (list error) - (..left (_.nth (_.string "message") - error)))) - #.None))) - -(runtime: (lux::program_args program_args) - (with_vars [inputs value] - ($_ _.then - (_.set! inputs ..none) - (<| (_.for_in value program_args) - (_.set! inputs (..some (_.list (list value inputs))))) - inputs))) - -(def: runtime::lux - Expression - ($_ _.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::from_float)) - -(def: runtime::io - Expression - ($_ _.then - @io::current_time! - )) - -(def: minimum_index_length - (-> SVar Expression) - (|>> (_.+ (_.int +1)))) - -(def: (product_element product index) - (-> Expression Expression Expression) - (|> product (_.nth (|> index (_.+ (_.int +1)))))) - -(def: (product_tail product) - (-> SVar Expression) - (|> product (_.nth (_.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")] - ($_ _.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")] - ($_ _.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 (_.nth (_.string ..variant_tag_field))) - sum_flag (|> sum (_.nth (_.string ..variant_flag_field))) - sum_value (|> sum (_.nth (_.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 - ($_ _.then - @tuple::left - @tuple::right - @sum::get - @adt::variant - )) - -(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_shift shift input) - ($_ _.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)))] - ($_ _.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 - ($_ _.then - @f2^32 - @f2^63 - - @i64::new - @i64::from_float - - @i64::and - @i64::or - @i64::xor - @i64::not - @i64::left_shift - @i64::arithmetic_right_shift_32 - @i64::arithmetic_right_shift - @i64::right_shift - - @i64::zero - @i64::one - @i64::min - @i64::max - @i64::= - @i64::< - @i64::+ - @i64::- - @i64::negate - @i64::-one - @i64::unsigned_low - @i64::to_float - @i64::* - @i64::/ - @i64::% - )) - -(runtime: (frac::decode input) - (with_vars [output] - ($_ _.then - (_.set! output (_.apply (list input) (_.var "as.numeric"))) - (_.if (|> output (_.= _.n/a)) - ..none - (..some output))))) - -(def: runtime::frac - Expression - ($_ _.then - @frac::decode - )) - -(def: inc - (-> Expression Expression) - (|>> (_.+ (_.int +1)))) - -(template [<name> <top_cmp>] - [(def: (<name> top value) - (-> Expression Expression Expression) - (|> (|> value (_.>= (_.int +0))) - (_.and (|> value (<top_cmp> top)))))] - - [within? _.<] - [up_to? _.<=] - ) - -(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] - ($_ _.then - (_.set! startF (i64::to_float start)) - (_.set! subjectL (text_length subject)) - (_.if (|> startF (within? subjectL)) - ($_ _.then - (_.set! idx (|> (_.apply_kw (list param (_.if (|> startF (_.= (_.int +0))) - subject - (text_clip (inc startF) - (inc subjectL) - subject))) - (list ["fixed" (_.bool #1)]) - (_.var "regexpr")) - (_.nth (_.int +1)))) - (_.if (|> idx (_.= (_.int -1))) - ..none - (..some (i64::from_float (|> idx (_.+ startF)))))) - ..none)))) - -(runtime: (text::clip text from to) - (with_vars [length] - ($_ _.then - (_.set! length (_.length text)) - (_.if ($_ _.and - (|> to (within? length)) - (|> from (up_to? to))) - (..some (text_clip (inc from) (inc 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 (|> idx (within? (_.length text))) - ($_ _.then - (_.set! idx (inc idx)) - (..some (i64::from_float (char_at idx text)))) - ..none)) - -(def: runtime::text - Expression - ($_ _.then - @text::index - @text::clip - @text::char - )) - -(def: (check_index_out_of_bounds array idx body) - (-> Expression Expression Expression Expression) - (_.if (|> idx (_.<= (_.length array))) - body - (_.stop (_.string "Array index out of bounds!")))) - -(runtime: (array::new size) - (with_vars [output] - ($_ _.then - (_.set! output (_.list (list))) - (_.set_nth! (|> size (_.+ (_.int +1))) - _.null - output) - output))) - -(runtime: (array::get array idx) - (with_vars [temp] - (<| (check_index_out_of_bounds array idx) - ($_ _.then - (_.set! temp (|> array (_.nth (_.+ (_.int +1) idx)))) - (_.if (|> temp (_.= _.null)) - ..none - (..some temp)))))) - -(runtime: (array::put array idx value) - (<| (check_index_out_of_bounds array idx) - ($_ _.then - (_.set_nth! (_.+ (_.int +1) idx) value array) - array))) - -(def: runtime::array - Expression - ($_ _.then - @array::new - @array::get - @array::put - )) - -(def: runtime - Expression - ($_ _.then - runtime::lux - runtime::i64 - runtime::adt - runtime::frac - runtime::text - runtime::array - runtime::io - )) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! (%.nat ..module_id) ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [(%.nat ..module_id) - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux deleted file mode 100644 index 5f4703836..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/r/structure.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - [collection - ["." list]]] - [target - ["_" r (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple expression archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (expression archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (expression archive)) - (///////phase\map _.list)))) - -(def: #export (variant expression archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (|>> (//runtime.variant tag right?)) - (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux deleted file mode 100644 index cdcc5a134..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux +++ /dev/null @@ -1,88 +0,0 @@ -(.module: - [lux #* - ["@" target] - [data - [text - ["%" format (#+ format)]]]] - ["." //// #_ - ["." version] - ["#." generation (#+ Context)] - ["//#" /// #_ - ["." reference (#+ Reference) - ["." variable (#+ Register Variable)]] - ["." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]) - -## This universe constant is for languages where one can't just turn all compiled definitions -## into the local variables of some scoping function. -(def: #export universe - (for {## In the case of Lua, there is a limit of 200 locals in a function's scope. - @.lua (not ("lua script universe")) - ## Cannot make all definitions be local variables because of limitations with JRuby. - @.ruby (not ("ruby script universe")) - ## Cannot make all definitions be local variables because of limitations with PHP itself. - @.php (not ("php script universe")) - ## Cannot make all definitions be local variables because of limitations with Kawa. - @.scheme (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: #export (artifact [module artifact]) - (-> Context Text) - (format "l" (%.nat version.version) - ..universe_label - "m" (%.nat module) - "a" (%.nat artifact))) - -(interface: #export (System expression) - (: (-> Text expression) - constant) - (: (-> Text expression) - variable)) - -(def: #export (constant system archive name) - (All [anchor expression directive] - (-> (System expression) Archive Name - (////generation.Operation anchor expression directive expression))) - (phase\map (|>> ..artifact (\ system constant)) - (////generation.remember archive name))) - -(template [<sigil> <name>] - [(def: #export (<name> system) - (All [expression] - (-> (System expression) - (-> Register expression))) - (|>> %.nat (format <sigil>) (\ system variable)))] - - ["f" foreign] - ["l" local] - ) - -(def: #export (variable system variable) - (All [expression] - (-> (System expression) Variable expression)) - (case variable - (#variable.Local register) - (..local system register) - - (#variable.Foreign register) - (..foreign system register))) - -(def: #export (reference system archive reference) - (All [anchor expression directive] - (-> (System expression) Archive Reference (////generation.Operation anchor expression directive expression))) - (case reference - (#reference.Constant value) - (..constant system archive value) - - (#reference.Variable value) - (phase\wrap (..variable system value)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux deleted file mode 100644 index f1a4e3c1c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby.lux +++ /dev/null @@ -1,104 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." exception (#+ exception:)]] - [target - ["_" ruby]]] - ["." / #_ - [runtime (#+ Phase Phase!)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." function] - ["#." case] - ["#." loop] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: (statement expression archive synthesis) - Phase! - (case synthesis - (^template [<tag>] - [(^ (<tag> value)) - (//////phase\map _.return (expression archive synthesis))]) - ([////synthesis.bit] - [////synthesis.i64] - [////synthesis.f64] - [////synthesis.text] - [////synthesis.variant] - [////synthesis.tuple] - [#////synthesis.Reference] - [////synthesis.branch/get] - [////synthesis.function/apply] - [#////synthesis.Extension]) - - (^ (////synthesis.branch/case case)) - (/case.case! false statement expression archive case) - - (^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/recur /loop.recur!]) - - (^ (////synthesis.function/abstraction abstraction)) - (//////phase\map _.return (/function.function statement expression archive abstraction)) - )) - -(exception: #export cannot-recur-as-an-expression) - -(def: (expression archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<generator> value))]) - ([////synthesis.bit /primitive.bit] - [////synthesis.i64 /primitive.i64] - [////synthesis.f64 /primitive.f64] - [////synthesis.text /primitive.text]) - - (^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]) - - (^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/recur _)) - (//////phase.throw ..cannot-recur-as-an-expression []) - - (#////synthesis.Reference value) - (//reference.reference /reference.system archive value) - - (#////synthesis.Extension extension) - (///extension.apply archive expression extension))) - -(def: #export generate - Phase - ..expression) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux deleted file mode 100644 index 2249874b5..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux +++ /dev/null @@ -1,311 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [control - [exception (#+ exception:)]] - [data - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat] - ["i" int]]] - [target - ["_" ruby (#+ Expression LVar Statement)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export (gensym prefix) - (-> Text (Operation LVar)) - (///////phase\map (|>> %.nat (format prefix) _.local) /////generation.next)) - -(def: #export register - (-> Register LVar) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register LVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (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. - (wrap (|> bodyO - _.return - (_.lambda #.None (list (..register register))) - (_.apply_lambda/* (list valueO)))))) - -(def: #export (let! statement expression archive [valueS register bodyS]) - (Generator! [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (statement expression archive bodyS)] - (wrap ($_ _.then - (_.set (list (..register register)) valueO) - bodyO)))) - -(def: #export (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)] - (wrap (_.? testO thenO elseO)))) - -(def: #export (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)] - (wrap (_.if test! - then! - else!)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueO - (list.reverse 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))))) - -(def: peek_and_pop - Expression - (|> @cursor (_.do "pop" (list)))) - -(def: pop! - Statement - (_.statement ..peek_and_pop)) - -(def: peek - Expression - (_.nth (_.int -1) @cursor)) - -(def: save! - Statement - (.let [cursor (_.array_range (_.int +0) (_.int -1) @cursor)] - (_.statement (|> @savepoint (_.do "push" (list cursor)))))) - -(def: restore! - Statement - (_.set (list @cursor) (|> @savepoint (_.do "pop" (list))))) - -(def: fail! _.break) - -(def: (multi_pop! pops) - (-> Nat Statement) - (_.statement (_.do "slice!" (list (_.int (i.* -1 (.int pops))) - (_.int (.int pops))) - @cursor))) - -(template [<name> <flag> <prep>] - [(def: (<name> simple? idx) - (-> Bit Nat Statement) - ($_ _.then - (_.set (list @temp) (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))) - (.if simple? - (_.when (_.= _.nil @temp) - fail!) - (_.if (_.= _.nil @temp) - fail! - (..push! @temp)))))] - - [left_choice _.nil (<|)] - [right_choice (_.string "") inc] - ) - -(def: (with_looping in_closure? g!once g!continue? body!) - (-> Bit LVar LVar Statement Statement) - (.if in_closure? - ($_ _.then - (_.while (_.bool true) - body!)) - ($_ _.then - (_.set (list g!once) (_.bool true)) - (_.set (list g!continue?) (_.bool false)) - (<| (_.while (_.bool true)) - (_.if g!once - ($_ _.then - (_.set (list g!once) (_.bool false)) - body!) - ($_ _.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) - ($_ _.then - (with_looping in_closure? g!once g!continue? - ($_ _.then - ..save! - pre!)) - ..restore! - post!)) - -(def: (pattern_matching' in_closure? statement expression archive) - (-> Bit (Generator! Path)) - (function (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (statement expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap ..pop!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.set (list (..register register)) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (\ ! map - (|>> [(_.= (|> match <format>) - ..peek)]) - (recur then))) - (#.Cons cons))] - (wrap (_.cond clauses - ..fail!)))]) - ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)] - [#/////synthesis.F64_Fork (<| //primitive.f64)] - [#/////synthesis.Text_Fork (<| //primitive.text)]) - - (^template [<complex> <simple> <choice>] - [(^ (<complex> idx)) - (///////phase\wrap (<choice> false idx)) - - (^ (<simple> idx nextP)) - (|> nextP - recur - (///////phase\map (_.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\wrap (|> ..peek (_.nth (_.int +0)) ..push!)) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..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! (recur thenP)] - (///////phase\wrap ($_ _.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! (recur nextP')] - (///////phase\wrap ($_ _.then - (..multi_pop! (n.+ 2 extra_pops)) - next!)))) - - (^ (/////synthesis.path/seq preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP)] - (wrap ($_ _.then - pre! - post!))) - - (^ (/////synthesis.path/alt preP postP)) - (do ///////phase.monad - [pre! (recur preP) - post! (recur postP) - g!once (..gensym "once") - g!continue? (..gensym "continue")] - (wrap (..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 (..gensym "once") - g!continue? (..gensym "continue")] - (wrap ($_ _.then - (..with_looping in_closure? g!once g!continue? - pattern_matching!) - (_.statement (_.raise (_.string case.pattern_matching_error))))))) - -(def: #export (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)] - (wrap ($_ _.then - (_.set (list @cursor) (_.array (list stack_init))) - (_.set (list @savepoint) (_.array (list))) - pattern_matching! - )))) - -(def: #export (case statement expression archive case) - (-> Phase! (Generator [Synthesis Path])) - (|> case - (case! true statement expression archive) - (\ ///////phase.monad map - (|>> (_.lambda #.None (list)) - (_.apply_lambda/* (list)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux deleted file mode 100644 index 535453f2e..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux +++ /dev/null @@ -1,111 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" ruby (#+ LVar GVar Expression Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." reference] - ["#." case] - ["#." loop] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Environment Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase] - [reference - [variable (#+ Register Variable)]] - [meta - [archive (#+ Archive) - ["." artifact]]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply_lambda/* argsO+ functionO)))) - -(def: #export capture - (-> Register LVar) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure inits self function_definition) - (-> (List Expression) Text Expression [Statement Expression]) - (case inits - #.Nil - (let [@self (_.global self)] - [(_.set (list @self) function_definition) - @self]) - - _ - (let [@self (_.local self)] - [(_.function @self - (|> (list.enumeration inits) - (list\map (|>> product.left ..capture))) - ($_ _.then - (_.set (list @self) function_definition) - (_.return @self))) - (_.apply/* inits @self)]))) - -(def: input - (|>> inc //case.register)) - -(def: #export (function statement expression archive [environment arity bodyS]) - (-> Phase! (Generator (Abstraction Synthesis))) - (do {! ///////phase.monad} - [[[function_module function_artifact] body!] (/////generation.with_new_context archive - (/////generation.with_anchor 1 - (statement expression archive bodyS))) - closureO+ (monad.map ! (expression archive) environment) - #let [function_name (///reference.artifact [function_module function_artifact]) - @curried (_.local "curried") - arityO (|> arity .int _.int) - limitO (|> arity dec .int _.int) - @num_args (_.local "num_args") - @self (_.local function_name) - initialize_self! (_.set (list (//case.register 0)) @self) - initialize! (list\fold (.function (_ post pre!) - ($_ _.then - pre! - (_.set (list (..input post)) (_.nth (|> post .int _.int) @curried)))) - initialize_self! - (list.indices arity)) - [declaration instatiation] (with_closure closureO+ function_name - (_.lambda (#.Some @self) (list (_.variadic @curried)) - ($_ _.then - (_.set (list @num_args) (_.the "length" @curried)) - (_.cond (list [(|> @num_args (_.= arityO)) - (<| (_.then initialize!) - //loop.with_scope - body!)] - [(|> @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)) - (_.do "concat" (list @missing)))))))))))) - )))] - _ (/////generation.execute! declaration) - _ (/////generation.save! function_artifact declaration)] - (wrap instatiation))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux deleted file mode 100644 index a2df0884a..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux +++ /dev/null @@ -1,95 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat]]] - [target - ["_" ruby (#+ Expression LVar Statement)]]] - ["." // #_ - [runtime (#+ Operation Phase Generator Phase! Generator!)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["." synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [reference - ["#." variable (#+ Register)]]]]]]]) - -(def: (setup offset bindings body) - (-> Register (List Expression) Statement Statement) - (|> bindings - list.enumeration - (list\map (function (_ [register value]) - (_.set (list (//case.register (n.+ offset register))) - value))) - list.reverse - (list\fold _.then body))) - -(def: symbol - (_.symbol "lux_continue")) - -(def: #export with_scope - (-> Statement Statement) - (_.while (_.bool true))) - -(def: #export (scope! statement expression archive [start initsS+ bodyS]) - (Generator! (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (statement expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [initsO+ (monad.map ! (expression archive) initsS+) - body! (/////generation.with_anchor start - (statement expression archive bodyS))] - (wrap (<| (..setup start initsO+) - ..with_scope - body!))))) - -(def: #export (scope statement expression archive [start initsS+ bodyS]) - (-> Phase! (Generator (Scope Synthesis))) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [body! (scope! statement expression archive [start initsS+ bodyS])] - (wrap (|> body! - (_.lambda #.None (list)) - (_.apply_lambda/* (list))))))) - -(def: #export (recur! statement expression archive argsS+) - (Generator! (List Synthesis)) - (do {! ///////phase.monad} - [offset /////generation.anchor - @temp (//case.gensym "lux_recur_values") - argsO+ (monad.map ! (expression archive) argsS+) - #let [re_binds (|> argsO+ - list.enumeration - (list\map (function (_ [idx _]) - (_.nth (_.int (.int idx)) @temp))))]] - (wrap ($_ _.then - (_.set (list @temp) (_.array argsO+)) - (..setup offset re_binds - _.next))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux deleted file mode 100644 index 59efdb9fb..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" ruby (#+ Literal)]]]) - -(template [<type> <name> <implementation>] - [(def: #export <name> - (-> <type> Literal) - <implementation>)] - - [Bit bit _.bool] - [(I64 Any) i64 (|>> .int _.int)] - [Frac f64 _.float] - [Text text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux deleted file mode 100644 index 1ea2cca00..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" ruby (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.global) - (def: variable _.local)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux deleted file mode 100644 index 2eb8ec79c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux +++ /dev/null @@ -1,402 +0,0 @@ -(.module: - [lux (#- inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" ruby (#+ Expression LVar Computation Literal Statement)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - ["$" version] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(template [<name> <base>] - [(type: #export <name> - (<base> Register Expression Statement))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(type: #export Phase! - (-> Phase Archive Synthesis (Operation Statement))) - -(type: #export (Generator! i) - (-> Phase! Phase Archive i (Operation Statement))) - -(def: #export unit - (_.string /////synthesis.unit)) - -(def: (flag value) - (-> Bit Literal) - (if value - ..unit - _.nil)) - -(def: (feature name definition) - (-> LVar (-> LVar Statement) Statement) - (definition name)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.local (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(def: module_id - 0) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.local (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) LVar (~ runtime_name))) - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!name)) - (_.set (list (~ g!name)) (~ code)))))))))) - - (#.Right [name inputs]) - (macro.with_gensyms [g!_] - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) Computation) - (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (format "@" name))) - Statement - (..feature (~ runtime_name) - (function ((~ g!_) (~ g!_)) - (..with_vars [(~+ inputsC)] - (_.function (~ g!_) (list (~+ inputsC)) - (~ code)))))))))))))))) - -(def: tuple_size - (_.the "length")) - -(def: last_index - (|>> ..tuple_size (_.- (_.int +1)))) - -(with_expansions [<recur> (as_is ($_ _.then - (_.set (list lefts) (_.- last_index_right lefts)) - (_.set (list tuple) (_.nth last_index_right tuple))))] - (runtime: (tuple//left lefts tuple) - (with_vars [last_index_right] - (<| (_.while (_.bool true)) - ($_ _.then - (_.set (list last_index_right) (..last_index tuple)) - (_.if (_.> lefts last_index_right) - ## No need for recursion - (_.return (_.nth lefts tuple)) - ## Needs recursion - <recur>))))) - - (runtime: (tuple//right lefts tuple) - (with_vars [last_index_right right_index] - (<| (_.while (_.bool true)) - ($_ _.then - (_.set (list last_index_right) (..last_index tuple)) - (_.set (list right_index) (_.+ (_.int +1) lefts)) - (_.cond (list [(_.= last_index_right right_index) - (_.return (_.nth right_index tuple))] - [(_.> last_index_right right_index) - ## Needs recursion. - <recur>]) - (_.return (_.array_range right_index (..tuple_size tuple) tuple))) - ))))) - -(def: #export variant_tag_field "_lux_tag") -(def: #export variant_flag_field "_lux_flag") -(def: #export 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: #export (variant tag last? value) - (-> Nat Bit Expression Computation) - (sum//make (_.int (.int tag)) (..flag last?) value)) - -(def: #export none - Computation - (..variant 0 #0 ..unit)) - -(def: #export some - (-> Expression Computation) - (..variant 1 #1)) - -(def: #export left - (-> Expression Computation) - (..variant 0 #0)) - -(def: #export right - (-> Expression Computation) - (..variant 1 #1)) - -(runtime: (sum//get sum wantsLast wantedTag) - (let [no_match! (_.return _.nil) - sum_tag (_.nth (_.string ..variant_tag_field) sum) - sum_flag (_.nth (_.string ..variant_flag_field) sum) - sum_value (_.nth (_.string ..variant_value_field) sum) - is_last? (_.= ..unit sum_flag) - test_recursion! (_.if is_last? - ## Must recurse. - ($_ _.then - (_.set (list wantedTag) (_.- sum_tag wantedTag)) - (_.set (list 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 - ($_ _.then - @tuple//left - @tuple//right - @sum//make - @sum//get - )) - -(runtime: (lux//try risky) - (with_vars [error value] - (_.begin ($_ _.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] - ($_ _.then - (_.set (list tail) ..none) - (<| (_.for_in head raw) - (_.set (list tail) (..some (_.array (list head tail))))) - (_.return tail)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program_args - )) - -(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] - (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>] - [(_.if (|> input <scenario>) - ($_ _.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))))) - -(runtime: i64//nat_top - (|> (_.int +1) - (_.bit_shl (_.int +64)) - (_.- (_.int +1)))) - -(def: as_nat - (_.% (_.manual "0x10000000000000000"))) - -(runtime: (i64//left_shift param subject) - (_.return (|> subject - (_.bit_shl (_.% (_.int +64) param)) - ..i64//64))) - -(runtime: (i64//right_shift param subject) - ($_ _.then - (_.set (list param) (_.% (_.int +64) param)) - (_.return (_.? (_.= (_.int +0) param) - subject - (|> subject - ..as_nat - (_.bit_shr param)))))) - -(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] - ) - -(runtime: (i64//division parameter subject) - (let [extra (_.do "remainder" (list parameter) subject)] - (_.return (|> subject - (_.- extra) - (_./ parameter))))) - -(def: runtime//i64 - Statement - ($_ _.then - @i64//64 - @i64//nat_top - @i64//left_shift - @i64//right_shift - @i64//and - @i64//or - @i64//xor - @i64//division - )) - -(runtime: (f64//decode inputG) - (with_vars [@input @temp] - ($_ _.then - (_.set (list @input) inputG) - (_.set (list @temp) (_.do "to_f" (list) @input)) - (_.if ($_ _.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 - ($_ _.then - @f64//decode - )) - -(runtime: (text//index subject param start) - (with_vars [idx] - ($_ _.then - (_.set (list idx) (|> subject (_.do "index" (list param start)))) - (_.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)))) - (_.statement (_.raise (_.string "[Lux Error] Cannot get char from text."))))) - -(def: runtime//text - Statement - ($_ _.then - @text//index - @text//clip - @text//char - )) - -(runtime: (array//write idx value array) - ($_ _.then - (_.set (list (_.nth idx array)) value) - (_.return array))) - -(def: runtime//array - Statement - ($_ _.then - @array//write - )) - -(def: runtime - Statement - ($_ _.then - runtime//adt - runtime//lux - runtime//i64 - runtime//f64 - runtime//text - runtime//array - )) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! ..module_id ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [..module_id - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux deleted file mode 100644 index e8d192326..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [target - ["_" ruby (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple generate archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (generate archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (generate archive)) - (///////phase\map _.array)))) - -(def: #export (variant generate archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (//runtime.variant tag right?) - (generate archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux deleted file mode 100644 index 1a36df4e0..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme.lux +++ /dev/null @@ -1,58 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [target - ["_" scheme]]] - ["." / #_ - [runtime (#+ Phase)] - ["#." primitive] - ["#." structure] - ["#." reference] - ["#." case] - ["#." loop] - ["#." function] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - [analysis (#+)] - ["#." synthesis] - ["//#" /// #_ - ["#." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]]) - -(def: #export (generate archive synthesis) - Phase - (case synthesis - (^template [<tag> <generator>] - [(^ (<tag> value)) - (//////phase\wrap (<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) - - (^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/recur /loop.recur] - [////synthesis.function/abstraction /function.function]) - - (#////synthesis.Extension extension) - (///extension.apply archive generate extension) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux deleted file mode 100644 index 884e20c0f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux +++ /dev/null @@ -1,222 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set]]] - [macro - ["." template]] - [math - [number - ["i" int]]] - [target - ["_" scheme (#+ Expression Computation Var)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." primitive] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - ["#." synthesis #_ - ["#/." case]] - ["/#" // #_ - ["#." synthesis (#+ Member Synthesis Path)] - ["#." generation] - ["//#" /// #_ - [reference - ["#." variable (#+ Register)]] - ["#." phase ("#\." monad)] - [meta - [archive (#+ Archive)]]]]]]]) - -(def: #export register - (-> Register Var) - (|>> (///reference.local //reference.system) :assume)) - -(def: #export capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: #export (let expression archive [valueS register bodyS]) - (Generator [Synthesis Register Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS) - bodyO (expression archive bodyS)] - (wrap (_.let (list [(..register register) valueO]) - bodyO)))) - -(def: #export (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)] - (wrap (_.if testO thenO elseO)))) - -(def: #export (get expression archive [pathP valueS]) - (Generator [(List Member) Synthesis]) - (do ///////phase.monad - [valueO (expression archive valueS)] - (wrap (list\fold (function (_ side source) - (.let [method (.case side - (^template [<side> <accessor>] - [(<side> lefts) - (<accessor> (_.int (.int lefts)))]) - ([#.Left //runtime.tuple//left] - [#.Right //runtime.tuple//right]))] - (method source))) - valueO - (list.reverse 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 (recur pathP) - (.case pathP - (#/////synthesis.Then bodyS) - (expression archive bodyS) - - #/////synthesis.Pop - (///////phase\wrap pop_cursor!) - - (#/////synthesis.Bind register) - (///////phase\wrap (_.define_constant (..register register) ..peek)) - - (#/////synthesis.Bit_Fork when thenP elseP) - (do {! ///////phase.monad} - [then! (recur thenP) - else! (.case elseP - (#.Some elseP) - (recur elseP) - - #.None - (wrap ..fail!))] - (wrap (.if when - (_.if ..peek - then! - else!) - (_.if ..peek - else! - then!)))) - - (^template [<tag> <format> <=>] - [(<tag> cons) - (do {! ///////phase.monad} - [clauses (monad.map ! (function (_ [match then]) - (do ! - [then! (recur then)] - (wrap [(<=> (|> match <format>) - ..peek) - then!]))) - (#.Cons cons))] - (wrap (list\fold (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]) - - (^template [<pm> <flag> <prep>] - [(^ (<pm> idx)) - (///////phase\wrap (_.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 inc]) - - (^ (/////synthesis.member/left 0)) - (///////phase\wrap (..push_cursor! (_.vector-ref/2 ..peek (_.int +0)))) - - (^template [<pm> <getter>] - [(^ (<pm> lefts)) - (///////phase\wrap (|> ..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 (recur leftP) - rightO (recur rightP)] - (wrap (_.begin (list leftO - rightO)))) - - (^ (/////synthesis.path/alt leftP rightP)) - (do {! ///////phase.monad} - [leftO (recur leftP) - rightO (recur rightP)] - (wrap (try_pm (_.begin (list restore_cursor! - rightO)) - (_.begin (list save_cursor! - leftO))))) - ))) - -(def: (pattern_matching expression archive pathP) - (Generator Path) - (\ ///////phase.monad map - (try_pm (_.raise/1 (_.string "Invalid expression for pattern-matching."))) - (pattern_matching' expression archive pathP))) - -(def: #export (case expression archive [valueS pathP]) - (Generator [Synthesis Path]) - (do {! ///////phase.monad} - [valueO (expression archive valueS)] - (<| (\ ! map (_.let (list [@cursor (_.list/* (list valueO))] - [@savepoint (_.list/* (list))]))) - (pattern_matching expression archive pathP)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux deleted file mode 100644 index 3bc0a0887..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common]]) - -(def: #export bundle - Bundle - common.bundle) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux deleted file mode 100644 index f7f55e260..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux +++ /dev/null @@ -1,222 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["ex" exception (#+ exception:)] - [parser - ["s" code]]] - [data - ["." product] - ["." text] - [number (#+ hex) - ["f" frac]] - [collection - ["." list ("#\." functor)] - ["dict" dictionary (#+ Dictionary)]]] - ["." macro (#+ with-gensyms) - ["." code] - [syntax (#+ syntax:)]] - [target - ["_" scheme (#+ Expression Computation)]]] - ["." /// #_ - ["#." runtime (#+ Operation Phase Handler Bundle)] - ["#//" /// - ["#." extension - ["." bundle]] - ["#/" // #_ - ["#." synthesis (#+ Synthesis)]]]]) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector 0 Expression) Computation)) -(type: #export Unary (-> (Vector 1 Expression) Computation)) -(type: #export Binary (-> (Vector 2 Expression) Computation)) -(type: #export Trinary (-> (Vector 3 Expression) Computation)) -(type: #export Variadic (-> (List Expression) Computation)) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!extension g!name g!phase g!inputs] - (do {! macro.monad} - [g!input+ (monad.seq ! (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) - Handler) - (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do /////.monad - [(~+ (|> g!input+ - (list\map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) - - (~' _) - (/////.throw /////extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) - -(arity: nullary 0) -(arity: unary 1) -(arity: binary 2) -(arity: trinary 3) - -(def: #export (variadic extension) - (-> Variadic Handler) - (function (_ extension-name) - (function (_ phase inputsS) - (do {! /////.monad} - [inputsI (monad.map ! phase inputsS)] - (wrap (extension inputsI)))))) - -(def: bundle::lux - Bundle - (|> bundle.empty - (bundle.install "is?" (binary (product.uncurry _.eq?/2))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(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-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) - subjectO)) - -(def: (i64::arithmetic-right-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) - subjectO)) - -(def: (i64::logical-right-shift [subjectO paramO]) - Binary - (///runtime.i64//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) - -(template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (|> subjectO (<op> paramO)))] - - [i64::+ _.+/2] - [i64::- _.-/2] - [i64::* _.*/2] - [i64::/ _.quotient/2] - [i64::% _.remainder/2] - ) - -(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] - ) - -(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-shift)) - (bundle.install "logical-right-shift" (binary i64::logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary i64::arithmetic-right-shift)) - (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.uncurry _.string-append/2))) - (bundle.install "size" (unary _.string-length/1)) - (bundle.install "char" (binary text::char)) - (bundle.install "clip" (trinary text::clip))))) - -(def: (io::log input) - Unary - (_.begin (list (_.display/1 input) - _.newline/0))) - -(def: (void code) - (-> Expression Computation) - (_.begin (list code (_.string //////synthesis.unit)))) - -(def: bundle::io - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary (|>> io::log ..void))) - (bundle.install "error" (unary _.raise/1)) - (bundle.install "exit" (unary _.exit/1)) - (bundle.install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string //////synthesis.unit)))))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> bundle::lux - (dict.merge bundle::i64) - (dict.merge bundle::f64) - (dict.merge bundle::text) - (dict.merge bundle::io) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux deleted file mode 100644 index 65c674ded..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux +++ /dev/null @@ -1,100 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)]]] - [target - ["_" scheme (#+ Expression Computation Var)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." reference] - ["#." case] - ["/#" // #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant Tuple Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["#." generation (#+ Context)] - ["//#" /// #_ - [arity (#+ Arity)] - ["#." phase ("#\." monad)] - [reference - [variable (#+ Register Variable)]]]]]]) - -(def: #export (apply expression archive [functionS argsS+]) - (Generator (Application Synthesis)) - (do {! ///////phase.monad} - [functionO (expression archive functionS) - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* argsO+ functionO)))) - -(def: capture - (-> Register Var) - (|>> (///reference.foreign //reference.system) :assume)) - -(def: (with_closure inits function_definition) - (-> (List Expression) Computation (Operation Computation)) - (///////phase\wrap - (case inits - #.Nil - function_definition - - _ - (|> function_definition - (_.lambda [(|> (list.enumeration inits) - (list\map (|>> product.left ..capture))) - #.None]) - (_.apply/* inits))))) - -(def: @curried (_.var "curried")) -(def: @missing (_.var "missing")) - -(def: input - (|>> inc //case.register)) - -(def: #export (function expression archive [environment arity bodyS]) - (Generator (Abstraction Synthesis)) - (do {! ///////phase.monad} - [[function_name bodyO] (/////generation.with_new_context archive - (do ! - [@self (\ ! map (|>> ///reference.artifact _.var) - (/////generation.context archive))] - (/////generation.with_anchor @self - (expression archive bodyS)))) - closureO+ (monad.map ! (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\map ..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/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux deleted file mode 100644 index d4b964910..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux +++ /dev/null @@ -1,63 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." set (#+ Set)]]] - [math - [number - ["n" nat]]] - [target - ["_" scheme]]] - ["." // #_ - [runtime (#+ Operation Phase Generator)] - ["#." case] - ["/#" // #_ - ["#." reference] - ["/#" // #_ - [synthesis - ["." case]] - ["/#" // #_ - ["."synthesis (#+ Scope Synthesis)] - ["#." generation] - ["//#" /// #_ - ["#." phase] - [meta - [archive (#+ Archive)]] - [reference - [variable (#+ Register)]]]]]]]) - -(def: @scope - (_.var "scope")) - -(def: #export (scope expression archive [start initsS+ bodyS]) - (Generator (Scope Synthesis)) - (case initsS+ - ## function/false/non-independent loop - #.Nil - (expression archive bodyS) - - ## true loop - _ - (do {! ///////phase.monad} - [initsO+ (monad.map ! (expression archive) initsS+) - bodyO (/////generation.with_anchor @scope - (expression archive bodyS))] - (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start) //case.register))) - #.None] - bodyO)]) - (_.apply/* initsO+ @scope)))))) - -(def: #export (recur expression archive argsS+) - (Generator (List Synthesis)) - (do {! ///////phase.monad} - [@scope /////generation.anchor - argsO+ (monad.map ! (expression archive) argsS+)] - (wrap (_.apply/* argsO+ @scope)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux deleted file mode 100644 index 4bfa67161..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux (#- i64) - [target - ["_" scheme (#+ Expression)]]]) - -(template [<name> <type> <code>] - [(def: #export <name> - (-> <type> Expression) - <code>)] - - [bit Bit _.bool] - [i64 (I64 Any) (|>> .int _.int)] - [f64 Frac _.float] - [text Text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux deleted file mode 100644 index f24134d9f..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [target - ["_" scheme (#+ Expression)]]] - [/// - [reference (#+ System)]]) - -(implementation: #export system - (System Expression) - - (def: constant _.var) - (def: variable _.var)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux deleted file mode 100644 index 7f55df9a9..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux +++ /dev/null @@ -1,369 +0,0 @@ -(.module: - [lux (#- Location inc) - ["." meta] - [abstract - ["." monad (#+ do)]] - [control - ["." function] - ["<>" parser - ["<.>" code]]] - [data - ["." product] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." list ("#\." functor)] - ["." row]]] - ["." macro - [syntax (#+ syntax:)] - ["." code]] - [math - [number (#+ hex) - ["." i64]]] - ["@" target - ["_" scheme (#+ Expression Computation Var)]]] - ["." /// #_ - ["#." reference] - ["//#" /// #_ - [analysis (#+ Variant)] - ["#." synthesis (#+ Synthesis)] - ["#." generation] - ["//#" /// - ["#." phase] - [reference - [variable (#+ Register)]] - [meta - [archive (#+ Output Archive) - ["." artifact (#+ Registry)]]]]]]) - -(def: module_id - 0) - -(template [<name> <base>] - [(type: #export <name> - (<base> Var Expression Expression))] - - [Operation /////generation.Operation] - [Phase /////generation.Phase] - [Handler /////generation.Handler] - [Bundle /////generation.Bundle] - ) - -(type: #export (Generator i) - (-> Phase Archive i (Operation Expression))) - -(def: #export unit - (_.string /////synthesis.unit)) - -(syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} - body) - (do {! meta.monad} - [ids (monad.seq ! (list.repeat (list.size vars) meta.count))] - (wrap (list (` (let [(~+ (|> vars - (list.zip/2 ids) - (list\map (function (_ [id var]) - (list (code.local_identifier var) - (` (_.var (~ (code.text (format "v" (%.nat id))))))))) - list.concat))] - (~ body))))))) - -(syntax: (runtime: {declaration (<>.or <code>.local_identifier - (<code>.form (<>.and <code>.local_identifier - (<>.some <code>.local_identifier))))} - code) - (do meta.monad - [runtime_id meta.count] - (macro.with_gensyms [g!_] - (let [runtime (code.local_identifier (///reference.artifact [..module_id runtime_id])) - runtime_name (` (_.var (~ (code.text (%.code runtime)))))] - (case declaration - (#.Left name) - (let [g!name (code.local_identifier name)] - (wrap (list (` (def: #export (~ g!name) - Var - (~ runtime_name))) - - (` (def: (~ (code.local_identifier (format "@" name))) - _.Computation - (_.define_constant (~ runtime_name) (~ code))))))) - - (#.Right [name inputs]) - (let [g!name (code.local_identifier name) - inputsC (list\map code.local_identifier inputs) - inputs_typesC (list\map (function.constant (` _.Expression)) - inputs)] - (wrap (list (` (def: #export ((~ g!name) (~+ inputsC)) - (-> (~+ inputs_typesC) _.Computation) - (_.apply/* (list (~+ inputsC)) (~ runtime_name)))) - - (` (def: (~ (code.local_identifier (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) - ($_ _.cons/2 - tag - last? - value)) - -(runtime: (sum//make tag last? value) - (variant' tag last? value)) - -(def: #export (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: #export none - Computation - (|> ..unit [0 #0] variant)) - -(def: #export some - (-> Expression Computation) - (|>> [1 #1] ..variant)) - -(def: #export left - (-> Expression Computation) - (|>> [0 #0] ..variant)) - -(def: #export 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] - (`` (<| (~~ (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_shift param subject) - (|> subject - (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) param)) - ..i64//64)) - -(def: as_nat - (_.remainder/2 ..i64//+iteration)) - -(runtime: (i64//right_shift 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))))))) - -(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_shift - @i64//right_shift - @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 - ($_ _.then - @array//write - )) - -(def: runtime - Computation - (_.begin (list @slice - runtime//lux - runtime//i64 - runtime//adt - runtime//f64 - runtime//text - runtime//array - ))) - -(def: #export generate - (Operation [Registry Output]) - (do ///////phase.monad - [_ (/////generation.execute! ..runtime) - _ (/////generation.save! (%.nat ..module_id) ..runtime)] - (wrap [(|> artifact.empty - artifact.resource - product.right) - (row.row [(%.nat ..module_id) - (|> ..runtime - _.code - (\ utf8.codec encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux deleted file mode 100644 index 951fa494d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - [collection - ["." list]]] - [target - ["_" scheme (#+ Expression)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase Generator)] - ["#." primitive] - ["///#" //// #_ - [analysis (#+ Variant Tuple)] - ["#." synthesis (#+ Synthesis)] - ["//#" /// #_ - ["#." phase ("#\." monad)]]]]) - -(def: #export (tuple expression archive elemsS+) - (Generator (Tuple Synthesis)) - (case elemsS+ - #.Nil - (///////phase\wrap (//primitive.text /////synthesis.unit)) - - (#.Cons singletonS #.Nil) - (expression archive singletonS) - - _ - (|> elemsS+ - (monad.map ///////phase.monad (expression archive)) - (///////phase\map _.vector/*)))) - -(def: #export (variant expression archive [lefts right? valueS]) - (Generator (Variant Synthesis)) - (let [tag (if right? - (inc lefts) - lefts)] - (///////phase\map (|>> [tag right?] //runtime.variant) - (expression archive valueS)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux deleted file mode 100644 index 615e7a722..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis.lux +++ /dev/null @@ -1,103 +0,0 @@ -(.module: - [lux (#- primitive) - [abstract - ["." monad (#+ do)]] - [control - [pipe (#+ case>)] - ["." try]] - [data - ["." maybe] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]]] - ["." / #_ - ["#." function] - ["#." case] - ["#." variable] - ["/#" // #_ - ["#." extension] - ["/#" // #_ - ["#." analysis (#+ Analysis)] - ["/" synthesis (#+ Synthesis Phase)] - [/// - ["." phase ("#\." monad)] - [reference (#+) - [variable (#+)]]]]]]) - -(def: (primitive analysis) - (-> ///analysis.Primitive /.Primitive) - (case analysis - #///analysis.Unit - (#/.Text /.unit) - - (^template [<analysis> <synthesis>] - [(<analysis> value) - (<synthesis> value)]) - ([#///analysis.Bit #/.Bit] - [#///analysis.Frac #/.F64] - [#///analysis.Text #/.Text]) - - (^template [<analysis> <synthesis>] - [(<analysis> value) - (<synthesis> (.i64 value))]) - ([#///analysis.Nat #/.I64] - [#///analysis.Int #/.I64] - [#///analysis.Rev #/.I64]))) - -(def: (optimization archive) - Phase - (function (optimization' analysis) - (case analysis - (#///analysis.Primitive analysis') - (phase\wrap (#/.Primitive (..primitive analysis'))) - - (#///analysis.Reference reference) - (phase\wrap (#/.Reference reference)) - - (#///analysis.Structure structure) - (/.with_currying? false - (case structure - (#///analysis.Variant variant) - (do phase.monad - [valueS (optimization' (get@ #///analysis.value variant))] - (wrap (/.variant (set@ #///analysis.value valueS variant)))) - - (#///analysis.Tuple tuple) - (|> tuple - (monad.map phase.monad optimization') - (phase\map (|>> /.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.run' state) - (case> (#try.Success output) - (#try.Success output) - - (#try.Failure _) - (|> args - (monad.map phase.monad optimization') - (phase\map (|>> [name] #/.Extension)) - (phase.run' state)))))) - ))) - -(def: #export (phase archive analysis) - Phase - (do phase.monad - [synthesis (..optimization archive analysis)] - (phase.lift (/variable.optimization synthesis)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux deleted file mode 100644 index 4d847ec2e..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ /dev/null @@ -1,429 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - ["." monad (#+ do)]] - [control - [pipe (#+ when> new> case>)]] - [data - ["." product] - ["." bit ("#\." equivalence)] - ["." text ("#\." equivalence)] - [collection - ["." list ("#\." functor fold monoid)] - ["." set (#+ Set)]]] - [math - [number - ["n" nat] - ["." i64] - ["." frac ("#\." equivalence)]]]] - ["." /// #_ - [// - ["#." analysis (#+ Pattern Match Analysis)] - ["/" synthesis (#+ Path Synthesis Operation Phase)] - [/// - ["#" phase ("#\." monad)] - ["#." reference - ["#/." variable (#+ Register Variable)]] - [meta - [archive (#+ Archive)]]]]]) - -(def: clean_up - (-> Path Path) - (|>> (#/.Seq #/.Pop))) - -(def: (path' pattern end? thenC) - (-> Pattern Bit (Operation Path) (Operation Path)) - (case pattern - (#///analysis.Simple simple) - (case simple - #///analysis.Unit - thenC - - (#///analysis.Bit when) - (///\map (function (_ then) - (#/.Bit_Fork when then #.None)) - thenC) - - (^template [<from> <to> <conversion>] - [(<from> test) - (///\map (function (_ then) - (<to> [(<conversion> test) then] (list))) - thenC)]) - ([#///analysis.Nat #/.I64_Fork .i64] - [#///analysis.Int #/.I64_Fork .i64] - [#///analysis.Rev #/.I64_Fork .i64] - [#///analysis.Frac #/.F64_Fork |>] - [#///analysis.Text #/.Text_Fork |>])) - - (#///analysis.Bind register) - (<| (\ ///.monad map (|>> (#/.Seq (#/.Bind register)))) - /.with_new_local - thenC) - - (#///analysis.Complex (#///analysis.Variant [lefts right? value_pattern])) - (<| (///\map (|>> (#/.Seq (#/.Access (#/.Side (if right? - (#.Right lefts) - (#.Left lefts))))))) - (path' value_pattern end?) - (when> [(new> (not end?) [])] [(///\map ..clean_up)]) - thenC) - - (#///analysis.Complex (#///analysis.Tuple tuple)) - (let [tuple::last (dec (list.size tuple))] - (list\fold (function (_ [tuple::lefts tuple::member] nextC) - (.case tuple::member - (#///analysis.Simple #///analysis.Unit) - nextC - - _ - (let [right? (n.= tuple::last tuple::lefts) - end?' (and end? right?)] - (<| (///\map (|>> (#/.Seq (#/.Access (#/.Member (if right? - (#.Right (dec tuple::lefts)) - (#.Left tuple::lefts))))))) - (path' tuple::member end?') - (when> [(new> (not end?') [])] [(///\map ..clean_up)]) - nextC)))) - thenC - (list.reverse (list.enumeration tuple)))) - )) - -(def: (path archive synthesize pattern bodyA) - (-> Archive Phase Pattern Analysis (Operation Path)) - (path' pattern true (///\map (|>> #/.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 (\ equivalence = new_test old_test) - [[old_test (weave new_then old_then)] old_tail] - [[old_test old_then] - (case old_tail - #.Nil - (list [new_test new_then]) - - (#.Cons old_cons) - (#.Cons (weave_branch weave equivalence [new_test new_then] old_cons)))])) - -(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\fold (..weave_branch weave equivalence) old_fork (#.Cons new_fork))) - -(def: (weave new old) - (-> Path Path Path) - (with_expansions [<default> (as_is (#/.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))))) - - (^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]) - - (^template [<access> <side>] - [[(#/.Access (<access> (<side> newL))) - (#/.Access (<access> (<side> oldL)))] - (if (n.= newL oldL) - old - <default>)]) - ([#/.Side #.Left] - [#/.Side #.Right] - [#/.Member #.Left] - [#/.Member #.Right]) - - [(#/.Bind newR) (#/.Bind oldR)] - (if (n.= newR oldR) - old - <default>) - - _ - <default>))) - -(def: (get patterns @selection) - (-> (///analysis.Tuple ///analysis.Pattern) Register (List /.Member)) - (loop [lefts 0 - patterns patterns] - (with_expansions [<failure> (as_is (list)) - <continue> (as_is (recur (inc lefts) - tail)) - <member> (as_is (if (list.empty? tail) - (#.Right (dec lefts)) - (#.Left lefts)))] - (case patterns - #.Nil - <failure> - - (#.Cons head tail) - (case head - (#///analysis.Simple #///analysis.Unit) - <continue> - - (#///analysis.Bind register) - (if (n.= @selection register) - (list <member>) - <continue>) - - (#///analysis.Complex (#///analysis.Tuple sub_patterns)) - (case (get sub_patterns @selection) - #.Nil - <continue> - - sub_members - (list& <member> sub_members)) - - _ - <failure>))))) - -(def: #export (synthesize_case synthesize archive input [[headP headA] tailPA+]) - (-> Phase Archive Synthesis Match (Operation Synthesis)) - (do {! ///.monad} - [headSP (path archive synthesize headP headA) - tailSP+ (monad.map ! (product.uncurry (path archive synthesize)) tailPA+)] - (wrap (/.branch/case [input (list\fold weave headSP tailSP+)])))) - -(template: (!masking <variable> <output>) - [[(#///analysis.Bind <variable>) - (#///analysis.Reference (///reference.local <output>))] - (list)]) - -(def: #export (synthesize_let synthesize archive input @variable body) - (-> Phase Archive Synthesis Register Analysis (Operation Synthesis)) - (do ///.monad - [body (/.with_new_local - (synthesize archive body))] - (wrap (/.branch/let [input @variable body])))) - -(def: #export (synthesize_masking synthesize archive input @variable @output) - (-> Phase Archive Synthesis Register Register (Operation Synthesis)) - (if (n.= @variable @output) - (///\wrap input) - (..synthesize_let synthesize archive input @variable (#///analysis.Reference (///reference.local @output))))) - -(def: #export (synthesize_if synthesize archive test then else) - (-> Phase Archive Synthesis Analysis Analysis (Operation Synthesis)) - (do ///.monad - [then (synthesize archive then) - else (synthesize archive else)] - (wrap (/.branch/if [test then else])))) - -(template: (!get <patterns> <output>) - [[(///analysis.pattern/tuple <patterns>) - (#///analysis.Reference (///reference.local <output>))] - (.list)]) - -(def: #export (synthesize_get synthesize archive input patterns @member) - (-> Phase Archive Synthesis (///analysis.Tuple ///analysis.Pattern) Register (Operation Synthesis)) - (case (..get patterns @member) - #.Nil - (..synthesize_case synthesize archive input (!get patterns @member)) - - path - (case input - (^ (/.branch/get [sub_path sub_input])) - (///\wrap (/.branch/get [(list\compose path sub_path) sub_input])) - - _ - (///\wrap (/.branch/get [path input]))))) - -(def: #export (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) - - [[(#///analysis.Bind @variable) body] - #.Nil] - (..synthesize_let synthesize^ archive inputS @variable body) - - (^or (^ [[(///analysis.pattern/bit #1) then] - (list [(///analysis.pattern/bit #0) else])]) - (^ [[(///analysis.pattern/bit #1) then] - (list [(///analysis.pattern/unit) else])]) - - (^ [[(///analysis.pattern/bit #0) else] - (list [(///analysis.pattern/bit #1) then])]) - (^ [[(///analysis.pattern/bit #0) else] - (list [(///analysis.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: #export (count_pops path) - (-> Path [Nat Path]) - (case path - (^ (/.path/seq #/.Pop path')) - (let [[pops post_pops] (count_pops path')] - [(inc pops) post_pops]) - - _ - [0 path])) - -(def: #export pattern_matching_error - "Invalid expression for pattern-matching.") - -(type: #export Storage - {#bindings (Set Register) - #dependencies (Set Variable)}) - -(def: empty - Storage - {#bindings (set.new n.hash) - #dependencies (set.new ///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: #export (storage path) - (-> Path Storage) - (loop for_path - [path path - path_storage ..empty] - (case path - (^or #/.Pop (#/.Access Access)) - path_storage - - (^ (/.path/bind register)) - (update@ #bindings (set.add 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)) - (|> (#.Cons forks) - (list\map product.right) - (list\fold for_path path_storage)) - - (^or (^ (/.path/seq left right)) - (^ (/.path/alt left right))) - (list\fold for_path path_storage (list left right)) - - (^ (/.path/then bodyS)) - (loop for_synthesis - [bodyS bodyS - synthesis_storage path_storage] - (case bodyS - (^ (/.variant [lefts right? valueS])) - (for_synthesis valueS synthesis_storage) - - (^ (/.tuple members)) - (list\fold for_synthesis synthesis_storage members) - - (#/.Reference (#///reference.Variable (#///reference/variable.Local register))) - (if (set.member? (get@ #bindings synthesis_storage) register) - synthesis_storage - (update@ #dependencies (set.add (#///reference/variable.Local register)) synthesis_storage)) - - (#/.Reference (#///reference.Variable var)) - (update@ #dependencies (set.add var) synthesis_storage) - - (^ (/.function/apply [functionS argsS])) - (list\fold for_synthesis synthesis_storage (#.Cons functionS argsS)) - - (^ (/.function/abstraction [environment arity bodyS])) - (list\fold for_synthesis synthesis_storage environment) - - (^ (/.branch/case [inputS pathS])) - (update@ #dependencies - (set.union (get@ #dependencies (for_path pathS synthesis_storage))) - (for_synthesis inputS synthesis_storage)) - - (^ (/.branch/let [inputS register exprS])) - (update@ #dependencies - (set.union (|> synthesis_storage - (update@ #bindings (set.add register)) - (for_synthesis exprS) - (get@ #dependencies))) - (for_synthesis inputS synthesis_storage)) - - (^ (/.branch/if [testS thenS elseS])) - (list\fold for_synthesis synthesis_storage (list testS thenS elseS)) - - (^ (/.branch/get [access whole])) - (for_synthesis whole synthesis_storage) - - (^ (/.loop/scope [start initsS+ iterationS])) - (update@ #dependencies - (set.union (|> synthesis_storage - (update@ #bindings (set.union (|> initsS+ - list.enumeration - (list\map (|>> product.left (n.+ start))) - (set.from_list n.hash)))) - (for_synthesis iterationS) - (get@ #dependencies))) - (list\fold for_synthesis synthesis_storage initsS+)) - - (^ (/.loop/recur replacementsS+)) - (list\fold for_synthesis synthesis_storage replacementsS+) - - (#/.Extension [extension argsS]) - (list\fold for_synthesis synthesis_storage argsS) - - _ - synthesis_storage)) - ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux deleted file mode 100644 index d3558e9c4..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/function.lux +++ /dev/null @@ -1,276 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)] - ["." enum]] - [control - [pipe (#+ case>)] - ["." exception (#+ exception:)]] - [data - ["." maybe ("#\." functor)] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor monoid fold)]]] - [math - [number - ["n" nat]]]] - ["." // #_ - ["#." loop (#+ Transform)] - ["//#" /// #_ - ["#." analysis (#+ Environment Analysis)] - ["/" synthesis (#+ Path Abstraction Synthesis Operation Phase)] - [/// - [arity (#+ Arity)] - ["#." reference - ["#/." variable (#+ Register Variable)]] - ["." phase ("#\." monad)]]]]) - -(exception: #export (cannot_find_foreign_variable_in_environment {foreign Register} {environment (Environment Synthesis)}) - (exception.report - ["Foreign" (%.nat foreign)] - ["Environment" (exception.enumerate /.%synthesis environment)])) - -(def: arity_arguments - (-> Arity (List Synthesis)) - (|>> dec - (enum.range n.enum 1) - (list\map (|>> /.variable/local)))) - -(template: #export (self_reference) - (/.variable/local 0)) - -(def: (expanded_nested_self_reference arity) - (-> Arity Synthesis) - (/.function/apply [(..self_reference) (arity_arguments arity)])) - -(def: #export (apply phase) - (-> Phase Phase) - (function (_ archive exprA) - (let [[funcA argsA] (////analysis.application exprA)] - (do {! phase.monad} - [funcS (phase archive funcA) - argsS (monad.map ! (phase archive) argsA)] - (with_expansions [<apply> (as_is (/.function/apply [funcS argsS]))] - (case funcS - (^ (/.function/abstraction functionS)) - (if (n.= (get@ #/.arity functionS) - (list.size argsS)) - (do ! - [locals /.locals] - (wrap (|> functionS - (//loop.optimization true locals argsS) - (maybe\map (: (-> [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.default <apply>)))) - (wrap <apply>)) - - (^ (/.function/apply [funcS' argsS'])) - (wrap (/.function/apply [funcS' (list\compose argsS' argsS)])) - - _ - (wrap <apply>))))))) - -(def: (find_foreign environment register) - (-> (Environment Synthesis) Register (Operation Synthesis)) - (case (list.nth register environment) - (#.Some aliased) - (phase\wrap aliased) - - #.None - (phase.throw ..cannot_find_foreign_variable_in_environment [register environment]))) - -(def: (grow_path grow path) - (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) - (case path - (#/.Bind register) - (phase\wrap (#/.Bind (inc register))) - - (^template [<tag>] - [(<tag> left right) - (do phase.monad - [left' (grow_path grow left) - right' (grow_path grow right)] - (wrap (<tag> left' right')))]) - ([#/.Alt] [#/.Seq]) - - (#/.Bit_Fork when then else) - (do {! phase.monad} - [then (grow_path grow then) - else (case else - (#.Some else) - (\ ! map (|>> #.Some) (grow_path grow else)) - - #.None - (wrap #.None))] - (wrap (#/.Bit_Fork when then else))) - - (^template [<tag>] - [(<tag> [[test then] elses]) - (do {! phase.monad} - [then (grow_path grow then) - elses (monad.map ! (function (_ [else_test else_then]) - (do ! - [else_then (grow_path grow else_then)] - (wrap [else_test else_then]))) - elses)] - (wrap (<tag> [[test then] elses])))]) - ([#/.I64_Fork] - [#/.F64_Fork] - [#/.Text_Fork]) - - (#/.Then thenS) - (|> thenS - grow - (phase\map (|>> #/.Then))) - - _ - (phase\wrap path))) - -(def: (grow environment expression) - (-> (Environment Synthesis) Synthesis (Operation Synthesis)) - (case expression - (#/.Structure structure) - (case structure - (#////analysis.Variant [lefts right? subS]) - (|> subS - (grow environment) - (phase\map (|>> [lefts right?] /.variant))) - - (#////analysis.Tuple membersS+) - (|> membersS+ - (monad.map phase.monad (grow environment)) - (phase\map (|>> /.tuple)))) - - (^ (..self_reference)) - (phase\wrap (/.function/apply [expression (list (/.variable/local 1))])) - - (#/.Reference reference) - (case reference - (#////reference.Variable variable) - (case variable - (#////reference/variable.Local register) - (phase\wrap (/.variable/local (inc register))) - - (#////reference/variable.Foreign register) - (..find_foreign environment register)) - - (#////reference.Constant constant) - (phase\wrap expression)) - - (#/.Control control) - (case control - (#/.Branch branch) - (case branch - (#/.Let [inputS register bodyS]) - (do phase.monad - [inputS' (grow environment inputS) - bodyS' (grow environment bodyS)] - (wrap (/.branch/let [inputS' (inc register) bodyS']))) - - (#/.If [testS thenS elseS]) - (do phase.monad - [testS' (grow environment testS) - thenS' (grow environment thenS) - elseS' (grow environment elseS)] - (wrap (/.branch/if [testS' thenS' elseS']))) - - (#/.Get members inputS) - (do phase.monad - [inputS' (grow environment inputS)] - (wrap (/.branch/get [members inputS']))) - - (#/.Case [inputS pathS]) - (do phase.monad - [inputS' (grow environment inputS) - pathS' (grow_path (grow environment) pathS)] - (wrap (/.branch/case [inputS' pathS'])))) - - (#/.Loop loop) - (case loop - (#/.Scope [start initsS+ iterationS]) - (do {! phase.monad} - [initsS+' (monad.map ! (grow environment) initsS+) - iterationS' (grow environment iterationS)] - (wrap (/.loop/scope [(inc start) initsS+' iterationS']))) - - (#/.Recur argumentsS+) - (|> argumentsS+ - (monad.map phase.monad (grow environment)) - (phase\map (|>> /.loop/recur)))) - - (#/.Function function) - (case function - (#/.Abstraction [_env _arity _body]) - (do {! phase.monad} - [_env' (monad.map ! - (|>> (case> (#/.Reference (#////reference.Variable (#////reference/variable.Foreign register))) - (..find_foreign environment register) - - captured - (grow environment captured))) - _env)] - (wrap (/.function/abstraction [_env' _arity _body]))) - - (#/.Apply funcS argsS+) - (do {! phase.monad} - [funcS (grow environment funcS) - argsS+ (monad.map ! (grow environment) argsS+)] - (wrap (/.function/apply (case funcS - (^ (/.function/apply [(..self_reference) pre_argsS+])) - [(..self_reference) - (list\compose pre_argsS+ argsS+)] - - _ - [funcS - argsS+])))))) - - (#/.Extension name argumentsS+) - (|> argumentsS+ - (monad.map phase.monad (grow environment)) - (phase\map (|>> (#/.Extension name)))) - - (#/.Primitive _) - (phase\wrap expression))) - -(def: #export (abstraction phase environment archive bodyA) - (-> Phase (Environment Analysis) Phase) - (do {! phase.monad} - [currying? /.currying? - environment (monad.map ! (phase archive) environment) - bodyS (/.with_currying? true - (/.with_locals 2 - (phase archive bodyA))) - abstraction (: (Operation Abstraction) - (case bodyS - (^ (/.function/abstraction [env' down_arity' bodyS'])) - (|> bodyS' - (grow env') - (\ ! map (function (_ body) - {#/.environment environment - #/.arity (inc down_arity') - #/.body body}))) - - _ - (wrap {#/.environment environment - #/.arity 1 - #/.body bodyS})))] - (wrap (if currying? - (/.function/abstraction abstraction) - (case (//loop.optimization false 1 (list) abstraction) - (#.Some [startL initsL bodyL]) - (/.function/abstraction {#/.environment environment - #/.arity (get@ #/.arity abstraction) - #/.body (/.loop/scope [startL initsL bodyL])}) - - #.None - (/.function/abstraction abstraction)))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux deleted file mode 100644 index e0fbf816c..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/loop.lux +++ /dev/null @@ -1,186 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [data - ["." maybe ("#\." monad)] - [collection - ["." list]]] - [math - [number - ["n" nat]]]] - [//// - ["." analysis (#+ Environment)] - ["/" synthesis (#+ Path Abstraction Synthesis)] - [/// - [arity (#+ Arity)] - ["." reference - ["." variable (#+ Register Variable)]]]]) - -(type: #export (Transform a) - (-> a (Maybe a))) - -(def: #export (register_optimization offset) - (-> Register (-> Register Register)) - (|>> dec (n.+ offset))) - -(def: (path_optimization body_optimization offset) - (-> (Transform Synthesis) Register (Transform Path)) - (function (recur path) - (case path - (#/.Bind register) - (#.Some (#/.Bind (register_optimization offset register))) - - (^template [<tag>] - [(<tag> left right) - (do maybe.monad - [left' (recur left) - right' (recur right)] - (wrap (<tag> left' right')))]) - ([#/.Alt] [#/.Seq]) - - (#/.Bit_Fork when then else) - (do {! maybe.monad} - [then (recur then) - else (case else - (#.Some else) - (\ ! map (|>> #.Some) (recur else)) - - #.None - (wrap #.None))] - (wrap (#/.Bit_Fork when then else))) - - (^template [<tag>] - [(<tag> [[test then] elses]) - (do {! maybe.monad} - [then (recur then) - elses (monad.map ! (function (_ [else_test else_then]) - (do ! - [else_then (recur else_then)] - (wrap [else_test else_then]))) - elses)] - (wrap (<tag> [[test then] elses])))]) - ([#/.I64_Fork] - [#/.F64_Fork] - [#/.Text_Fork]) - - (#/.Then body) - (|> body - body_optimization - (maybe\map (|>> #/.Then))) - - _ - (#.Some path)))) - -(def: (body_optimization true_loop? offset scope_environment arity expr) - (-> Bit Register (Environment Synthesis) Arity (Transform Synthesis)) - (loop [return? true - expr expr] - (case expr - (#/.Primitive _) - (#.Some expr) - - (#/.Structure structure) - (case structure - (#analysis.Variant variant) - (do maybe.monad - [value' (|> variant (get@ #analysis.value) (recur false))] - (wrap (|> variant - (set@ #analysis.value value') - /.variant))) - - (#analysis.Tuple tuple) - (|> tuple - (monad.map maybe.monad (recur false)) - (maybe\map (|>> /.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.nth register scope_environment) - (#.Some expr))) - - (^ (/.branch/case [input path])) - (do maybe.monad - [input' (recur false input) - path' (path_optimization (recur return?) offset path)] - (wrap (|> path' [input'] /.branch/case))) - - (^ (/.branch/let [input register body])) - (do maybe.monad - [input' (recur false input) - body' (recur return? body)] - (wrap (/.branch/let [input' (register_optimization offset register) body']))) - - (^ (/.branch/if [input then else])) - (do maybe.monad - [input' (recur false input) - then' (recur return? then) - else' (recur return? else)] - (wrap (/.branch/if [input' then' else']))) - - (^ (/.branch/get [path record])) - (do maybe.monad - [record (recur false record)] - (wrap (/.branch/get [path record]))) - - (^ (/.loop/scope scope)) - (do {! maybe.monad} - [inits' (|> scope - (get@ #/.inits) - (monad.map ! (recur false))) - iteration' (recur return? (get@ #/.iteration scope))] - (wrap (/.loop/scope {#/.start (|> scope (get@ #/.start) (register_optimization offset)) - #/.inits inits' - #/.iteration iteration'}))) - - (^ (/.loop/recur args)) - (|> args - (monad.map maybe.monad (recur false)) - (maybe\map (|>> /.loop/recur))) - - (^ (/.function/abstraction [environment arity body])) - (do {! maybe.monad} - [environment' (monad.map ! (recur false) environment)] - (wrap (/.function/abstraction [environment' arity body]))) - - (^ (/.function/apply [abstraction arguments])) - (do {! maybe.monad} - [arguments' (monad.map maybe.monad (recur false) arguments)] - (with_expansions [<application> (as_is (do ! - [abstraction' (recur false abstraction)] - (wrap (/.function/apply [abstraction' arguments']))))] - (case abstraction - (^ (#/.Reference (#reference.Variable (variable.self)))) - (if (and return? - (n.= arity (list.size arguments))) - (wrap (/.loop/recur arguments')) - (if true_loop? - #.None - <application>)) - - _ - <application>))) - - (#/.Extension [name args]) - (|> args - (monad.map maybe.monad (recur false)) - (maybe\map (|>> [name] #/.Extension)))))) - -(def: #export (optimization true_loop? offset inits functionS) - (-> Bit Register (List Synthesis) Abstraction (Maybe [Register (List Synthesis) Synthesis])) - (|> (get@ #/.body functionS) - (body_optimization true_loop? offset (get@ #/.environment functionS) (get@ #/.arity functionS)) - (maybe\map (|>> [offset inits])))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux deleted file mode 100644 index 68e12745d..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/synthesis/variable.lux +++ /dev/null @@ -1,442 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." maybe ("#\." functor)] - ["." text - ["%" format]] - [collection - ["." dictionary (#+ Dictionary)] - ["." list ("#\." functor fold)] - ["." set]]] - [math - [number - ["n" nat]]]] - [//// - ["/" synthesis (#+ Path Synthesis)] - ["." analysis] - [/// - [arity (#+ Arity)] - ["." reference - ["." variable (#+ Register Variable)]]]]) - -(def: (prune redundant register) - (-> Register Register Register) - (if (n.> redundant register) - (dec register) - register)) - -(type: (Remover a) - (-> Register (-> a a))) - -(def: (remove_local_from_path remove_local redundant) - (-> (Remover Synthesis) (Remover Path)) - (function (recur path) - (case path - (#/.Seq (#/.Bind register) - post) - (if (n.= redundant register) - (recur post) - (#/.Seq (#/.Bind (if (n.> redundant register) - (dec register) - register)) - (recur post))) - - (^or (#/.Seq (#/.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 (#/.Member member)) - (#/.Bind register)) - post)) - (if (n.= redundant register) - (recur post) - (#/.Seq (#/.Access (#/.Member member)) - (#/.Seq (#/.Bind (if (n.> redundant register) - (dec register) - register)) - (recur post)))) - - (^template [<tag>] - [(<tag> left right) - (<tag> (recur left) (recur right))]) - ([#/.Seq] - [#/.Alt]) - - (#/.Bit_Fork when then else) - (#/.Bit_Fork when (recur then) (maybe\map recur else)) - - (^template [<tag>] - [(<tag> [[test then] tail]) - (<tag> [[test (recur then)] - (list\map (function (_ [test' then']) - [test' (recur 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 (recur synthesis) - (case synthesis - (#/.Primitive _) - synthesis - - (#/.Structure structure) - (#/.Structure (case structure - (#analysis.Variant [lefts right value]) - (#analysis.Variant [lefts right (recur value)]) - - (#analysis.Tuple tuple) - (#analysis.Tuple (list\map recur 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 - (#/.Let input register output) - (#/.Let (recur input) - (..prune redundant register) - (recur output)) - - (#/.If test then else) - (#/.If (recur test) (recur then) (recur else)) - - (#/.Get path record) - (#/.Get path (recur record)) - - (#/.Case input path) - (#/.Case (recur input) (remove_local_from_path remove_local redundant path)))) - - (#/.Loop loop) - (#/.Loop (case loop - (#/.Scope [start inits iteration]) - (#/.Scope [(..prune redundant start) - (list\map recur inits) - (recur iteration)]) - - (#/.Recur resets) - (#/.Recur (list\map recur resets)))) - - (#/.Function function) - (#/.Function (case function - (#/.Abstraction [environment arity body]) - (#/.Abstraction [(list\map recur environment) - arity - body]) - - (#/.Apply abstraction inputs) - (#/.Apply (recur abstraction) (list\map recur inputs)))))) - - (#/.Extension name inputs) - (#/.Extension name (list\map recur inputs))))) - -(type: Redundancy - (Dictionary Register Bit)) - -(def: initial - Redundancy - (dictionary.new 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\map (n.+ offset)))] - [extension - (list\fold (function (_ register redundancy) - (dictionary.put register ..necessary! redundancy)) - redundancy - extension)])) - -(def: (default arity) - (-> Arity Redundancy) - (product.right (..extended 0 (inc arity) ..initial))) - -(type: (Optimization a) - (-> [Redundancy a] (Try [Redundancy a]))) - -(def: (list_optimization optimization) - (All [a] (-> (Optimization a) (Optimization (List a)))) - (function (recur [redundancy values]) - (case values - #.Nil - (#try.Success [redundancy - values]) - - (#.Cons head tail) - (do try.monad - [[redundancy head] (optimization [redundancy head]) - [redundancy tail] (recur [redundancy tail])] - (wrap [redundancy - (#.Cons head tail)]))))) - -(template [<name>] - [(exception: #export (<name> {register Register}) - (exception.report - ["Register" (%.nat register)]))] - - [redundant_declaration] - [unknown_register] - ) - -(def: (declare register redundancy) - (-> Register Redundancy (Try Redundancy)) - (case (dictionary.get register redundancy) - #.None - (#try.Success (dictionary.put register ..redundant! redundancy)) - - (#.Some _) - (exception.throw ..redundant_declaration [register]))) - -(def: (observe register redundancy) - (-> Register Redundancy (Try Redundancy)) - (case (dictionary.get register redundancy) - #.None - (exception.throw ..unknown_register [register]) - - (#.Some _) - (#try.Success (dictionary.put register ..necessary! redundancy)))) - -(def: (format redundancy) - (%.Format Redundancy) - (|> redundancy - dictionary.entries - (list\map (function (_ [register redundant?]) - (%.format (%.nat register) ": " (%.bit redundant?)))) - (text.join_with ", "))) - -(def: (path_optimization optimization) - (-> (Optimization Synthesis) (Optimization Path)) - (function (recur [redundancy path]) - (case path - (^or #/.Pop - (#/.Access _)) - (#try.Success [redundancy - path]) - - (#/.Bit_Fork when then else) - (do {! try.monad} - [[redundancy then] (recur [redundancy then]) - [redundancy else] (case else - (#.Some else) - (\ ! map - (function (_ [redundancy else]) - [redundancy (#.Some else)]) - (recur [redundancy else])) - - #.None - (wrap [redundancy #.None]))] - (wrap [redundancy (#/.Bit_Fork when then else)])) - - (^template [<tag> <type>] - [(<tag> [[test then] elses]) - (do {! try.monad} - [[redundancy then] (recur [redundancy then]) - [redundancy elses] (..list_optimization (: (Optimization [<type> Path]) - (function (_ [redundancy [else_test else_then]]) - (do ! - [[redundancy else_then] (recur [redundancy else_then])] - (wrap [redundancy [else_test else_then]])))) - [redundancy elses])] - (wrap [redundancy (<tag> [[test then] elses])]))]) - ([#/.I64_Fork (I64 Any)] - [#/.F64_Fork Frac] - [#/.Text_Fork Text]) - - (#/.Bind register) - (do try.monad - [redundancy (..declare register redundancy)] - (wrap [redundancy - path])) - - (#/.Alt left right) - (do try.monad - [[redundancy left] (recur [redundancy left]) - [redundancy right] (recur [redundancy right])] - (wrap [redundancy (#/.Alt left right)])) - - (#/.Seq pre post) - (do try.monad - [#let [baseline (|> redundancy - dictionary.keys - (set.from_list n.hash))] - [redundancy pre] (recur [redundancy pre]) - #let [bindings (|> redundancy - dictionary.keys - (set.from_list n.hash) - (set.difference baseline))] - [redundancy post] (recur [redundancy post]) - #let [redundants (|> redundancy - dictionary.entries - (list.filter (function (_ [register redundant?]) - (and (set.member? bindings register) - redundant?))) - (list\map product.left))]] - (wrap [(list\fold dictionary.remove redundancy (set.to_list bindings)) - (|> redundants - (list.sort n.>) - (list\fold (..remove_local_from_path ..remove_local) (#/.Seq pre post)))])) - - (#/.Then then) - (do try.monad - [[redundancy then] (optimization [redundancy then])] - (wrap [redundancy (#/.Then then)])) - ))) - -(def: (optimization' [redundancy synthesis]) - (Optimization Synthesis) - (with_expansions [<no_op> (as_is (#try.Success [redundancy - synthesis]))] - (case synthesis - (#/.Primitive _) - <no_op> - - (#/.Structure structure) - (case structure - (#analysis.Variant [lefts right value]) - (do try.monad - [[redundancy value] (optimization' [redundancy value])] - (wrap [redundancy - (#/.Structure (#analysis.Variant [lefts right value]))])) - - (#analysis.Tuple tuple) - (do try.monad - [[redundancy tuple] (..list_optimization optimization' [redundancy tuple])] - (wrap [redundancy - (#/.Structure (#analysis.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 - (#/.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.get register) - (maybe.default ..necessary!))]] - (wrap [(dictionary.remove register redundancy) - (#/.Control (if redundant? - (#/.Branch (#/.Case input - (#/.Seq #/.Pop - (#/.Then (..remove_local register output))))) - (#/.Branch (#/.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])] - (wrap [redundancy - (#/.Control (#/.Branch (#/.If test then else)))])) - - (#/.Get path record) - (do try.monad - [[redundancy record] (optimization' [redundancy record])] - (wrap [redundancy - (#/.Control (#/.Branch (#/.Get path record)))])) - - (#/.Case input path) - (do try.monad - [[redundancy input] (optimization' [redundancy input]) - [redundancy path] (..path_optimization optimization' [redundancy path])] - (wrap [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])] - (wrap [(list\fold dictionary.remove redundancy extension) - (#/.Control (#/.Loop (#/.Scope [start inits iteration])))])) - - (#/.Recur resets) - (do try.monad - [[redundancy resets] (..list_optimization optimization' [redundancy resets])] - (wrap [redundancy - (#/.Control (#/.Loop (#/.Recur resets)))]))) - - (#/.Function function) - (case function - (#/.Abstraction [environment arity body]) - (do {! try.monad} - [[redundancy environment] (..list_optimization optimization' [redundancy environment]) - [_ body] (optimization' [(..default arity) body])] - (wrap [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])] - (wrap [redundancy - (#/.Control (#/.Function (#/.Apply abstraction inputs)))])))) - - (#/.Extension name inputs) - (do try.monad - [[redundancy inputs] (..list_optimization optimization' [redundancy inputs])] - (wrap [redundancy - (#/.Extension name inputs)]))))) - -(def: #export optimization - (-> Synthesis (Try Synthesis)) - (|>> [..initial] - optimization' - (\ try.monad map product.right))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/program.lux b/stdlib/source/lux/tool/compiler/language/lux/program.lux deleted file mode 100644 index fc384c178..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/program.lux +++ /dev/null @@ -1,56 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." maybe] - [text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor)]]]] - [// - [generation (#+ Context)] - [/// - [meta - ["." archive (#+ Archive) - ["." descriptor (#+ Module)] - ["." artifact]]]]]) - -(type: #export (Program expression directive) - (-> Context expression directive)) - -(def: #export name - Text - "") - -(exception: #export (cannot-find-program {modules (List Module)}) - (exception.report - ["Modules" (exception.enumerate %.text modules)])) - -(def: #export (context archive) - (-> Archive (Try Context)) - (do {! try.monad} - [registries (|> archive - archive.archived - (monad.map ! - (function (_ module) - (do ! - [id (archive.id module archive) - [descriptor document] (archive.find module archive)] - (wrap [[module id] (get@ #descriptor.registry descriptor)])))))] - (case (list.one (function (_ [[module module-id] registry]) - (do maybe.monad - [program-id (artifact.remember ..name registry)] - (wrap [module-id program-id]))) - registries) - (#.Some program-context) - (wrap program-context) - - #.None - (|> registries - (list\map (|>> product.left product.left)) - (exception.throw ..cannot-find-program))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/lux/tool/compiler/language/lux/syntax.lux deleted file mode 100644 index 00d1497a1..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/syntax.lux +++ /dev/null @@ -1,582 +0,0 @@ -## This is LuxC's parser. -## It takes the source code of a Lux file in raw text form and -## extracts the syntactic structure of the code from it. -## It only produces Lux Code nodes, and thus removes any white-space -## and comments while processing its inputs. - -## Another important aspect of the parser is that it keeps track of -## its position within the input data. -## That is, the parser takes into account the line and column -## information in the input text (it doesn't really touch the -## file-name aspect of the 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. -(.module: - [lux #* - ["@" target] - [abstract - monad] - [control - ["." exception (#+ exception:)] - [parser - [text (#+ Offset)]]] - [data - ["." maybe] - ["." text - ["%" format (#+ format)]] - [collection - ["." list] - ["." dictionary (#+ Dictionary)]]] - [macro - ["." template]] - [math - [number - ["n" nat] - ["." int] - ["." rev] - ["." frac]]]]) - -(template: (inline: <declaration> <type> <body>) - (for {@.python (def: <declaration> <type> <body>)} - (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) - -(template [<name> <extension> <diff>] - [(template: (<name> value) - (<extension> <diff> value))] - - [!inc "lux i64 +" 1] - [!inc/2 "lux i64 +" 2] - [!dec "lux i64 -" 1] - ) - -(template: (!clip from to text) - ("lux text clip" from (n.- from to) text)) - -(template [<name> <extension>] - [(template: (<name> reference subject) - (<extension> reference subject))] - - [!n/= "lux i64 ="] - [!i/< "lux i64 <"] - ) - -(template [<name> <extension>] - [(template: (<name> param subject) - (<extension> param subject))] - - [!n/+ "lux i64 +"] - [!n/- "lux i64 -"] - ) - -(type: #export Aliases - (Dictionary Text Text)) - -(def: #export no_aliases - Aliases - (dictionary.new text.hash)) - -(def: #export prelude "lux") - -(def: #export text_delimiter text.double_quote) - -(template [<char> <definition>] - [(def: #export <definition> <char>)] - - ## Form delimiters - ["(" open_form] - [")" close_form] - - ## Tuple delimiters - ["[" open_tuple] - ["]" close_tuple] - - ## Record delimiters - ["{" open_record] - ["}" close_record] - - ["#" 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. - ["." name_separator] - ) - -(exception: #export (end_of_file {module Text}) - (exception.report - ["Module" (%.text module)])) - -(def: amount_of_input_shown 64) - -(inline: (input_at start input) - (-> Offset Text Text) - (let [end (|> start (!n/+ amount_of_input_shown) (n.min ("lux text size" input)))] - (!clip start end input))) - -(exception: #export (unrecognized_input {[file line column] 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: #export (text_cannot_contain_new_lines {text Text}) - (exception.report - ["Text" (%.text text)])) - -(template: (!failure parser where offset source_code) - (#.Left [[where offset source_code] - (exception.construct ..unrecognized_input [where (%.name (name_of parser)) source_code offset])])) - -(template: (!end_of_file where offset source_code current_module) - (#.Left [[where offset source_code] - (exception.construct ..end_of_file current_module)])) - -(type: (Parser a) - (-> Source (Either [Source Text] [Source a]))) - -(template: (!with_char+ @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)) - -(template: (!with_char @source_code @offset @char @else @body) - (!with_char+ ("lux text size" @source_code) @source_code @offset @char @else @body)) - -(template: (!letE <binding> <computation> <body>) - (case <computation> - (#.Right <binding>) - <body> - - ## (#.Left error) - <<otherwise>> - (:assume <<otherwise>>))) - -(template: (!horizontal where offset source_code) - [(update@ #.column inc where) - (!inc offset) - source_code]) - -(inline: (!new_line where) - (-> Location Location) - (let [[where::file where::line where::column] where] - [where::file (!inc where::line) 0])) - -(inline: (!forward length where) - (-> Nat Location Location) - (let [[where::file where::line where::column] where] - [where::file where::line (!n/+ length where::column)])) - -(template: (!vertical where offset source_code) - [(!new_line where) - (!inc offset) - source_code]) - -(template [<name> <close> <tag>] - [(inline: (<name> parse where offset source_code) - (-> (Parser Code) Location Offset Text - (Either [Source Text] [Source Code])) - (loop [source (: Source [(!forward 1 where) offset source_code]) - stack (: (List Code) #.Nil)] - (case (parse source) - (#.Right [source' top]) - (recur source' (#.Cons top stack)) - - (#.Left [source' error]) - (if (is? <close> error) - (#.Right [source' - [where (<tag> (list.reverse 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. - [parse_form ..close_form #.Form] - [parse_tuple ..close_tuple #.Tuple] - ) - -(inline: (parse_record parse where offset source_code) - (-> (Parser Code) Location Offset Text - (Either [Source Text] [Source Code])) - (loop [source (: Source [(!forward 1 where) offset source_code]) - stack (: (List [Code Code]) #.Nil)] - (case (parse source) - (#.Right [sourceF field]) - (!letE [sourceFV value] (parse sourceF) - (recur sourceFV (#.Cons [field value] stack))) - - (#.Left [source' error]) - (if (is? ..close_record error) - (#.Right [source' - [where (#.Record (list.reverse stack))]]) - (#.Left [source' error]))))) - -(template: (!guarantee_no_new_lines 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.construct ..text_cannot_contain_new_lines content)]))) - -(def: (parse_text 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)] - (update@ #.column (|>> (!n/+ size) (!n/+ 2)) where)) - (!inc g!end) - source_code] - [where - (#.Text g!content)]])) - - _ - (!failure ..parse_text where offset source_code))) - -(with_expansions [<digits> (as_is "0" "1" "2" "3" "4" "5" "6" "7" "8" "9") - <non_name_chars> (template [<char>] - [(~~ (static <char>))] - - [text.space] - [text.new_line] [text.carriage_return] - [..name_separator] - [..open_form] [..close_form] - [..open_tuple] [..close_tuple] - [..open_record] [..close_record] - [..text_delimiter] - [..sigil]) - <digit_separator> (static ..digit_separator)] - (template: (!if_digit? @char @then @else) - ("lux syntax char case!" @char - [[<digits>] - @then] - - ## else - @else)) - - (template: (!if_digit?+ @char @then @else_options @else) - (`` ("lux syntax char case!" @char - [[<digits> <digit_separator>] - @then - - (~~ (template.splice @else_options))] - - ## else - @else))) - - (`` (template: (!if_name_char?|tail @char @then @else) - ("lux syntax char case!" @char - [[<non_name_chars>] - @else] - - ## else - @then))) - - (`` (template: (!if_name_char?|head @char @then @else) - ("lux syntax char case!" @char - [[<non_name_chars> <digits>] - @else] - - ## else - @then))) - ) - -(template: (!number_output <source_code> <start> <end> <codec> <tag>) - (case (|> <source_code> - (!clip <start> <end>) - (text.replace_all ..digit_separator "") - (\ <codec> decode)) - (#.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> (as_is (!number_output source_code start end int.decimal #.Int)) - <frac_output> (as_is (!number_output source_code start end frac.decimal #.Frac)) - <failure> (!failure ..parse_frac where offset source_code) - <frac_separator> (static ..frac_separator) - <signs> (template [<sign>] - [(~~ (static <sign>))] - - [..positive_sign] - [..negative_sign])] - (inline: (parse_frac source_code//size start where offset source_code) - (-> Nat Nat Location Offset Text - (Either [Source Text] [Source Code])) - (loop [end offset - exponent (static ..no_exponent)] - (<| (!with_char+ source_code//size source_code end char/0 <frac_output>) - (!if_digit?+ char/0 - (recur (!inc end) exponent) - - [["e" "E"] - (if (is? (static ..no_exponent) exponent) - (<| (!with_char+ source_code//size source_code (!inc 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 - (recur (!n/+ 3 end) char/0) - [] - <failure>))] - ## else - <failure>))) - <frac_output>)] - - <frac_output>)))) - - (inline: (parse_signed source_code//size start where offset source_code) - (-> Nat Nat Location Offset Text - (Either [Source Text] [Source Code])) - (loop [end offset] - (<| (!with_char+ source_code//size source_code end char <int_output>) - (!if_digit?+ char - (recur (!inc end)) - - [[<frac_separator>] - (parse_frac source_code//size start where (!inc end) source_code)] - - <int_output>)))) - ) - -(template [<parser> <codec> <tag>] - [(inline: (<parser> source_code//size start where offset source_code) - (-> Nat Nat Location Offset Text - (Either [Source Text] [Source Code])) - (loop [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 - (recur (!inc g!end)) - [] - (!number_output source_code start g!end <codec> <tag>)))))] - - [parse_nat n.decimal #.Nat] - [parse_rev rev.decimal #.Rev] - ) - -(template: (!parse_signed source_code//size offset where source_code @aliases @end) - (<| (let [g!offset/1 (!inc offset)]) - (!with_char+ source_code//size source_code g!offset/1 g!char/1 @end) - (!if_digit? g!char/1 - (parse_signed source_code//size offset where (!inc/2 offset) source_code) - (!parse_full_name offset [where (!inc offset) source_code] where @aliases #.Identifier)))) - -(with_expansions [<output> (#.Right [[(update@ #.column (|>> (!n/+ (!n/- start end))) where) - end - source_code] - (!clip start end source_code)])] - (inline: (parse_name_part start where offset source_code) - (-> Nat Location Offset Text - (Either [Source Text] [Source Text])) - (let [source_code//size ("lux text size" source_code)] - (loop [end offset] - (<| (!with_char+ source_code//size source_code end char <output>) - (!if_name_char?|tail char - (recur (!inc end)) - <output>)))))) - -(template: (!parse_half_name @offset @char @module) - (!if_name_char?|head @char - (!letE [source' name] (..parse_name_part @offset where (!inc @offset) source_code) - (#.Right [source' [@module name]])) - (!failure ..!parse_half_name where @offset source_code))) - -(`` (def: (parse_short_name source_code//size current_module [where offset/0 source_code]) - (-> Nat Text (Parser Name)) - (<| (!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 ..name_separator))) char/0) - (<| (let [offset/1 (!inc offset/0)]) - (!with_char+ source_code//size source_code offset/1 char/1 - (!end_of_file where offset/1 source_code current_module)) - (!parse_half_name offset/1 char/1 current_module)) - (!parse_half_name offset/0 char/0 (static ..prelude)))))) - -(template: (!parse_short_name source_code//size @current_module @source @where @tag) - (!letE [source' name] (..parse_short_name source_code//size @current_module @source) - (#.Right [source' [@where (@tag name)]]))) - -(with_expansions [<simple> (as_is (#.Right [source' ["" simple]]))] - (`` (def: (parse_full_name aliases start source) - (-> Aliases Offset (Parser Name)) - (<| (!letE [source' simple] (let [[where offset source_code] source] - (..parse_name_part start where offset source_code))) - (let [[where' offset' source_code'] source']) - (!with_char source_code' offset' char/separator <simple>) - (if (!n/= (char (~~ (static ..name_separator))) char/separator) - (<| (let [offset'' (!inc offset')]) - (!letE [source'' complex] (..parse_name_part offset'' (!forward 1 where') offset'' source_code')) - (if ("lux text =" "" complex) - (let [[where offset source_code] source] - (!failure ..parse_full_name where offset source_code)) - (#.Right [source'' [(|> aliases - (dictionary.get simple) - (maybe.default simple)) - complex]]))) - <simple>))))) - -(template: (!parse_full_name @offset @source @where @aliases @tag) - (!letE [source' full_name] (..parse_full_name @aliases @offset @source) - (#.Right [source' [@where (@tag full_name)]]))) - -## TODO: Grammar macro for specifying syntax. -## (grammar: lux_grammar -## [expression ...] -## [form "(" [#* expression] ")"]) - -(with_expansions [<consume_1> (as_is where (!inc offset/0) source_code) - <move_1> (as_is [(!forward 1 where) (!inc offset/0) source_code]) - <move_2> (as_is [(!forward 1 where) (!inc/2 offset/0) source_code]) - <recur> (as_is (parse current_module aliases source_code//size)) - <horizontal_move> (as_is (recur (!horizontal where offset/0 source_code)))] - - (template: (!close closer) - (#.Left [<move_1> closer])) - - (def: #export (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 (recur [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> (template [<open> <close> <parser>] - [[(~~ (static <open>))] - (<parser> <recur> <consume_1>) - - [(~~ (static <close>))] - (!close <close>)] - - [..open_form ..close_form parse_form] - [..open_tuple ..close_tuple parse_tuple] - [..open_record ..close_record parse_record] - )] - (`` ("lux syntax char case!" char/0 - [[(~~ (static text.space)) - (~~ (static text.carriage_return))] - <horizontal_move> - - ## New line - [(~~ (static text.new_line))] - (recur (!vertical where offset/0 source_code)) - - <composites> - - ## Text - [(~~ (static ..text_delimiter))] - (parse_text where (!inc offset/0) source_code) - - ## Special code - [(~~ (static ..sigil))] - (<| (let [offset/1 (!inc 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 - [[(~~ (static ..name_separator))] - (!parse_short_name source_code//size current_module <move_2> where #.Tag) - - ## Single_line comment - [(~~ (static ..sigil))] - (case ("lux text index" (!inc offset/1) (static text.new_line) source_code) - (#.Some end) - (recur (!vertical where end source_code)) - - _ - (!end_of_file where offset/1 source_code current_module)) - - (~~ (template [<char> <bit>] - [[<char>] - (#.Right [[(update@ #.column (|>> !inc/2) where) - (!inc offset/1) - source_code] - [where (#.Bit <bit>)]])] - - ["0" #0] - ["1" #1]))] - - ## else - (!if_name_char?|head char/1 - ## Tag - (!parse_full_name offset/1 <move_2> where aliases #.Tag) - (!failure ..parse where offset/0 source_code)))) - - ## Coincidentally (= ..name_separator ..frac_separator) - [(~~ (static ..name_separator)) - ## (~~ (static ..frac_separator)) - ] - (<| (let [offset/1 (!inc 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 - (parse_rev source_code//size offset/0 where (!inc offset/1) source_code) - (!parse_short_name source_code//size current_module [where offset/1 source_code] where #.Identifier))) - - [(~~ (static ..positive_sign)) - (~~ (static ..negative_sign))] - (!parse_signed source_code//size offset/0 where source_code aliases - (!end_of_file where offset/0 source_code current_module))] - - ## else - (!if_digit? char/0 - ## Natural number - (parse_nat source_code//size offset/0 where (!inc offset/0) source_code) - ## Identifier - (!parse_full_name offset/0 [<consume_1>] where aliases #.Identifier)) - ))) - ))) - )) diff --git a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux deleted file mode 100644 index 0b2086f25..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/synthesis.lux +++ /dev/null @@ -1,808 +0,0 @@ -(.module: - [lux (#- i64 Scope) - [abstract - [monad (#+ do)] - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [control - [pipe (#+ case>)] - ["." exception (#+ exception:)]] - [data - ["." sum] - ["." product] - ["." maybe] - ["." bit ("#\." equivalence)] - ["." text ("#\." equivalence) - ["%" format (#+ Format format)]] - [collection - ["." list ("#\." functor)] - ["." dictionary (#+ Dictionary)]]] - [math - [number - ["." i64] - ["n" nat] - ["i" int] - ["f" frac]]]] - [// - ["." analysis (#+ Environment Composite Analysis)] - [phase - ["." extension (#+ Extension)]] - [/// - [arity (#+ Arity)] - ["." phase] - ["." reference (#+ Reference) - ["." variable (#+ Register Variable)]]]]) - -(type: #export Resolver - (Dictionary Variable Variable)) - -(type: #export State - {#locals Nat - ## https://en.wikipedia.org/wiki/Currying - #currying? Bit}) - -(def: #export fresh_resolver - Resolver - (dictionary.new variable.hash)) - -(def: #export init - State - {#locals 0 - #currying? false}) - -(type: #export Primitive - (#Bit Bit) - (#I64 (I64 Any)) - (#F64 Frac) - (#Text Text)) - -(type: #export Side - (Either Nat Nat)) - -(type: #export Member - (Either Nat Nat)) - -(type: #export Access - (#Side Side) - (#Member Member)) - -(type: #export (Fork value next) - [[value next] (List [value next])]) - -(type: #export (Path' s) - #Pop - (#Access Access) - (#Bind Register) - (#Bit_Fork Bit (Path' s) (Maybe (Path' s))) - (#I64_Fork (Fork (I64 Any) (Path' s))) - (#F64_Fork (Fork Frac (Path' s))) - (#Text_Fork (Fork Text (Path' s))) - (#Alt (Path' s) (Path' s)) - (#Seq (Path' s) (Path' s)) - (#Then s)) - -(type: #export (Abstraction' s) - {#environment (Environment s) - #arity Arity - #body s}) - -(type: #export (Apply' s) - {#function s - #arguments (List s)}) - -(type: #export (Branch s) - (#Let s Register s) - (#If s s s) - (#Get (List Member) s) - (#Case s (Path' s))) - -(type: #export (Scope s) - {#start Register - #inits (List s) - #iteration s}) - -(type: #export (Loop s) - (#Scope (Scope s)) - (#Recur (List s))) - -(type: #export (Function s) - (#Abstraction (Abstraction' s)) - (#Apply s (List s))) - -(type: #export (Control s) - (#Branch (Branch s)) - (#Loop (Loop s)) - (#Function (Function s))) - -(type: #export #rec Synthesis - (#Primitive Primitive) - (#Structure (Composite Synthesis)) - (#Reference Reference) - (#Control (Control Synthesis)) - (#Extension (Extension Synthesis))) - -(template [<special> <general>] - [(type: #export <special> - (<general> ..State Analysis Synthesis))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(type: #export Path - (Path' Synthesis)) - -(def: #export path/pop - Path - #Pop) - -(template [<name> <kind>] - [(template: #export (<name> content) - (.<| #..Access - <kind> - content))] - - [path/side #..Side] - [path/member #..Member] - ) - -(template [<name> <kind> <side>] - [(template: #export (<name> content) - (.<| #..Access - <kind> - <side> - content))] - - [side/left #..Side #.Left] - [side/right #..Side #.Right] - [member/left #..Member #.Left] - [member/right #..Member #.Right] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (<tag> content))] - - [path/bind #..Bind] - [path/then #..Then] - ) - -(template [<name> <tag>] - [(template: #export (<name> left right) - (<tag> [left right]))] - - [path/alt #..Alt] - [path/seq #..Seq] - ) - -(type: #export Abstraction - (Abstraction' Synthesis)) - -(type: #export Apply - (Apply' Synthesis)) - -(def: #export unit Text "") - -(template [<with> <query> <tag> <type>] - [(def: #export (<with> value) - (-> <type> (All [a] (-> (Operation a) (Operation a)))) - (extension.temporary (set@ <tag> value))) - - (def: #export <query> - (Operation <type>) - (extension.read (get@ <tag>)))] - - [with_locals locals #locals Nat] - [with_currying? currying? #currying? Bit] - ) - -(def: #export with_new_local - (All [a] (-> (Operation a) (Operation a))) - (<<| (do phase.monad - [locals ..locals]) - (..with_locals (inc locals)))) - -(template [<name> <tag>] - [(template: #export (<name> content) - (#..Primitive (<tag> content)))] - - [bit #..Bit] - [i64 #..I64] - [f64 #..F64] - [text #..Text] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (<| #..Structure - <tag> - content))] - - [variant #analysis.Variant] - [tuple #analysis.Tuple] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (.<| #..Reference - <tag> - content))] - - [variable reference.variable] - [constant reference.constant] - [variable/local reference.local] - [variable/foreign reference.foreign] - ) - -(template [<name> <family> <tag>] - [(template: #export (<name> content) - (.<| #..Control - <family> - <tag> - content))] - - [branch/case #..Branch #..Case] - [branch/let #..Branch #..Let] - [branch/if #..Branch #..If] - [branch/get #..Branch #..Get] - - [loop/recur #..Loop #..Recur] - [loop/scope #..Loop #..Scope] - - [function/abstraction #..Function #..Abstraction] - [function/apply #..Function #..Apply] - ) - -(def: #export (%path' %then value) - (All [a] (-> (Format a) (Format (Path' a)))) - (case value - #Pop - "_" - - (#Bit_Fork when then else) - (format "(?" - " " (%.bit when) " " (%path' %then then) - (case else - (#.Some else) - (format " " (%.bit (not when)) " " (%path' %then else)) - - #.None - "") - ")") - - (^template [<tag> <format>] - [(<tag> cons) - (|> (#.Cons cons) - (list\map (function (_ [test then]) - (format (<format> test) " " (%path' %then then)))) - (text.join_with " ") - (text.enclose ["(? " ")"]))]) - ([#I64_Fork (|>> .int %.int)] - [#F64_Fork %.frac] - [#Text_Fork %.text]) - - (#Access access) - (case access - (#Side side) - (case side - (#.Left lefts) - (format "(" (%.nat lefts) " #0" ")") - - (#.Right lefts) - (format "(" (%.nat lefts) " #1" ")")) - - (#Member member) - (case member - (#.Left lefts) - (format "[" (%.nat lefts) " #0" "]") - - (#.Right lefts) - (format "[" (%.nat lefts) " #1" "]"))) - - (#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.enclose ["(! " ")"])))) - -(def: #export (%synthesis value) - (Format Synthesis) - (case value - (#Primitive primitive) - (case primitive - (^template [<pattern> <format>] - [(<pattern> value) - (<format> value)]) - ([#Bit %.bit] - [#F64 %.frac] - [#Text %.text]) - - (#I64 value) - (%.int (.int value))) - - (#Structure structure) - (case structure - (#analysis.Variant [lefts right? content]) - (|> (%synthesis content) - (format (%.nat lefts) " " (%.bit right?) " ") - (text.enclose ["(" ")"])) - - (#analysis.Tuple members) - (|> members - (list\map %synthesis) - (text.join_with " ") - (text.enclose ["[" "]"]))) - - (#Reference reference) - (reference.format reference) - - (#Control control) - (case control - (#Function function) - (case function - (#Abstraction [environment arity body]) - (let [environment' (|> environment - (list\map %synthesis) - (text.join_with " ") - (text.enclose ["[" "]"]))] - (|> (format environment' " " (%.nat arity) " " (%synthesis body)) - (text.enclose ["(#function " ")"]))) - - (#Apply func args) - (|> args - (list\map %synthesis) - (text.join_with " ") - (format (%synthesis func) " ") - (text.enclose ["(" ")"]))) - - (#Branch branch) - (case branch - (#Let input register body) - (|> (format (%.nat register) " " (%synthesis input) " " (%synthesis body)) - (text.enclose ["(#let " ")"])) - - (#If test then else) - (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else)) - (text.enclose ["(#if " ")"])) - - (#Get members record) - (|> (format (%.list (%path' %synthesis) - (list\map (|>> #Member #Access) members)) - " " (%synthesis record)) - (text.enclose ["(#get " ")"])) - - (#Case input path) - (|> (format (%synthesis input) " " (%path' %synthesis path)) - (text.enclose ["(#case " ")"]))) - - (#Loop loop) - (case loop - (#Scope scope) - (|> (format (%.nat (get@ #start scope)) - " " (|> (get@ #inits scope) - (list\map %synthesis) - (text.join_with " ") - (text.enclose ["[" "]"])) - " " (%synthesis (get@ #iteration scope))) - (text.enclose ["(#loop " ")"])) - - (#Recur args) - (|> args - (list\map %synthesis) - (text.join_with " ") - (text.enclose ["(#recur " ")"])))) - - (#Extension [name args]) - (|> (list\map %synthesis args) - (text.join_with " ") - (format (%.text name) " ") - (text.enclose ["(" ")"])))) - -(def: #export %path - (Format Path) - (%path' %synthesis)) - -(implementation: #export primitive_equivalence - (Equivalence Primitive) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <eq> <format>] - [[(<tag> reference') (<tag> sample')] - (<eq> reference' sample')]) - ([#Bit bit\= %.bit] - [#F64 f.= %.frac] - [#Text text\= %.text]) - - [(#I64 reference') (#I64 sample')] - (i.= (.int reference') (.int sample')) - - _ - false))) - -(implementation: primitive_hash - (Hash Primitive) - - (def: &equivalence ..primitive_equivalence) - - (def: hash - (|>> (case> (^template [<tag> <hash>] - [(<tag> value') - (\ <hash> hash value')]) - ([#Bit bit.hash] - [#F64 f.hash] - [#Text text.hash] - [#I64 i64.hash]))))) - -(def: side_equivalence - (Equivalence Side) - (sum.equivalence n.equivalence n.equivalence)) - -(def: member_equivalence - (Equivalence Member) - (sum.equivalence n.equivalence n.equivalence)) - -(def: member_hash - (Hash Member) - (sum.hash n.hash n.hash)) - -(implementation: #export access_equivalence - (Equivalence Access) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <equivalence>] - [[(<tag> reference) (<tag> sample)] - (\ <equivalence> = reference sample)]) - ([#Side ..side_equivalence] - [#Member ..member_equivalence]) - - _ - false))) - -(implementation: access_hash - (Hash Access) - - (def: &equivalence ..access_equivalence) - - (def: (hash value) - (let [sub_hash (sum.hash n.hash n.hash)] - (case value - (^template [<tag>] - [(<tag> value) - (\ sub_hash hash value)]) - ([#Side] - [#Member]))))) - -(implementation: #export (path'_equivalence equivalence) - (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) - - (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) - (\ (maybe.equivalence =) = reference_else sample_else)) - - (^template [<tag> <equivalence>] - [[(<tag> reference_cons) - (<tag> sample_cons)] - (\ (list.equivalence (product.equivalence <equivalence> =)) = - (#.Cons reference_cons) - (#.Cons sample_cons))]) - ([#I64_Fork i64.equivalence] - [#F64_Fork f.equivalence] - [#Text_Fork text.equivalence]) - - (^template [<tag> <equivalence>] - [[(<tag> reference') (<tag> sample')] - (\ <equivalence> = reference' sample')]) - ([#Access ..access_equivalence] - [#Then equivalence]) - - [(#Bind reference') (#Bind sample')] - (n.= reference' sample') - - (^template [<tag>] - [[(<tag> leftR rightR) (<tag> leftS rightS)] - (and (= leftR leftS) - (= rightR rightS))]) - ([#Alt] - [#Seq]) - - _ - false))) - -(implementation: (path'_hash super) - (All [a] (-> (Hash a) (Hash (Path' a)))) - - (def: &equivalence - (..path'_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - #Pop - 2 - - (#Access access) - (n.* 3 (\ ..access_hash hash access)) - - (#Bind register) - (n.* 5 (\ n.hash hash register)) - - (#Bit_Fork when then else) - ($_ n.* 7 - (\ bit.hash hash when) - (hash then) - (\ (maybe.hash (path'_hash super)) hash else)) - - (^template [<factor> <tag> <hash>] - [(<tag> cons) - (let [case_hash (product.hash <hash> - (path'_hash super)) - cons_hash (product.hash case_hash (list.hash case_hash))] - (n.* <factor> (\ cons_hash hash cons)))]) - ([11 #I64_Fork i64.hash] - [13 #F64_Fork f.hash] - [17 #Text_Fork text.hash]) - - (^template [<factor> <tag>] - [(<tag> fork) - (let [recur_hash (path'_hash super) - fork_hash (product.hash recur_hash recur_hash)] - (n.* <factor> (\ fork_hash hash fork)))]) - ([19 #Alt] - [23 #Seq]) - - (#Then body) - (n.* 29 (\ super hash body)) - ))) - -(implementation: (branch_equivalence (^open "\.")) - (All [a] (-> (Equivalence a) (Equivalence (Branch a)))) - - (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 (\ (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) - (\ (path'_equivalence \=) = reference_path sample_path)) - - _ - false))) - -(implementation: (branch_hash super) - (All [a] (-> (Hash a) (Hash (Branch a)))) - - (def: &equivalence - (..branch_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (#Let [input register body]) - ($_ n.* 2 - (\ super hash input) - (\ n.hash hash register) - (\ super hash body)) - - (#If [test then else]) - ($_ n.* 3 - (\ super hash test) - (\ super hash then) - (\ super hash else)) - - (#Get [path record]) - ($_ n.* 5 - (\ (list.hash ..member_hash) hash path) - (\ super hash record)) - - (#Case [input path]) - ($_ n.* 7 - (\ super hash input) - (\ (..path'_hash super) hash path)) - ))) - -(implementation: (loop_equivalence (^open "\.")) - (All [a] (-> (Equivalence a) (Equivalence (Loop a)))) - - (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) - (\ (list.equivalence \=) = reference_inits sample_inits) - (\= reference_iteration sample_iteration)) - - [(#Recur reference) (#Recur sample)] - (\ (list.equivalence \=) = reference sample) - - _ - false))) - -(implementation: (loop_hash super) - (All [a] (-> (Hash a) (Hash (Loop a)))) - - (def: &equivalence - (..loop_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (#Scope [start inits iteration]) - ($_ n.* 2 - (\ n.hash hash start) - (\ (list.hash super) hash inits) - (\ super hash iteration)) - - (#Recur resets) - ($_ n.* 3 - (\ (list.hash super) hash resets)) - ))) - -(implementation: (function_equivalence (^open "\.")) - (All [a] (-> (Equivalence a) (Equivalence (Function a)))) - - (def: (= reference sample) - (case [reference sample] - [(#Abstraction [reference_environment reference_arity reference_body]) - (#Abstraction [sample_environment sample_arity sample_body])] - (and (\ (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) - (\ (list.equivalence \=) = reference_arguments sample_arguments)) - - _ - false))) - -(implementation: (function_hash super) - (All [a] (-> (Hash a) (Hash (Function a)))) - - (def: &equivalence - (..function_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (#Abstraction [environment arity body]) - ($_ n.* 2 - (\ (list.hash super) hash environment) - (\ n.hash hash arity) - (\ super hash body)) - - (#Apply [abstraction arguments]) - ($_ n.* 3 - (\ super hash abstraction) - (\ (list.hash super) hash arguments)) - ))) - -(implementation: (control_equivalence (^open "\.")) - (All [a] (-> (Equivalence a) (Equivalence (Control a)))) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <equivalence>] - [[(<tag> reference) (<tag> sample)] - (\ (<equivalence> \=) = reference sample)]) - ([#Branch ..branch_equivalence] - [#Loop ..loop_equivalence] - [#Function ..function_equivalence]) - - _ - false))) - -(implementation: (control_hash super) - (All [a] (-> (Hash a) (Hash (Control a)))) - - (def: &equivalence - (..control_equivalence (\ super &equivalence))) - - (def: (hash value) - (case value - (^template [<factor> <tag> <hash>] - [(<tag> value) - (n.* <factor> (\ (<hash> super) hash value))]) - ([2 #Branch ..branch_hash] - [3 #Loop ..loop_hash] - [5 #Function ..function_hash]) - ))) - -(implementation: #export equivalence - (Equivalence Synthesis) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <equivalence>] - [[(<tag> reference') (<tag> sample')] - (\ <equivalence> = reference' sample')]) - ([#Primitive ..primitive_equivalence] - [#Structure (analysis.composite_equivalence =)] - [#Reference reference.equivalence] - [#Control (control_equivalence =)] - [#Extension (extension.equivalence =)]) - - _ - false))) - -(def: #export path_equivalence - (Equivalence Path) - (path'_equivalence equivalence)) - -(implementation: #export hash - (Hash Synthesis) - - (def: &equivalence ..equivalence) - - (def: (hash value) - (let [recur_hash [..equivalence hash]] - (case value - (^template [<tag> <hash>] - [(<tag> value) - (\ <hash> hash value)]) - ([#Primitive ..primitive_hash] - [#Structure (analysis.composite_hash recur_hash)] - [#Reference reference.hash] - [#Control (..control_hash recur_hash)] - [#Extension (extension.hash recur_hash)]))))) - -(template: #export (!bind_top register thenP) - ($_ ..path/seq - (#..Bind register) - #..Pop - thenP)) - -(template: #export (!multi_pop nextP) - ($_ ..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. -(template [<name> <side>] - [(template: #export (<name> idx nextP) - ($_ ..path/seq - (<side> idx) - #..Pop - nextP))] - - [simple_left_side ..side/left] - [simple_right_side ..side/right] - ) diff --git a/stdlib/source/lux/tool/compiler/language/lux/version.lux b/stdlib/source/lux/tool/compiler/language/lux/version.lux deleted file mode 100644 index 53b3424ae..000000000 --- a/stdlib/source/lux/tool/compiler/language/lux/version.lux +++ /dev/null @@ -1,8 +0,0 @@ -(.module: - [lux #*] - [//// - [version (#+ Version)]]) - -(def: #export version - Version - 00,06,00) diff --git a/stdlib/source/lux/tool/compiler/meta.lux b/stdlib/source/lux/tool/compiler/meta.lux deleted file mode 100644 index df3eb31a7..000000000 --- a/stdlib/source/lux/tool/compiler/meta.lux +++ /dev/null @@ -1,8 +0,0 @@ -(.module: - [lux #*] - [// - [version (#+ Version)]]) - -(def: #export version - Version - 00,01,00) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux deleted file mode 100644 index 09b501ef3..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ /dev/null @@ -1,279 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - ["." equivalence (#+ Equivalence)] - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["." function] - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - [binary (#+ Binary)] - ["." product] - ["." name] - ["." text - ["%" format (#+ format)]] - [format - ["." binary (#+ Writer)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)] - ["." set] - ["." row (#+ Row)]]] - [math - [number - ["n" nat ("#\." equivalence)]]] - [type - abstract]] - [/ - ["." artifact] - ["." signature (#+ Signature)] - ["." key (#+ Key)] - ["." descriptor (#+ Module Descriptor)] - ["." document (#+ Document)] - [/// - [version (#+ Version)]]]) - -(type: #export Output - (Row [artifact.ID Binary])) - -(exception: #export (unknown_document {module Module} - {known_modules (List Module)}) - (exception.report - ["Module" (%.text module)] - ["Known Modules" (exception.enumerate %.text known_modules)])) - -(exception: #export (cannot_replace_document {module 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))])) - -(exception: #export (module_has_already_been_reserved {module Module}) - (exception.report - ["Module" (%.text module)])) - -(exception: #export (module_must_be_reserved_before_it_can_be_added {module Module}) - (exception.report - ["Module" (%.text module)])) - -(exception: #export (module_is_only_reserved {module Module}) - (exception.report - ["Module" (%.text module)])) - -(type: #export ID - Nat) - -(def: #export runtime_module - Module - "") - -(abstract: #export Archive - {#next ID - #resolver (Dictionary Module [ID (Maybe [Descriptor (Document Any) Output])])} - - (def: next - (-> Archive ID) - (|>> :representation (get@ #next))) - - (def: #export empty - Archive - (:abstraction {#next 0 - #resolver (dictionary.new text.hash)})) - - (def: #export (id module archive) - (-> Module Archive (Try ID)) - (let [(^slots [#..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some [id _]) - (#try.Success id) - - #.None - (exception.throw ..unknown_document [module - (dictionary.keys resolver)])))) - - (def: #export (reserve module archive) - (-> Module Archive (Try [ID Archive])) - (let [(^slots [#..next #..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some _) - (exception.throw ..module_has_already_been_reserved [module]) - - #.None - (#try.Success [next - (|> archive - :representation - (update@ #..resolver (dictionary.put module [next #.None])) - (update@ #..next inc) - :abstraction)])))) - - (def: #export (add module [descriptor document output] archive) - (-> Module [Descriptor (Document Any) Output] Archive (Try Archive)) - (let [(^slots [#..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some [id #.None]) - (#try.Success (|> archive - :representation - (update@ #..resolver (dictionary.put module [id (#.Some [descriptor document output])])) - :abstraction)) - - (#.Some [id (#.Some [existing_descriptor existing_document existing_output])]) - (if (is? document existing_document) - ## TODO: Find out why this code allows for the same module to be added more than once. It looks fishy... - (#try.Success archive) - (exception.throw ..cannot_replace_document [module existing_document document])) - - #.None - (exception.throw ..module_must_be_reserved_before_it_can_be_added [module])))) - - (def: #export (find module archive) - (-> Module Archive (Try [Descriptor (Document Any) Output])) - (let [(^slots [#..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some [id (#.Some entry)]) - (#try.Success entry) - - (#.Some [id #.None]) - (exception.throw ..module_is_only_reserved [module]) - - #.None - (exception.throw ..unknown_document [module - (dictionary.keys resolver)])))) - - (def: #export (archived? archive module) - (-> Archive Module Bit) - (case (..find module archive) - (#try.Success _) - yes - - (#try.Failure _) - no)) - - (def: #export archived - (-> Archive (List Module)) - (|>> :representation - (get@ #resolver) - dictionary.entries - (list.all (function (_ [module [id descriptor+document]]) - (case descriptor+document - (#.Some _) (#.Some module) - #.None #.None))))) - - (def: #export (reserved? archive module) - (-> Archive Module Bit) - (let [(^slots [#..resolver]) (:representation archive)] - (case (dictionary.get module resolver) - (#.Some [id _]) - yes - - #.None - no))) - - (def: #export reserved - (-> Archive (List Module)) - (|>> :representation - (get@ #resolver) - dictionary.keys)) - - (def: #export reservations - (-> Archive (List [Module ID])) - (|>> :representation - (get@ #resolver) - dictionary.entries - (list\map (function (_ [module [id _]]) - [module id])))) - - (def: #export (merge additions archive) - (-> Archive Archive Archive) - (let [[+next +resolver] (:representation additions)] - (|> archive - :representation - (update@ #next (n.max +next)) - (update@ #resolver (function (_ resolver) - (list\fold (function (_ [module [id entry]] resolver) - (case entry - (#.Some _) - (dictionary.put module [id entry] resolver) - - #.None - resolver)) - resolver - (dictionary.entries +resolver)))) - :abstraction))) - - (type: Reservation [Module ID]) - (type: Frozen [Version ID (List Reservation)]) - - (def: reader - (Parser ..Frozen) - ($_ <>.and - <b>.nat - <b>.nat - (<b>.list (<>.and <b>.text <b>.nat)))) - - (def: writer - (Writer ..Frozen) - ($_ binary.and - binary.nat - binary.nat - (binary.list (binary.and binary.text binary.nat)))) - - (def: #export (export version archive) - (-> Version Archive Binary) - (let [(^slots [#..next #..resolver]) (:representation archive)] - (|> resolver - dictionary.entries - (list.all (function (_ [module [id descriptor+document]]) - (case descriptor+document - (#.Some _) (#.Some [module id]) - #.None #.None))) - [version next] - (binary.run ..writer)))) - - (exception: #export (version_mismatch {expected Version} {actual Version}) - (exception.report - ["Expected" (%.nat expected)] - ["Actual" (%.nat actual)])) - - (exception: #export corrupt_data) - - (def: (correct_modules? reservations) - (-> (List Reservation) Bit) - (n.= (list.size reservations) - (|> reservations - (list\map product.left) - (set.from_list text.hash) - set.size))) - - (def: (correct_ids? reservations) - (-> (List Reservation) Bit) - (n.= (list.size reservations) - (|> reservations - (list\map product.right) - (set.from_list n.hash) - set.size))) - - (def: (correct_reservations? reservations) - (-> (List Reservation) Bit) - (and (correct_modules? reservations) - (correct_ids? reservations))) - - (def: #export (import expected binary) - (-> Version Binary (Try Archive)) - (do try.monad - [[actual next reservations] (<b>.run ..reader binary) - _ (exception.assert ..version_mismatch [expected actual] - (n\= expected actual)) - _ (exception.assert ..corrupt_data [] - (correct_reservations? reservations))] - (wrap (:abstraction - {#next next - #resolver (list\fold (function (_ [module id] archive) - (dictionary.put module [id #.None] archive)) - (get@ #resolver (:representation ..empty)) - reservations)})))) - ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux deleted file mode 100644 index 5592df470..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/artifact.lux +++ /dev/null @@ -1,154 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - [pipe (#+ case>)] - ["." exception (#+ exception:)] - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]] - [collection - ["." list] - ["." row (#+ Row) ("#\." functor fold)] - ["." dictionary (#+ Dictionary)]] - [format - ["." binary (#+ Writer)]]] - [type - abstract]]) - -(type: #export ID - Nat) - -(type: #export Category - #Anonymous - (#Definition Text) - (#Analyser Text) - (#Synthesizer Text) - (#Generator Text) - (#Directive Text)) - -(type: #export Artifact - {#id ID - #category Category}) - -(abstract: #export Registry - {#artifacts (Row Artifact) - #resolver (Dictionary Text ID)} - - (def: #export empty - Registry - (:abstraction {#artifacts row.empty - #resolver (dictionary.new text.hash)})) - - (def: #export artifacts - (-> Registry (Row Artifact)) - (|>> :representation (get@ #artifacts))) - - (def: next - (-> Registry ID) - (|>> ..artifacts row.size)) - - (def: #export (resource registry) - (-> Registry [ID Registry]) - (let [id (..next registry)] - [id - (|> registry - :representation - (update@ #artifacts (row.add {#id id - #category #Anonymous})) - :abstraction)])) - - (template [<tag> <create> <fetch>] - [(def: #export (<create> name registry) - (-> Text Registry [ID Registry]) - (let [id (..next registry)] - [id - (|> registry - :representation - (update@ #artifacts (row.add {#id id - #category (<tag> name)})) - (update@ #resolver (dictionary.put name id)) - :abstraction)])) - - (def: #export (<fetch> registry) - (-> Registry (List Text)) - (|> registry - :representation - (get@ #artifacts) - row.to_list - (list.all (|>> (get@ #category) - (case> (<tag> name) (#.Some name) - _ #.None)))))] - - [#Definition definition definitions] - [#Analyser analyser analysers] - [#Synthesizer synthesizer synthesizers] - [#Generator generator generators] - [#Directive directive directives] - ) - - (def: #export (remember name registry) - (-> Text Registry (Maybe ID)) - (|> (:representation registry) - (get@ #resolver) - (dictionary.get name))) - - (def: #export writer - (Writer Registry) - (let [category (: (Writer Category) - (function (_ value) - (case value - (^template [<nat> <tag> <writer>] - [(<tag> value) ((binary.and binary.nat <writer>) [<nat> value])]) - ([0 #Anonymous binary.any] - [1 #Definition binary.text] - [2 #Analyser binary.text] - [3 #Synthesizer binary.text] - [4 #Generator binary.text] - [5 #Directive binary.text])))) - artifacts (: (Writer (Row Category)) - (binary.row/64 category))] - (|>> :representation - (get@ #artifacts) - (row\map (get@ #category)) - artifacts))) - - (exception: #export (invalid_category {tag Nat}) - (exception.report - ["Tag" (%.nat tag)])) - - (def: #export parser - (Parser Registry) - (let [category (: (Parser Category) - (do {! <>.monad} - [tag <b>.nat] - (case tag - 0 (\ ! map (|>> #Anonymous) <b>.any) - 1 (\ ! map (|>> #Definition) <b>.text) - 2 (\ ! map (|>> #Analyser) <b>.text) - 3 (\ ! map (|>> #Synthesizer) <b>.text) - 4 (\ ! map (|>> #Generator) <b>.text) - 5 (\ ! map (|>> #Directive) <b>.text) - _ (<>.fail (exception.construct ..invalid_category [tag])))))] - (|> (<b>.row/64 category) - (\ <>.monad map (row\fold (function (_ artifact registry) - (product.right - (case artifact - #Anonymous - (..resource registry) - - (^template [<tag> <create>] - [(<tag> name) - (<create> name registry)]) - ([#Definition ..definition] - [#Analyser ..analyser] - [#Synthesizer ..synthesizer] - [#Generator ..generator] - [#Directive ..directive]) - ))) - ..empty))))) - ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux deleted file mode 100644 index a31f6e793..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux +++ /dev/null @@ -1,48 +0,0 @@ -(.module: - [lux (#- Module) - [control - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - ["." text] - [collection - [set (#+ Set)]] - [format - ["." binary (#+ Writer)]]] - [world - [file (#+ Path)]]] - [// - ["." artifact (#+ Registry)]]) - -(type: #export Module - Text) - -(type: #export Descriptor - {#name Module - #file Path - #hash Nat - #state Module_State - #references (Set Module) - #registry Registry}) - -(def: #export writer - (Writer Descriptor) - ($_ binary.and - binary.text - binary.text - binary.nat - binary.any - (binary.set binary.text) - artifact.writer - )) - -(def: #export parser - (Parser Descriptor) - ($_ <>.and - <b>.text - <b>.text - <b>.nat - (\ <>.monad wrap #.Cached) - (<b>.set text.hash <b>.text) - artifact.parser - )) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/lux/tool/compiler/meta/archive/document.lux deleted file mode 100644 index b60d77246..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/document.lux +++ /dev/null @@ -1,71 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - [monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - ["<>" parser - [binary (#+ Parser)]]] - [data - [collection - ["." dictionary (#+ Dictionary)]] - [format - ["." binary (#+ Writer)]]] - [type (#+ :share) - abstract]] - [// - ["." signature (#+ Signature)] - ["." key (#+ Key)] - [descriptor (#+ Module)]]) - -(exception: #export (invalid-signature {expected Signature} {actual Signature}) - (exception.report - ["Expected" (signature.description expected)] - ["Actual" (signature.description actual)])) - -(abstract: #export (Document d) - {#signature Signature - #content d} - - (def: #export (read key document) - (All [d] (-> (Key d) (Document Any) (Try d))) - (let [[document//signature document//content] (:representation document)] - (if (\ signature.equivalence = - (key.signature key) - document//signature) - (#try.Success (:share [e] - (Key e) - key - - e - (:assume document//content))) - (exception.throw ..invalid-signature [(key.signature key) - document//signature])))) - - (def: #export (write key content) - (All [d] (-> (Key d) d (Document d))) - (:abstraction {#signature (key.signature key) - #content content})) - - (def: #export (check key document) - (All [d] (-> (Key d) (Document Any) (Try (Document d)))) - (do try.monad - [_ (..read key document)] - (wrap (:assume document)))) - - (def: #export signature - (-> (Document Any) Signature) - (|>> :representation (get@ #signature))) - - (def: #export (writer content) - (All [d] (-> (Writer d) (Writer (Document d)))) - (let [writer (binary.and signature.writer - content)] - (|>> :representation writer))) - - (def: #export parser - (All [d] (-> (Parser d) (Parser (Document d)))) - (|>> (<>.and signature.parser) - (\ <>.monad map (|>> :abstraction)))) - ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/key.lux b/stdlib/source/lux/tool/compiler/meta/archive/key.lux deleted file mode 100644 index 1f30e105b..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/key.lux +++ /dev/null @@ -1,18 +0,0 @@ -(.module: - [lux #* - [type - abstract]] - [// - [signature (#+ Signature)]]) - -(abstract: #export (Key k) - Signature - - (def: #export signature - (-> (Key Any) Signature) - (|>> :representation)) - - (def: #export (key signature sample) - (All [d] (-> Signature d (Key d))) - (:abstraction signature)) - ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux deleted file mode 100644 index 8956f99ec..000000000 --- a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)]] - [control - ["<>" parser - ["<b>" binary (#+ Parser)]]] - [data - ["." product] - ["." name] - ["." text - ["%" format (#+ format)]] - [format - ["." binary (#+ Writer)]]] - [math - [number - ["." nat]]]] - [//// - [version (#+ Version)]]) - -(type: #export Signature - {#name Name - #version Version}) - -(def: #export equivalence - (Equivalence Signature) - (product.equivalence name.equivalence nat.equivalence)) - -(def: #export (description signature) - (-> Signature Text) - (format (%.name (get@ #name signature)) " " (%.nat (get@ #version signature)))) - -(def: #export writer - (Writer Signature) - (binary.and (binary.and binary.text binary.text) - binary.nat)) - -(def: #export parser - (Parser Signature) - (<>.and (<>.and <b>.text <b>.text) - <b>.nat)) diff --git a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux deleted file mode 100644 index 2a9389235..000000000 --- a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux +++ /dev/null @@ -1,96 +0,0 @@ -(.module: - [lux (#- Module) - [abstract - ["." monad (#+ do)]] - [control - ["." try (#+ Try)] - ["." state] - ["." function - ["." memo (#+ Memo)]]] - [data - ["." maybe ("#\." functor)] - ["." text - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)] - ["." set (#+ Set)]]]] - [/// - ["." archive (#+ Output Archive) - [key (#+ Key)] - ["." descriptor (#+ Module Descriptor)] - ["." document (#+ Document)]]]) - -(type: Ancestry - (Set Module)) - -(def: fresh - Ancestry - (set.new text.hash)) - -(type: #export Graph - (Dictionary Module Ancestry)) - -(def: empty - Graph - (dictionary.new text.hash)) - -(def: #export modules - (-> Graph (List Module)) - dictionary.keys) - -(type: Dependency - {#module Module - #imports Ancestry}) - -(def: #export graph - (-> (List Dependency) Graph) - (list\fold (function (_ [module imports] graph) - (dictionary.put module imports graph)) - ..empty)) - -(def: (ancestry archive) - (-> Archive Graph) - (let [memo (: (Memo Module Ancestry) - (function (_ recur module) - (do {! state.monad} - [#let [parents (case (archive.find module archive) - (#try.Success [descriptor document]) - (get@ #descriptor.references descriptor) - - (#try.Failure error) - ..fresh)] - ancestors (monad.map ! recur (set.to_list parents))] - (wrap (list\fold set.union parents ancestors))))) - ancestry (memo.open memo)] - (list\fold (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 Module Module Bit) - (let [target_ancestry (|> ancestry - (dictionary.get target) - (maybe.default ..fresh))] - (set.member? target_ancestry source))) - -(type: #export Order - (List [Module [archive.ID [Descriptor (Document .Module) Output]]])) - -(def: #export (load_order key archive) - (-> (Key .Module) Archive (Try Order)) - (let [ancestry (..ancestry archive)] - (|> ancestry - dictionary.keys - (list.sort (..dependency? ancestry)) - (monad.map try.monad - (function (_ module) - (do try.monad - [module_id (archive.id module archive) - [descriptor document output] (archive.find module archive) - document (document.check key document)] - (wrap [module [module_id [descriptor document output]]]))))))) diff --git a/stdlib/source/lux/tool/compiler/meta/io.lux b/stdlib/source/lux/tool/compiler/meta/io.lux deleted file mode 100644 index 6bafa0a79..000000000 --- a/stdlib/source/lux/tool/compiler/meta/io.lux +++ /dev/null @@ -1,19 +0,0 @@ -(.module: - [lux (#- Code) - [data - ["." text]] - [world - [file (#+ Path System)]]]) - -(type: #export Context - Path) - -(type: #export Code - Text) - -(def: #export (sanitize system) - (All [m] (-> (System m) Text Text)) - (text.replace_all "/" (\ system separator))) - -(def: #export lux_context - "lux") diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux deleted file mode 100644 index 1ff603267..000000000 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ /dev/null @@ -1,449 +0,0 @@ -(.module: - [lux (#- Module) - [target (#+ Target)] - [abstract - [predicate (#+ Predicate)] - ["." monad (#+ do)]] - [control - [pipe (#+ case>)] - ["." try (#+ Try)] - ["." exception (#+ exception:)] - [concurrency - ["." promise (#+ Promise) ("#\." monad)]] - ["<>" parser - ["<.>" binary (#+ Parser)]]] - [data - [binary (#+ Binary)] - ["." product] - ["." text ("#\." equivalence) - ["%" format (#+ format)]] - [collection - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)] - ["." row (#+ Row)] - ["." set]]] - [math - [number - ["n" nat]]] - [world - ["." file]]] - [program - [compositor - [import (#+ Import)] - ["." static (#+ Static)]]] - ["." // (#+ Context) - ["#." context] - ["/#" // - ["." archive (#+ Output Archive) - ["." artifact (#+ Artifact)] - ["." descriptor (#+ Module Descriptor)] - ["." document (#+ Document)]] - [cache - ["." dependency]] - ["/#" // (#+ Input) - [language - ["$" lux - ["." version] - ["." analysis] - ["." synthesis] - ["." generation] - ["." directive] - ["#/." program]]]]]]) - -(exception: #export (cannot_prepare {archive file.Path} - {module_id archive.ID} - {error Text}) - (exception.report - ["Archive" archive] - ["Module ID" (%.nat module_id)] - ["Error" error])) - -(def: (archive fs static) - (All [!] (-> (file.System !) Static file.Path)) - (format (get@ #static.target static) - (\ fs separator) - (get@ #static.host static))) - -(def: (unversioned_lux_archive fs static) - (All [!] (-> (file.System !) Static file.Path)) - (format (..archive fs static) - (\ fs separator) - //.lux_context)) - -(def: (versioned_lux_archive fs static) - (All [!] (-> (file.System !) Static file.Path)) - (format (..unversioned_lux_archive fs static) - (\ fs separator) - (%.nat version.version))) - -(def: (module fs static module_id) - (All [!] (-> (file.System !) Static archive.ID file.Path)) - (format (..versioned_lux_archive fs static) - (\ fs separator) - (%.nat module_id))) - -(def: #export (artifact fs static module_id artifact_id) - (All [!] (-> (file.System !) Static archive.ID artifact.ID file.Path)) - (format (..module fs static module_id) - (\ fs separator) - (%.nat artifact_id) - (get@ #static.artifact_extension static))) - -(def: (ensure_directory fs path) - (-> (file.System Promise) file.Path (Promise (Try Any))) - (do promise.monad - [? (\ fs directory? path)] - (if ? - (wrap (#try.Success [])) - (\ fs make_directory path)))) - -(def: #export (prepare fs static module_id) - (-> (file.System Promise) Static archive.ID (Promise (Try Any))) - (do {! promise.monad} - [#let [module (..module fs static module_id)] - module_exists? (\ fs directory? module)] - (if module_exists? - (wrap (#try.Success [])) - (do (try.with !) - [_ (ensure_directory fs (..unversioned_lux_archive fs static)) - _ (ensure_directory fs (..versioned_lux_archive fs static))] - (|> module - (\ fs make_directory) - (\ ! map (|>> (case> (#try.Success output) - (#try.Success []) - - (#try.Failure error) - (exception.throw ..cannot_prepare [(..archive fs static) - module_id - error]))))))))) - -(def: #export (write fs static module_id artifact_id content) - (-> (file.System Promise) Static archive.ID artifact.ID Binary (Promise (Try Any))) - (\ fs write content (..artifact fs static module_id artifact_id))) - -(def: #export (enable fs static) - (-> (file.System Promise) Static (Promise (Try Any))) - (do (try.with promise.monad) - [_ (..ensure_directory fs (get@ #static.target static))] - (..ensure_directory fs (..archive fs static)))) - -(def: (general_descriptor fs static) - (-> (file.System Promise) Static file.Path) - (format (..archive fs static) - (\ fs separator) - "general_descriptor")) - -(def: #export (freeze fs static archive) - (-> (file.System Promise) Static Archive (Promise (Try Any))) - (\ fs write (archive.export ///.version archive) (..general_descriptor fs static))) - -(def: module_descriptor_file - "module_descriptor") - -(def: (module_descriptor fs static module_id) - (-> (file.System Promise) Static archive.ID file.Path) - (format (..module fs static module_id) - (\ fs separator) - ..module_descriptor_file)) - -(def: #export (cache fs static module_id content) - (-> (file.System Promise) Static archive.ID Binary (Promise (Try Any))) - (\ fs write content (..module_descriptor fs static module_id))) - -(def: (read_module_descriptor fs static module_id) - (-> (file.System Promise) Static archive.ID (Promise (Try Binary))) - (\ fs read (..module_descriptor fs static module_id))) - -(def: parser - (Parser [Descriptor (Document .Module)]) - (<>.and descriptor.parser - (document.parser $.parser))) - -(def: (fresh_analysis_state host) - (-> Target .Lux) - (analysis.state (analysis.info version.version host))) - -(def: (analysis_state host archive) - (-> Target Archive (Try .Lux)) - (do {! try.monad} - [modules (: (Try (List [Module .Module])) - (monad.map ! (function (_ module) - (do ! - [[descriptor document output] (archive.find module archive) - content (document.read $.key document)] - (wrap [module content]))) - (archive.archived archive)))] - (wrap (set@ #.modules modules (fresh_analysis_state host))))) - -(def: (cached_artifacts fs static module_id) - (-> (file.System Promise) Static archive.ID (Promise (Try (Dictionary Text Binary)))) - (let [! (try.with promise.monad)] - (|> (..module fs static module_id) - (\ fs directory_files) - (\ ! map (|>> (list\map (function (_ file) - [(file.name fs file) file])) - (list.filter (|>> product.left (text\= ..module_descriptor_file) not)) - (monad.map ! (function (_ [name path]) - (|> path - (\ fs read) - (\ ! map (|>> [name]))))) - (\ ! map (dictionary.from_list text.hash)))) - (\ ! join)))) - -(type: Definitions (Dictionary Text Any)) -(type: Analysers (Dictionary Text analysis.Handler)) -(type: Synthesizers (Dictionary Text synthesis.Handler)) -(type: Generators (Dictionary Text generation.Handler)) -(type: Directives (Dictionary Text directive.Handler)) - -(type: Bundles - [Analysers - Synthesizers - Generators - Directives]) - -(def: empty_bundles - Bundles - [(dictionary.new text.hash) - (dictionary.new text.hash) - (dictionary.new text.hash) - (dictionary.new text.hash)]) - -(def: (loaded_document extension host module_id expected actual document) - (All [expression directive] - (-> Text (generation.Host expression directive) archive.ID (Row Artifact) (Dictionary Text Binary) (Document .Module) - (Try [(Document .Module) Bundles]))) - (do {! try.monad} - [[definitions bundles] (: (Try [Definitions Bundles]) - (loop [input (row.to_list expected) - definitions (: Definitions - (dictionary.new text.hash)) - bundles ..empty_bundles] - (let [[analysers synthesizers generators directives] bundles] - (case input - (#.Cons [[artifact_id artifact_category] input']) - (case (do ! - [data (try.from_maybe (dictionary.get (format (%.nat artifact_id) extension) actual)) - #let [context [module_id artifact_id] - directive (\ host ingest context data)]] - (case artifact_category - #artifact.Anonymous - (do ! - [_ (\ host re_learn context directive)] - (wrap [definitions - [analysers - synthesizers - generators - directives]])) - - (#artifact.Definition name) - (if (text\= $/program.name name) - (wrap [definitions - [analysers - synthesizers - generators - directives]]) - (do ! - [value (\ host re_load context directive)] - (wrap [(dictionary.put name value definitions) - [analysers - synthesizers - generators - directives]]))) - - (#artifact.Analyser extension) - (do ! - [value (\ host re_load context directive)] - (wrap [definitions - [(dictionary.put extension (:as analysis.Handler value) analysers) - synthesizers - generators - directives]])) - - (#artifact.Synthesizer extension) - (do ! - [value (\ host re_load context directive)] - (wrap [definitions - [analysers - (dictionary.put extension (:as synthesis.Handler value) synthesizers) - generators - directives]])) - - (#artifact.Generator extension) - (do ! - [value (\ host re_load context directive)] - (wrap [definitions - [analysers - synthesizers - (dictionary.put extension (:as generation.Handler value) generators) - directives]])) - - (#artifact.Directive extension) - (do ! - [value (\ host re_load context directive)] - (wrap [definitions - [analysers - synthesizers - generators - (dictionary.put extension (:as directive.Handler value) directives)]])))) - (#try.Success [definitions' bundles']) - (recur input' definitions' bundles') - - failure - failure) - - #.None - (#try.Success [definitions bundles]))))) - content (document.read $.key document) - definitions (monad.map ! (function (_ [def_name def_global]) - (case def_global - (#.Alias alias) - (wrap [def_name (#.Alias alias)]) - - (#.Definition [exported? type annotations _]) - (do ! - [value (try.from_maybe (dictionary.get def_name definitions))] - (wrap [def_name (#.Definition [exported? type annotations value])])))) - (get@ #.definitions content))] - (wrap [(document.write $.key (set@ #.definitions definitions content)) - bundles]))) - -(def: (load_definitions fs static module_id host_environment [descriptor document output]) - (All [expression directive] - (-> (file.System Promise) Static archive.ID (generation.Host expression directive) - [Descriptor (Document .Module) Output] - (Promise (Try [[Descriptor (Document .Module) Output] - Bundles])))) - (do (try.with promise.monad) - [actual (cached_artifacts fs static module_id) - #let [expected (|> descriptor (get@ #descriptor.registry) artifact.artifacts)] - [document bundles] (promise\wrap (loaded_document (get@ #static.artifact_extension static) host_environment module_id expected actual document))] - (wrap [[descriptor document output] bundles]))) - -(def: (purge! fs static [module_name module_id]) - (-> (file.System Promise) Static [Module archive.ID] (Promise (Try Any))) - (do {! (try.with promise.monad)} - [#let [cache (..module fs static module_id)] - _ (|> cache - (\ fs directory_files) - (\ ! map (monad.map ! (\ fs delete))) - (\ ! join))] - (\ fs delete cache))) - -(def: (valid_cache? expected actual) - (-> Descriptor Input Bit) - (and (text\= (get@ #descriptor.name expected) - (get@ #////.module actual)) - (text\= (get@ #descriptor.file expected) - (get@ #////.file actual)) - (n.= (get@ #descriptor.hash expected) - (get@ #////.hash actual)))) - -(type: Purge - (Dictionary Module archive.ID)) - -(def: initial_purge - (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]]) - Purge) - (|>> (list.all (function (_ [valid_cache? [module_name [module_id _]]]) - (if valid_cache? - #.None - (#.Some [module_name module_id])))) - (dictionary.from_list text.hash))) - -(def: (full_purge caches load_order) - (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]]) - dependency.Order - Purge) - (list\fold (function (_ [module_name [module_id [descriptor document output]]] purge) - (let [purged? (: (Predicate Module) - (dictionary.key? purge))] - (if (purged? module_name) - purge - (if (|> descriptor - (get@ #descriptor.references) - set.to_list - (list.any? purged?)) - (dictionary.put module_name module_id purge) - purge)))) - (..initial_purge caches) - load_order)) - -(def: pseudo_module - Text - "(Lux Caching System)") - -(def: (load_every_reserved_module host_environment fs static import contexts archive) - (All [expression directive] - (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context) Archive - (Promise (Try [Archive .Lux Bundles])))) - (do {! (try.with promise.monad)} - [pre_loaded_caches (|> archive - archive.reservations - (monad.map ! (function (_ [module_name module_id]) - (do ! - [data (..read_module_descriptor fs static module_id) - [descriptor document] (promise\wrap (<binary>.run ..parser data))] - (if (text\= archive.runtime_module module_name) - (wrap [true - [module_name [module_id [descriptor document (: Output row.empty)]]]]) - (do ! - [input (//context.read fs ..pseudo_module import contexts (get@ #static.host_module_extension static) module_name)] - (wrap [(..valid_cache? descriptor input) - [module_name [module_id [descriptor document (: Output row.empty)]]]]))))))) - load_order (|> pre_loaded_caches - (list\map product.right) - (monad.fold try.monad - (function (_ [module [module_id descriptor,document,output]] archive) - (archive.add module descriptor,document,output archive)) - archive) - (\ try.monad map (dependency.load_order $.key)) - (\ try.monad join) - promise\wrap) - #let [purge (..full_purge pre_loaded_caches load_order)] - _ (|> purge - dictionary.entries - (monad.map ! (..purge! fs static))) - loaded_caches (|> load_order - (list.filter (function (_ [module_name [module_id [descriptor document output]]]) - (not (dictionary.key? purge module_name)))) - (monad.map ! (function (_ [module_name [module_id descriptor,document,output]]) - (do ! - [[descriptor,document,output bundles] (..load_definitions fs static module_id host_environment descriptor,document,output)] - (wrap [[module_name descriptor,document,output] - bundles])))))] - (promise\wrap - (do {! try.monad} - [archive (monad.fold ! - (function (_ [[module descriptor,document] _bundle] archive) - (archive.add module descriptor,document archive)) - archive - loaded_caches) - analysis_state (..analysis_state (get@ #static.host static) archive)] - (wrap [archive - analysis_state - (list\fold (function (_ [_ [+analysers +synthesizers +generators +directives]] - [analysers synthesizers generators directives]) - [(dictionary.merge +analysers analysers) - (dictionary.merge +synthesizers synthesizers) - (dictionary.merge +generators generators) - (dictionary.merge +directives directives)]) - ..empty_bundles - loaded_caches)]))))) - -(def: #export (thaw host_environment fs static import contexts) - (All [expression directive] - (-> (generation.Host expression directive) (file.System Promise) Static Import (List Context) - (Promise (Try [Archive .Lux Bundles])))) - (do promise.monad - [binary (\ fs read (..general_descriptor fs static))] - (case binary - (#try.Success binary) - (do (try.with promise.monad) - [archive (promise\wrap (archive.import ///.version binary))] - (..load_every_reserved_module host_environment fs static import contexts archive)) - - (#try.Failure error) - (wrap (#try.Success [archive.empty - (fresh_analysis_state (get@ #static.host static)) - ..empty_bundles]))))) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux deleted file mode 100644 index f31b4e1b2..000000000 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ /dev/null @@ -1,169 +0,0 @@ -(.module: - [lux (#- Module Code) - ["@" target] - [abstract - [predicate (#+ Predicate)] - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)] - ["." exception (#+ exception:)] - [concurrency - ["." promise (#+ Promise) ("#\." monad)]]] - [data - [binary (#+ Binary)] - ["." text ("#\." hash) - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." dictionary (#+ Dictionary)]]] - [world - ["." file]]] - [program - [compositor - [import (#+ Import)]]] - ["." // (#+ Context Code) - ["/#" // #_ - [archive - [descriptor (#+ Module)]] - ["/#" // (#+ Input)]]]) - -(exception: #export (cannot_find_module {importer Module} {module Module}) - (exception.report - ["Module" (%.text module)] - ["Importer" (%.text importer)])) - -(exception: #export (cannot_read_module {module Module}) - (exception.report - ["Module" (%.text module)])) - -(type: #export Extension - Text) - -(def: lux_extension - Extension - ".lux") - -(def: #export (path fs context module) - (All [m] (-> (file.System m) Context Module file.Path)) - (|> module - (//.sanitize fs) - (format context (\ fs separator)))) - -(def: (find_source_file fs importer contexts module extension) - (-> (file.System Promise) Module (List Context) Module Extension - (Promise (Try file.Path))) - (case contexts - #.Nil - (promise\wrap (exception.throw ..cannot_find_module [importer module])) - - (#.Cons context contexts') - (let [path (format (..path fs context module) extension)] - (do promise.monad - [? (\ fs file? path)] - (if ? - (wrap (#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 Promise) Module Import (List Context) Extension Module - (Promise (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 {! promise.monad} - [outcome (..find_source_file fs importer contexts module (..full_host_extension partial_host_extension))] - (case outcome - (#try.Success path) - (|> path - (\ fs read) - (\ (try.with !) map (|>> [path]))) - - (#try.Failure _) - (do {! (try.with !)} - [path (..find_source_file fs importer contexts module ..lux_extension)] - (|> path - (\ fs read) - (\ ! map (|>> [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.get path import) - (#.Some data) - (#try.Success [path data]) - - #.None - (let [path (format module ..lux_extension)] - (case (dictionary.get path import) - (#.Some data) - (#try.Success [path data]) - - #.None - (exception.throw ..cannot_find_module [importer module])))))) - -(def: (find_any_source_file fs importer import contexts partial_host_extension module) - (-> (file.System Promise) Module Import (List Context) Extension Module - (Promise (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 {! promise.monad} - [outcome (find_local_source_file fs importer import contexts partial_host_extension module)] - (case outcome - (#try.Success [path data]) - (wrap outcome) - - (#try.Failure _) - (wrap (..find_library_source_file importer import partial_host_extension module))))) - -(def: #export (read fs importer import contexts partial_host_extension module) - (-> (file.System Promise) Module Import (List Context) Extension Module - (Promise (Try Input))) - (do (try.with promise.monad) - [[path binary] (..find_any_source_file fs importer import contexts partial_host_extension module)] - (case (\ utf8.codec decode binary) - (#try.Success code) - (wrap {#////.module module - #////.file path - #////.hash (text\hash code) - #////.code code}) - - (#try.Failure _) - (promise\wrap (exception.throw ..cannot_read_module [module]))))) - -(type: #export Enumeration - (Dictionary file.Path Binary)) - -(def: (enumerate_context fs directory enumeration) - (-> (file.System Promise) Context Enumeration (Promise (Try Enumeration))) - (do {! (try.with promise.monad)} - [enumeration (|> directory - (\ fs directory_files) - (\ ! map (monad.fold ! (function (_ file enumeration) - (if (text.ends_with? ..lux_extension file) - (do ! - [source_code (\ fs read file)] - (promise\wrap - (dictionary.try_put (file.name fs file) source_code enumeration))) - (wrap enumeration))) - enumeration)) - (\ ! join))] - (|> directory - (\ fs sub_directories) - (\ ! map (monad.fold ! (enumerate_context fs) enumeration)) - (\ ! join)))) - -(def: Action - (type (All [a] (Promise (Try a))))) - -(def: #export (enumerate fs contexts) - (-> (file.System Promise) (List Context) (Action Enumeration)) - (monad.fold (: (Monad Action) - (try.with promise.monad)) - (..enumerate_context fs) - (: Enumeration - (dictionary.new text.hash)) - contexts)) diff --git a/stdlib/source/lux/tool/compiler/meta/packager.lux b/stdlib/source/lux/tool/compiler/meta/packager.lux deleted file mode 100644 index fff07d28f..000000000 --- a/stdlib/source/lux/tool/compiler/meta/packager.lux +++ /dev/null @@ -1,42 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ Monad)]] - [control - [try (#+ Try)]] - [data - [binary (#+ Binary)] - [collection - ["." row] - ["." list ("#\." functor)]]] - [world - ["." file (#+ Path)]]] - [program - [compositor - [static (#+ Static)]]] - [// - [cache - ["." dependency]] - ["." archive (#+ Archive) - ["." descriptor] - ["." artifact]] - [// - [language - [lux - [generation (#+ Context)]]]]]) - -(type: #export Packager - (-> Archive Context (Try Binary))) - -(type: #export Order - (List [archive.ID (List artifact.ID)])) - -(def: #export order - (-> dependency.Order Order) - (list\map (function (_ [module [module_id [descriptor document]]]) - (|> descriptor - (get@ #descriptor.registry) - artifact.artifacts - row.to_list - (list\map (|>> (get@ #artifact.id))) - [module_id])))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux b/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux deleted file mode 100644 index a89bdc836..000000000 --- a/stdlib/source/lux/tool/compiler/meta/packager/jvm.lux +++ /dev/null @@ -1,144 +0,0 @@ -(.module: - [lux (#- Module Definition) - [type (#+ :share)] - ["." ffi (#+ import: do_to)] - [abstract - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)] - [concurrency - ["." promise (#+ Promise)]]] - [data - ["." binary (#+ Binary)] - ["." text - ["%" format (#+ format)]] - [collection - ["." row (#+ Row) ("#\." fold)] - ["." list ("#\." functor fold)]]] - [math - [number - ["n" nat]]] - [target - [jvm - [encoding - ["." name]]]]] - [program - [compositor - ["." static (#+ Static)]]] - ["." // (#+ Packager) - [// - ["." archive (#+ Output) - ["." descriptor (#+ Module)] - ["." artifact]] - [cache - ["." dependency]] - ["." io #_ - ["#" archive]] - [// - [language - ["$" lux - [generation (#+ Context)] - [phase - [generation - [jvm - ["." runtime (#+ Definition)]]]]]]]]]) - -(import: java/lang/Object) - -(import: java/lang/String) - -(import: java/util/jar/Attributes - ["#::." - (put [java/lang/Object java/lang/Object] #? java/lang/Object)]) - -(import: java/util/jar/Attributes$Name - ["#::." - (#static MAIN_CLASS java/util/jar/Attributes$Name) - (#static MANIFEST_VERSION java/util/jar/Attributes$Name)]) - -(import: java/util/jar/Manifest - ["#::." - (new []) - (getMainAttributes [] java/util/jar/Attributes)]) - -(import: java/io/Flushable - ["#::." - (flush [] void)]) - -(import: java/io/Closeable - ["#::." - (close [] void)]) - -(import: java/io/OutputStream) - -(import: java/io/ByteArrayOutputStream - ["#::." - (new [int]) - (toByteArray [] [byte])]) - -(import: java/util/zip/ZipEntry) - -(import: java/util/zip/ZipOutputStream - ["#::." - (write [[byte] int int] void) - (closeEntry [] void)]) - -(import: java/util/jar/JarEntry - ["#::." - (new [java/lang/String])]) - -(import: java/util/jar/JarOutputStream - ["#::." - (new [java/io/OutputStream java/util/jar/Manifest]) - (putNextEntry [java/util/zip/ZipEntry] void)]) - -(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) - (-> Context java/util/jar/Manifest) - (let [manifest (java/util/jar/Manifest::new)] - (exec (do_to (java/util/jar/Manifest::getMainAttributes manifest) - (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) (|> program runtime.class_name name.internal name.external)) - (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest_version)) - manifest))) - -(def: (write_class static module artifact content sink) - (-> Static archive.ID artifact.ID Binary java/util/jar/JarOutputStream - java/util/jar/JarOutputStream) - (let [class_path (format (runtime.class_name [module artifact]) - (get@ #static.artifact_extension static))] - (do_to sink - (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class_path)) - (java/util/zip/ZipOutputStream::write content +0 (.int (binary.size content))) - (java/io/Flushable::flush) - (java/util/zip/ZipOutputStream::closeEntry)))) - -(def: (write_module static [module output] sink) - (-> Static [archive.ID Output] java/util/jar/JarOutputStream - java/util/jar/JarOutputStream) - (row\fold (function (_ [artifact content] sink) - (..write_class static module artifact content sink)) - sink - output)) - -(def: #export (package static) - (-> Static Packager) - (function (_ archive program) - (do {! try.monad} - [order (dependency.load_order $.key archive) - #let [buffer (java/io/ByteArrayOutputStream::new (.int ..mebi_byte)) - sink (|> order - (list\map (function (_ [module [module_id [descriptor document output]]]) - [module_id output])) - (list\fold (..write_module static) - (java/util/jar/JarOutputStream::new buffer (..manifest program)))) - _ (do_to sink - (java/io/Flushable::flush) - (java/io/Closeable::close))]] - (wrap (java/io/ByteArrayOutputStream::toByteArray buffer))))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux b/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux deleted file mode 100644 index ac35684ed..000000000 --- a/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux +++ /dev/null @@ -1,131 +0,0 @@ -(.module: - [lux (#- Module) - [type (#+ :share)] - [abstract - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)]] - [data - [binary (#+ Binary)] - ["." product] - ["." text - ["%" format (#+ format)] - ["." encoding]] - [collection - ["." row] - ["." list ("#\." functor fold)] - ["." dictionary (#+ Dictionary)] - ["." set]] - [format - ["." tar] - ["." binary]]] - [target - ["_" scheme]] - [time - ["." instant (#+ Instant)]] - [world - ["." file]]] - [program - [compositor - ["." static (#+ Static)]]] - ["." // (#+ Packager) - [// - ["." archive (#+ Output) - ["." descriptor (#+ Module Descriptor)] - ["." artifact] - ["." document (#+ Document)]] - [cache - ["." dependency]] - ["." io #_ - ["#" archive]] - [// - [language - ["$" lux - [generation (#+ 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)) - (|>> row.to_list - (list\map product.right) - (monad.fold try.monad - (function (_ content so_far) - (|> content - (\ encoding.utf8 decode) - (\ try.monad map - (|>> :assume - (:share [directive] - directive - so_far - - directive) - (..then so_far))))) - (: _.Expression (_.manual ""))))) - -(def: module_file - (-> archive.ID file.Path) - (|>> %.nat (text.suffix ".scm"))) - -(def: mode - tar.Mode - ($_ 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 (: (Try _.Expression) - (..bundle_module output)) - entry_content (: (Try tar.Content) - (|> descriptor - (get@ #descriptor.references) - set.to_list - (list.all (function (_ module) (dictionary.get module mapping))) - (list\map (|>> ..module_file _.string _.load-relative/1)) - (list\fold ..then bundle) - (: _.Expression) - _.code - (\ encoding.utf8 encode) - tar.content)) - module_file (tar.path (..module_file module_id))] - (wrap (#tar.Normal [module_file now ..mode ..ownership entry_content])))) - -(def: #export (package now) - (-> Instant Packager) - (function (package archive program) - (do {! try.monad} - [order (dependency.load_order $.key archive) - #let [mapping (|> order - (list\map (function (_ [module [module_id [descriptor document output]]]) - [module module_id])) - (dictionary.from_list text.hash) - (: (Dictionary Module archive.ID)))] - entries (monad.map ! (..write_module now mapping) order)] - (wrap (|> entries - row.from_list - (binary.run tar.writer)))))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/script.lux deleted file mode 100644 index 98a011a4c..000000000 --- a/stdlib/source/lux/tool/compiler/meta/packager/script.lux +++ /dev/null @@ -1,75 +0,0 @@ -(.module: - [lux #* - [type (#+ :share)] - [abstract - ["." monad (#+ Monad do)]] - [control - ["." try (#+ Try)]] - [data - [binary (#+ Binary)] - ["." product] - [text - ["%" format (#+ format)] - [encoding - ["." utf8]]] - [collection - ["." row] - ["." list ("#\." functor)]]]] - [program - [compositor - ["." static (#+ Static)]]] - ["." // (#+ Packager) - [// - ["." archive (#+ Output) - ["." descriptor] - ["." artifact]] - [cache - ["." dependency]] - ["." io #_ - ["#" archive]] - [// - [language - ["$" lux - [generation (#+ Context)]]]]]]) - -## TODO: Delete ASAP -(type: (Action ! a) - (! (Try a))) - -(def: (write_module sequence [module output] so_far) - (All [directive] - (-> (-> directive directive directive) [archive.ID Output] directive - (Try directive))) - (|> output - row.to_list - (list\map product.right) - (monad.fold try.monad - (function (_ content so_far) - (|> content - (\ utf8.codec decode) - (\ try.monad map - (function (_ content) - (sequence so_far - (:share [directive] - directive - so_far - - directive - (:assume content))))))) - so_far))) - -(def: #export (package header to_code sequence scope) - (All [directive] - (-> directive - (-> directive Text) - (-> directive directive directive) - (-> directive directive) - Packager)) - (function (package archive program) - (do {! try.monad} - [order (dependency.load_order $.key archive)] - (|> order - (list\map (function (_ [module [module_id [descriptor document output]]]) - [module_id output])) - (monad.fold ! (..write_module sequence) header) - (\ ! map (|>> scope to_code (\ utf8.codec encode))))))) diff --git a/stdlib/source/lux/tool/compiler/phase.lux b/stdlib/source/lux/tool/compiler/phase.lux deleted file mode 100644 index 0d6543c33..000000000 --- a/stdlib/source/lux/tool/compiler/phase.lux +++ /dev/null @@ -1,118 +0,0 @@ -(.module: - [lux #* - ["." debug] - [abstract - [monad (#+ Monad do)]] - [control - ["." state] - ["." try (#+ Try) ("#\." functor)] - ["ex" exception (#+ Exception exception:)] - ["." io] - [parser - ["s" code]]] - [data - ["." product] - ["." text - ["%" format (#+ format)]]] - [time - ["." instant] - ["." duration]] - [macro - [syntax (#+ syntax:)]]] - [// - [meta - [archive (#+ Archive)]]]) - -(type: #export (Operation s o) - (state.State' Try s o)) - -(def: #export monad - (All [s] (Monad (Operation s))) - (state.with try.monad)) - -(type: #export (Phase s i o) - (-> Archive i (Operation s o))) - -(def: #export (run' state operation) - (All [s o] - (-> s (Operation s o) (Try [s o]))) - (operation state)) - -(def: #export (run state operation) - (All [s o] - (-> s (Operation s o) (Try o))) - (|> state - operation - (\ try.monad map product.right))) - -(def: #export get_state - (All [s o] - (Operation s s)) - (function (_ state) - (#try.Success [state state]))) - -(def: #export (set_state state) - (All [s o] - (-> s (Operation s Any))) - (function (_ _) - (#try.Success [state []]))) - -(def: #export (sub [get set] operation) - (All [s s' o] - (-> [(-> s s') (-> s' s s)] - (Operation s' o) - (Operation s o))) - (function (_ state) - (do try.monad - [[state' output] (operation (get state))] - (wrap [(set state' state) output])))) - -(def: #export fail - (-> Text Operation) - (|>> try.fail (state.lift try.monad))) - -(def: #export (throw exception parameters) - (All [e] (-> (Exception e) e Operation)) - (..fail (ex.construct exception parameters))) - -(def: #export (lift error) - (All [s a] (-> (Try a) (Operation s a))) - (function (_ state) - (try\map (|>> [state]) error))) - -(syntax: #export (assert exception message test) - (wrap (list (` (if (~ test) - (\ ..monad (~' wrap) []) - (..throw (~ exception) (~ message))))))) - -(def: #export identity - (All [s a] (Phase s a a)) - (function (_ archive input state) - (#try.Success [state input]))) - -(def: #export (compose pre post) - (All [s0 s1 i t o] - (-> (Phase s0 i t) - (Phase s1 t o) - (Phase [s0 s1] i o))) - (function (_ 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)] - (wrap [[pre/state' post/state'] output])))) - -(def: #export (timed definition description operation) - (All [s a] - (-> Name Text (Operation s a) (Operation s a))) - (do ..monad - [_ (wrap []) - #let [pre (io.run instant.now)] - output operation - #let [_ (|> instant.now - io.run - instant.relative - (duration.difference (instant.relative pre)) - %.duration - (format (%.name definition) " [" description "]: ") - debug.log!)]] - (wrap output))) diff --git a/stdlib/source/lux/tool/compiler/reference.lux b/stdlib/source/lux/tool/compiler/reference.lux deleted file mode 100644 index 98a1f0c07..000000000 --- a/stdlib/source/lux/tool/compiler/reference.lux +++ /dev/null @@ -1,84 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [control - [pipe (#+ case>)]] - [data - ["." name] - [text - ["%" format (#+ Format)]]] - [math - [number - ["n" nat]]]] - ["." / #_ - ["#." variable (#+ Variable)]]) - -(type: #export Constant - Name) - -(type: #export Reference - (#Variable Variable) - (#Constant Constant)) - -(implementation: #export equivalence - (Equivalence Reference) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag> <equivalence>] - [[(<tag> reference) (<tag> sample)] - (\ <equivalence> = reference sample)]) - ([#Variable /variable.equivalence] - [#Constant name.equivalence]) - - _ - false))) - -(implementation: #export hash - (Hash Reference) - - (def: &equivalence - ..equivalence) - - (def: (hash value) - (case value - (^template [<factor> <tag> <hash>] - [(<tag> value) - ($_ n.* <factor> - (\ <hash> hash value))]) - ([2 #Variable /variable.hash] - [3 #Constant name.hash]) - ))) - -(template [<name> <family> <tag>] - [(template: #export (<name> content) - (<| <family> - <tag> - content))] - - [local #..Variable #/variable.Local] - [foreign #..Variable #/variable.Foreign] - ) - -(template [<name> <tag>] - [(template: #export (<name> content) - (<| <tag> - content))] - - [variable #..Variable] - [constant #..Constant] - ) - -(def: #export self - Reference - (..local 0)) - -(def: #export format - (Format Reference) - (|>> (case> (#Variable variable) - (/variable.format variable) - - (#Constant constant) - (%.name constant)))) diff --git a/stdlib/source/lux/tool/compiler/reference/variable.lux b/stdlib/source/lux/tool/compiler/reference/variable.lux deleted file mode 100644 index 84aea58ab..000000000 --- a/stdlib/source/lux/tool/compiler/reference/variable.lux +++ /dev/null @@ -1,67 +0,0 @@ -(.module: - [lux #* - [abstract - [equivalence (#+ Equivalence)] - [hash (#+ Hash)]] - [control - [pipe (#+ case>)]] - [data - [text - ["%" format (#+ Format)]]] - [math - [number - ["n" nat] - ["i" int]]]]) - -(type: #export Register - Nat) - -(type: #export Variable - (#Local Register) - (#Foreign Register)) - -(implementation: #export equivalence - (Equivalence Variable) - - (def: (= reference sample) - (case [reference sample] - (^template [<tag>] - [[(<tag> reference') (<tag> sample')] - (n.= reference' sample')]) - ([#Local] [#Foreign]) - - _ - #0))) - -(implementation: #export hash - (Hash Variable) - - (def: &equivalence - ..equivalence) - - (def: hash - (|>> (case> (^template [<factor> <tag>] - [(<tag> register) - ($_ n.* <factor> - (\ n.hash hash register))]) - ([2 #Local] - [3 #Foreign]))))) - -(template: #export (self) - (#..Local 0)) - -(def: #export self? - (-> Variable Bit) - (|>> (case> (^ (..self)) - true - - _ - false))) - -(def: #export format - (Format Variable) - (|>> (case> (#Local local) - (%.format "+" (%.nat local)) - - (#Foreign foreign) - (%.format "-" (%.nat foreign))))) diff --git a/stdlib/source/lux/tool/compiler/version.lux b/stdlib/source/lux/tool/compiler/version.lux deleted file mode 100644 index d29428636..000000000 --- a/stdlib/source/lux/tool/compiler/version.lux +++ /dev/null @@ -1,51 +0,0 @@ -(.module: - [lux #* - [data - [text - ["%" format]]] - [math - [number - ["n" nat]]]]) - -(type: #export Version - Nat) - -(def: range 100) - -(def: level - (n.% ..range)) - -(def: current - (-> Nat Nat) - (|>>)) - -(def: next - (n./ ..range)) - -(def: #export patch - (-> Version Nat) - (|>> ..current ..level)) - -(def: #export minor - (-> Version Nat) - (|>> ..next ..level)) - -(def: #export major - (-> Version Nat) - (|>> ..next ..next ..level)) - -(def: separator ".") - -(def: (padded value) - (-> Nat Text) - (if (n.< 10 value) - (%.format "0" (%.nat value)) - (%.nat value))) - -(def: #export (format version) - (%.Format Version) - (%.format (..padded (..major version)) - ..separator - (..padded (..minor version)) - ..separator - (..padded (..patch version)))) diff --git a/stdlib/source/lux/tool/interpreter.lux b/stdlib/source/lux/tool/interpreter.lux deleted file mode 100644 index e18a27c47..000000000 --- a/stdlib/source/lux/tool/interpreter.lux +++ /dev/null @@ -1,221 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ Monad do)] - ["." try (#+ Try)] - ["ex" exception (#+ exception:)]] - [data - ["." text ("#\." equivalence) - ["%" format (#+ format)]]] - [type (#+ :share) - ["." check]] - [compiler - ["." phase - ["." analysis - ["." module] - ["." type]] - ["." generation] - ["." directive (#+ State+ Operation) - ["." total]] - ["." extension]] - ["." default - ["." syntax] - ["." platform (#+ Platform)] - ["." init]] - ["." cli (#+ Configuration)]] - [world - ["." file (#+ File)] - ["." console (#+ Console)]]] - ["." /type]) - -(exception: #export (error {message Text}) - message) - -(def: #export module "<INTERPRETER>") - -(def: fresh-source Source [[..module 1 0] 0 ""]) - -(def: (add-line line [where offset input]) - (-> Text Source Source) - [where offset (format input text.new-line line)]) - -(def: exit-command Text "exit") - -(def: welcome-message - Text - (format text.new-line - "Welcome to the interpreter!" text.new-line - "Type '" ..exit-command "' to leave." text.new-line - text.new-line)) - -(def: farewell-message - Text - "Till next time...") - -(def: enter-module - (All [anchor expression directive] - (Operation anchor expression directive Any)) - (directive.lift-analysis - (do phase.monad - [_ (module.create 0 ..module)] - (analysis.set-current-module ..module)))) - -(def: (initialize Monad<!> Console<!> platform configuration generation-bundle) - (All [! anchor expression directive] - (-> (Monad !) - (Console !) (Platform ! anchor expression directive) - Configuration - (generation.Bundle anchor expression directive) - (! (State+ anchor expression directive)))) - (do Monad<!> - [state (platform.initialize platform generation-bundle) - state (platform.compile platform - (set@ #cli.module syntax.prelude configuration) - (set@ [#extension.state - #directive.analysis #directive.state - #extension.state - #.info #.mode] - #.Interpreter - state)) - [state _] (\ (get@ #platform.file-system platform) - lift (phase.run' state enter-module)) - _ (\ Console<!> write ..welcome-message)] - (wrap state))) - -(with-expansions [<Interpretation> (as-is (Operation anchor expression directive [Type Any]))] - - (def: (interpret-directive code) - (All [anchor expression directive] - (-> Code <Interpretation>)) - (do phase.monad - [_ (total.phase code) - _ init.refresh] - (wrap [Any []]))) - - (def: (interpret-expression code) - (All [anchor expression directive] - (-> Code <Interpretation>)) - (do {! phase.monad} - [state (extension.lift phase.get-state) - #let [analyse (get@ [#directive.analysis #directive.phase] state) - synthesize (get@ [#directive.synthesis #directive.phase] state) - generate (get@ [#directive.generation #directive.phase] state)] - [_ codeT codeA] (directive.lift-analysis - (analysis.with-scope - (type.with-fresh-env - (do ! - [[codeT codeA] (type.with-inference - (analyse code)) - codeT (type.with-env - (check.clean codeT))] - (wrap [codeT codeA]))))) - codeS (directive.lift-synthesis - (synthesize codeA))] - (directive.lift-generation - (generation.with-buffer - (do ! - [codeH (generate codeS) - count generation.next - codeV (generation.evaluate! (format "interpretation_" (%.nat count)) codeH)] - (wrap [codeT codeV])))))) - - (def: (interpret configuration code) - (All [anchor expression directive] - (-> Configuration Code <Interpretation>)) - (function (_ state) - (case (<| (phase.run' state) - (:share [anchor expression directive] - {(State+ anchor expression directive) - state} - {<Interpretation> - (interpret-directive code)})) - (#try.Success [state' output]) - (#try.Success [state' output]) - - (#try.Failure error) - (if (ex.match? total.not-a-directive error) - (<| (phase.run' state) - (:share [anchor expression directive] - {(State+ anchor expression directive) - state} - {<Interpretation> - (interpret-expression code)})) - (#try.Failure error))))) - ) - -(def: (execute configuration code) - (All [anchor expression directive] - (-> Configuration Code (Operation anchor expression directive Text))) - (do phase.monad - [[codeT codeV] (interpret configuration code) - state phase.get-state] - (wrap (/type.represent (get@ [#extension.state - #directive.analysis #directive.state - #extension.state] - state) - codeT - codeV)))) - -(type: (Context anchor expression directive) - {#configuration Configuration - #state (State+ anchor expression directive) - #source Source}) - -(with-expansions [<Context> (as-is (Context anchor expression directive))] - (def: (read-eval-print context) - (All [anchor expression directive] - (-> <Context> (Try [<Context> Text]))) - (do try.monad - [#let [[_where _offset _code] (get@ #source context)] - [source' input] (syntax.parse ..module syntax.no-aliases (text.size _code) (get@ #source context)) - [state' representation] (let [## TODO: Simplify ASAP - state (:share [anchor expression directive] - {<Context> - context} - {(State+ anchor expression directive) - (get@ #state context)})] - (<| (phase.run' state) - ## TODO: Simplify ASAP - (:share [anchor expression directive] - {<Context> - context} - {(Operation anchor expression directive Text) - (execute (get@ #configuration context) input)})))] - (wrap [(|> context - (set@ #state state') - (set@ #source source')) - representation])))) - -(def: #export (run Monad<!> Console<!> platform configuration generation-bundle) - (All [! anchor expression directive] - (-> (Monad !) - (Console !) (Platform ! anchor expression directive) - Configuration - (generation.Bundle anchor expression directive) - (! Any))) - (do {! Monad<!>} - [state (initialize Monad<!> Console<!> platform configuration)] - (loop [context {#configuration configuration - #state state - #source ..fresh-source} - multi-line? #0] - (do ! - [_ (if multi-line? - (\ Console<!> write " ") - (\ Console<!> write "> ")) - line (\ Console<!> read-line)] - (if (and (not multi-line?) - (text\= ..exit-command line)) - (\ Console<!> write ..farewell-message) - (case (read-eval-print (update@ #source (add-line line) context)) - (#try.Success [context' representation]) - (do ! - [_ (\ Console<!> write representation)] - (recur context' #0)) - - (#try.Failure error) - (if (ex.match? syntax.end-of-file error) - (recur context #1) - (exec (log! (ex.construct ..error error)) - (recur (set@ #source ..fresh-source context) #0)))))) - ))) diff --git a/stdlib/source/lux/tool/mediator.lux b/stdlib/source/lux/tool/mediator.lux deleted file mode 100644 index 5beb217e0..000000000 --- a/stdlib/source/lux/tool/mediator.lux +++ /dev/null @@ -1,18 +0,0 @@ -(.module: - [lux (#- Source Module) - [world - ["." binary (#+ Binary)] - ["." file (#+ File)]]] - [// - [compiler (#+ Compiler) - [meta - ["." archive (#+ Archive) - [descriptor (#+ Module)]]]]]) - -(type: #export Source File) - -(type: #export (Mediator !) - (-> Archive Module (! Archive))) - -(type: #export (Instancer ! d o) - (-> (file.System !) (List Source) (Compiler d o) (Mediator !))) |