diff options
Diffstat (limited to '')
195 files changed, 31720 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/tool/compiler.lux b/stdlib/source/library/lux/tool/compiler.lux new file mode 100644 index 000000000..1acd9aeea --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler.lux @@ -0,0 +1,47 @@ +(.module: + [library + [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/library/lux/tool/compiler/arity.lux b/stdlib/source/library/lux/tool/compiler/arity.lux new file mode 100644 index 000000000..61e0ea625 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/arity.lux @@ -0,0 +1,16 @@ +(.module: + [library + [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/library/lux/tool/compiler/default/init.lux b/stdlib/source/library/lux/tool/compiler/default/init.lux new file mode 100644 index 000000000..172de25e7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/default/init.lux @@ -0,0 +1,287 @@ +(.module: + [library + [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/library/lux/tool/compiler/default/platform.lux b/stdlib/source/library/lux/tool/compiler/default/platform.lux new file mode 100644 index 000000000..9ebf79b7b --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/default/platform.lux @@ -0,0 +1,602 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux.lux new file mode 100644 index 000000000..e6d5816a4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux.lux @@ -0,0 +1,107 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux new file mode 100644 index 000000000..c29eaaf54 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis.lux @@ -0,0 +1,556 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux new file mode 100644 index 000000000..0895955dc --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/evaluation.lux @@ -0,0 +1,57 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/analysis/macro.lux b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/macro.lux new file mode 100644 index 000000000..d0957820c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/analysis/macro.lux @@ -0,0 +1,52 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux new file mode 100644 index 000000000..49ab15299 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux @@ -0,0 +1,83 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/generation.lux new file mode 100644 index 000000000..13d36021f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/generation.lux @@ -0,0 +1,336 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux new file mode 100644 index 000000000..c35404a68 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis.lux @@ -0,0 +1,144 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux new file mode 100644 index 000000000..d447b8d1d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case.lux @@ -0,0 +1,325 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux new file mode 100644 index 000000000..df92858ec --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/case/coverage.lux @@ -0,0 +1,373 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux new file mode 100644 index 000000000..5e41e907e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/function.lux @@ -0,0 +1,113 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux new file mode 100644 index 000000000..9ad503709 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/inference.lux @@ -0,0 +1,301 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/module.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux new file mode 100644 index 000000000..94b289a08 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/module.lux @@ -0,0 +1,275 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux new file mode 100644 index 000000000..27c4d98f4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/primitive.lux @@ -0,0 +1,33 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux new file mode 100644 index 000000000..9ce2b1faa --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/reference.lux @@ -0,0 +1,85 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux new file mode 100644 index 000000000..c0e598e06 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/scope.lux @@ -0,0 +1,206 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux new file mode 100644 index 000000000..0f8106a7d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/structure.lux @@ -0,0 +1,361 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/analysis/type.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/type.lux new file mode 100644 index 000000000..61948e7c2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/analysis/type.lux @@ -0,0 +1,56 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/directive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux new file mode 100644 index 000000000..882ac3a6e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/directive.lux @@ -0,0 +1,79 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension.lux new file mode 100644 index 000000000..fd30c45d2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension.lux @@ -0,0 +1,177 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux new file mode 100644 index 000000000..a1a979555 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis.lux @@ -0,0 +1,16 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux new file mode 100644 index 000000000..348124448 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/common_lisp.lux @@ -0,0 +1,35 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux new file mode 100644 index 000000000..5660a2a85 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/js.lux @@ -0,0 +1,218 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux new file mode 100644 index 000000000..76bcd528e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux @@ -0,0 +1,2076 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux new file mode 100644 index 000000000..b0bdba0cb --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux @@ -0,0 +1,252 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux new file mode 100644 index 000000000..a5e924af1 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux @@ -0,0 +1,301 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux new file mode 100644 index 000000000..a30c9e6f0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/php.lux @@ -0,0 +1,214 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux new file mode 100644 index 000000000..a3635cf96 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/python.lux @@ -0,0 +1,231 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux new file mode 100644 index 000000000..6dfbf707e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/r.lux @@ -0,0 +1,35 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux new file mode 100644 index 000000000..1d01b479d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/ruby.lux @@ -0,0 +1,199 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux new file mode 100644 index 000000000..e7ff4ba15 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux @@ -0,0 +1,158 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux new file mode 100644 index 000000000..3fb0c967e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/bundle.lux @@ -0,0 +1,29 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux new file mode 100644 index 000000000..8678c6269 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/jvm.lux @@ -0,0 +1,307 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux new file mode 100644 index 000000000..dc8272030 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -0,0 +1,451 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux new file mode 100644 index 000000000..f42aa31ff --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux new file mode 100644 index 000000000..7f911e3b3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/common.lux @@ -0,0 +1,180 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux new file mode 100644 index 000000000..9895f051a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/common_lisp/host.lux @@ -0,0 +1,40 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux new file mode 100644 index 000000000..ba83e257f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux new file mode 100644 index 000000000..a74c72d38 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/common.lux @@ -0,0 +1,191 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux new file mode 100644 index 000000000..edc4e2321 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/js/host.lux @@ -0,0 +1,160 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux new file mode 100644 index 000000000..396c3284e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm.lux @@ -0,0 +1,20 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux new file mode 100644 index 000000000..da55a6c32 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/common.lux @@ -0,0 +1,414 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux new file mode 100644 index 000000000..b46934a86 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/jvm/host.lux @@ -0,0 +1,1106 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux new file mode 100644 index 000000000..1f1bd7f91 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux new file mode 100644 index 000000000..b31bf5610 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux @@ -0,0 +1,181 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux new file mode 100644 index 000000000..1bb7d771c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux @@ -0,0 +1,200 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux new file mode 100644 index 000000000..751e67a85 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux new file mode 100644 index 000000000..2d31a6b71 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/common.lux @@ -0,0 +1,192 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux new file mode 100644 index 000000000..ab01b5938 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/php/host.lux @@ -0,0 +1,143 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux new file mode 100644 index 000000000..2309732f3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux new file mode 100644 index 000000000..da9ab4a4b --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/common.lux @@ -0,0 +1,171 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux new file mode 100644 index 000000000..6612cda07 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/python/host.lux @@ -0,0 +1,165 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux new file mode 100644 index 000000000..7ca8195f7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux new file mode 100644 index 000000000..36238f9e3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/common.lux @@ -0,0 +1,179 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux new file mode 100644 index 000000000..37390f799 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/r/host.lux @@ -0,0 +1,40 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux new file mode 100644 index 000000000..417ccf847 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux new file mode 100644 index 000000000..4f2cd3291 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/common.lux @@ -0,0 +1,186 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux new file mode 100644 index 000000000..6f538b8dd --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/ruby/host.lux @@ -0,0 +1,136 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux new file mode 100644 index 000000000..7245ac4f6 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux new file mode 100644 index 000000000..17df72ac2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux @@ -0,0 +1,175 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux new file mode 100644 index 000000000..e67e05db4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux @@ -0,0 +1,109 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux new file mode 100644 index 000000000..7e9e85d6e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/synthesis.lux @@ -0,0 +1,11 @@ +(.module: + [library + [lux #*]] + [// + ["." bundle] + [/// + [synthesis (#+ Bundle)]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux new file mode 100644 index 000000000..972e318c2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp.lux @@ -0,0 +1,57 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux new file mode 100644 index 000000000..2425e2cb4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/case.lux @@ -0,0 +1,262 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux new file mode 100644 index 000000000..1880d7700 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension.lux @@ -0,0 +1,14 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux new file mode 100644 index 000000000..baac3e891 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/extension/common.lux @@ -0,0 +1,137 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux new file mode 100644 index 000000000..6adc2d747 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/function.lux @@ -0,0 +1,103 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux new file mode 100644 index 000000000..bfe5e2787 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/loop.lux @@ -0,0 +1,70 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux new file mode 100644 index 000000000..82ab68128 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/primitive.lux @@ -0,0 +1,21 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux new file mode 100644 index 000000000..83bbc6a95 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" common_lisp (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System (Expression Any)) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux new file mode 100644 index 000000000..41e7cda43 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/runtime.lux @@ -0,0 +1,293 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux new file mode 100644 index 000000000..44bd542f6 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/common_lisp/structure.lux @@ -0,0 +1,37 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux new file mode 100644 index 000000000..5196c6e33 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/extension.lux @@ -0,0 +1,66 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/js.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js.lux new file mode 100644 index 000000000..18319d0a2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js.lux @@ -0,0 +1,117 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux new file mode 100644 index 000000000..76da7c8f1 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/case.lux @@ -0,0 +1,322 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux new file mode 100644 index 000000000..df13919b0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/function.lux @@ -0,0 +1,123 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux new file mode 100644 index 000000000..720257105 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/loop.lux @@ -0,0 +1,91 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux new file mode 100644 index 000000000..ede743c5d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/primitive.lux @@ -0,0 +1,21 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux new file mode 100644 index 000000000..b21262192 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" js (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux new file mode 100644 index 000000000..2f6370418 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/runtime.lux @@ -0,0 +1,785 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux new file mode 100644 index 000000000..8c68d5b23 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/js/structure.lux @@ -0,0 +1,38 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux new file mode 100644 index 000000000..e8357027d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm.lux @@ -0,0 +1,73 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux new file mode 100644 index 000000000..7d2416d67 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/case.lux @@ -0,0 +1,266 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux new file mode 100644 index 000000000..65c141283 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/debug.lux @@ -0,0 +1,31 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux new file mode 100644 index 000000000..37cda09e1 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function.lux @@ -0,0 +1,135 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux new file mode 100644 index 000000000..fea8a985e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/abstract.lux @@ -0,0 +1,24 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux new file mode 100644 index 000000000..d6bb70600 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant.lux @@ -0,0 +1,26 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux new file mode 100644 index 000000000..a1e0a589d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/constant/arity.lux @@ -0,0 +1,22 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux new file mode 100644 index 000000000..aa200182d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable.lux @@ -0,0 +1,56 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux new file mode 100644 index 000000000..4506bb2f8 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/foreign.lux @@ -0,0 +1,40 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux new file mode 100644 index 000000000..0a2e25b3d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial.lux @@ -0,0 +1,59 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux new file mode 100644 index 000000000..5497cc094 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/field/variable/partial/count.lux @@ -0,0 +1,31 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux new file mode 100644 index 000000000..9cbde4b63 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method.lux @@ -0,0 +1,14 @@ +(.module: + [library + [lux #* + [target + [jvm + ["." modifier (#+ Modifier) ("#\." monoid)] + ["." method (#+ Method)]]]]]) + +(def: #export modifier + (Modifier Method) + ($_ modifier\compose + method.public + method.strict + )) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux new file mode 100644 index 000000000..e42804d63 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/apply.lux @@ -0,0 +1,157 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux new file mode 100644 index 000000000..14cde40a2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/implementation.lux @@ -0,0 +1,42 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux new file mode 100644 index 000000000..3785f9a40 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/init.lux @@ -0,0 +1,98 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux new file mode 100644 index 000000000..f6bfa0278 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/new.lux @@ -0,0 +1,81 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux new file mode 100644 index 000000000..229538870 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/function/method/reset.lux @@ -0,0 +1,50 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux new file mode 100644 index 000000000..2f6b8041c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/host.lux @@ -0,0 +1,161 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux new file mode 100644 index 000000000..465e8d1af --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/loop.lux @@ -0,0 +1,90 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux new file mode 100644 index 000000000..6b24fb2f5 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/primitive.lux @@ -0,0 +1,121 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux new file mode 100644 index 000000000..0441f3b00 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/program.lux @@ -0,0 +1,144 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux new file mode 100644 index 000000000..c41e5c16a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/reference.lux @@ -0,0 +1,67 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux new file mode 100644 index 000000000..e445ec2d4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux @@ -0,0 +1,611 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux new file mode 100644 index 000000000..4ff9bdb81 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/structure.lux @@ -0,0 +1,95 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux new file mode 100644 index 000000000..4c6f14a3f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/type.lux @@ -0,0 +1,23 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux new file mode 100644 index 000000000..ef82a6257 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/jvm/value.lux @@ -0,0 +1,49 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/lua.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua.lux new file mode 100644 index 000000000..529dd28a0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua.lux @@ -0,0 +1,119 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux new file mode 100644 index 000000000..0be2698f8 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/case.lux @@ -0,0 +1,280 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux new file mode 100644 index 000000000..97a5b1691 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/function.lux @@ -0,0 +1,137 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux new file mode 100644 index 000000000..a6719856c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux @@ -0,0 +1,119 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux new file mode 100644 index 000000000..7d010b4cb --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/primitive.lux @@ -0,0 +1,16 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux new file mode 100644 index 000000000..52bc69a29 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" lua (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux new file mode 100644 index 000000000..a0266db38 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux @@ -0,0 +1,432 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux new file mode 100644 index 000000000..ff9bae4be --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/lua/structure.lux @@ -0,0 +1,37 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/php.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php.lux new file mode 100644 index 000000000..5bcb2770d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php.lux @@ -0,0 +1,103 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux new file mode 100644 index 000000000..d6a4c67b0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/case.lux @@ -0,0 +1,298 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux new file mode 100644 index 000000000..1880d7700 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension.lux @@ -0,0 +1,14 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux new file mode 100644 index 000000000..5eaccf0aa --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/extension/common.lux @@ -0,0 +1,112 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux new file mode 100644 index 000000000..819f6b244 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/function.lux @@ -0,0 +1,116 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux new file mode 100644 index 000000000..9dc7e9e78 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/loop.lux @@ -0,0 +1,122 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux new file mode 100644 index 000000000..9101ee48d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/primitive.lux @@ -0,0 +1,32 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux new file mode 100644 index 000000000..5dce15a26 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" php (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.global) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux new file mode 100644 index 000000000..231bb4a29 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/runtime.lux @@ -0,0 +1,610 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux new file mode 100644 index 000000000..8d9334dca --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/php/structure.lux @@ -0,0 +1,42 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/python.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python.lux new file mode 100644 index 000000000..683a64ffe --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python.lux @@ -0,0 +1,113 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux new file mode 100644 index 000000000..a4e5e81fc --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/case.lux @@ -0,0 +1,334 @@ +(.module: + [library + [lux (#- case let if) + [abstract + ["." monad (#+ do)]] + [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: (primitive_pattern_matching recur pathP) + (-> (-> Path (Operation (Statement Any))) + (-> Path (Operation (Maybe (Statement Any))))) + (.case pathP + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail_pm!))] + (wrap (#.Some (.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 (#.Some (_.cond clauses + ..fail_pm!))))]) + ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)] + [#/////synthesis.F64_Fork (<| //primitive.f64)] + [#/////synthesis.Text_Fork (<| //primitive.text)]) + + _ + (\ ///////phase.monad wrap #.None))) + +(def: (pattern_matching' in_closure? statement expression archive) + (-> Bit Phase! Phase Archive Path (Operation (Statement Any))) + (function (recur pathP) + (do {! ///////phase.monad} + [?output (primitive_pattern_matching recur pathP)] + (.case ?output + (#.Some output) + (wrap output) + + #.None + (.case pathP + (#/////synthesis.Then bodyS) + (statement expression archive bodyS) + + #/////synthesis.Pop + (///////phase\wrap ..pop!) + + (#/////synthesis.Bind register) + (///////phase\wrap (_.set (list (..register register)) ..peek)) + + (^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 ! + [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 ! + [next! (recur nextP')] + (///////phase\wrap ($_ _.then + (..multi_pop! (n.+ 2 extra_pops)) + next!)))) + + (^ (/////synthesis.path/seq preP postP)) + (do ! + [pre! (recur preP) + post! (recur postP)] + (wrap (_.then pre! post!))) + + (^ (/////synthesis.path/alt preP postP)) + (do ! + [pre! (recur preP) + post! (recur postP) + g!once (..gensym "once")] + (wrap (..alternation in_closure? g!once pre! post!))) + + _ + (undefined)))))) + +(def: (pattern_matching in_closure? statement expression archive pathP) + (-> Bit Phase! Phase Archive Path (Operation (Statement Any))) + (do ///////phase.monad + [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP) + g!once (..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/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux new file mode 100644 index 000000000..ca18fb0ef --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/function.lux @@ -0,0 +1,112 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux new file mode 100644 index 000000000..353c890f9 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/loop.lux @@ -0,0 +1,122 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux new file mode 100644 index 000000000..60175358f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/primitive.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux new file mode 100644 index 000000000..eeb4604a3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" python (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System (Expression Any)) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux new file mode 100644 index 000000000..1b7c4310c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux @@ -0,0 +1,456 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux new file mode 100644 index 000000000..342e180d0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/python/structure.lux @@ -0,0 +1,37 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/r.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r.lux new file mode 100644 index 000000000..d3636709a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r.lux @@ -0,0 +1,59 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux new file mode 100644 index 000000000..912b7aff7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/case.lux @@ -0,0 +1,240 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux new file mode 100644 index 000000000..f30e18def --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/function.lux @@ -0,0 +1,117 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux new file mode 100644 index 000000000..f4887aaaa --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/loop.lux @@ -0,0 +1,65 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux new file mode 100644 index 000000000..9b7f40e86 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/primitive.lux @@ -0,0 +1,18 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux new file mode 100644 index 000000000..4917eb90f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/common.lux @@ -0,0 +1,340 @@ +(.module: + lux + (lux (control [library + [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/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux new file mode 100644 index 000000000..5dabf7f2a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/procedure/host.lux @@ -0,0 +1,90 @@ +(.module: + lux + (lux (control [library + [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/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux new file mode 100644 index 000000000..bbdb06ba0 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" r (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux new file mode 100644 index 000000000..4682a593d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/runtime.lux @@ -0,0 +1,855 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux new file mode 100644 index 000000000..1020cad97 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/r/structure.lux @@ -0,0 +1,40 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/reference.lux new file mode 100644 index 000000000..8b2a907ca --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/reference.lux @@ -0,0 +1,89 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux new file mode 100644 index 000000000..c891727e4 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby.lux @@ -0,0 +1,105 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux new file mode 100644 index 000000000..3c080ba8a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/case.lux @@ -0,0 +1,360 @@ +(.module: + [library + [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: (primitive_pattern_matching recur pathP) + (-> (-> Path (Operation Statement)) + (-> Path (Operation (Maybe Statement)))) + (.case pathP + (#/////synthesis.Bit_Fork when thenP elseP) + (do {! ///////phase.monad} + [then! (recur thenP) + else! (.case elseP + (#.Some elseP) + (recur elseP) + + #.None + (wrap ..fail!))] + (wrap (#.Some (.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 (#.Some (_.cond clauses + ..fail!))))]) + ([#/////synthesis.I64_Fork (<| //primitive.i64 .int)] + [#/////synthesis.F64_Fork (<| //primitive.f64)] + [#/////synthesis.Text_Fork (<| //primitive.text)]) + + _ + (\ ///////phase.monad wrap #.None))) + +(def: (pattern_matching' in_closure? statement expression archive) + (-> Bit (Generator! Path)) + (function (recur pathP) + (do ///////phase.monad + [?output (primitive_pattern_matching recur pathP)] + (.case ?output + (#.Some output) + (wrap output) + + #.None + (.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!))) + + _ + (undefined)))))) + +(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/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux new file mode 100644 index 000000000..af7906c9c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/function.lux @@ -0,0 +1,112 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux new file mode 100644 index 000000000..c1639df6a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/loop.lux @@ -0,0 +1,96 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux new file mode 100644 index 000000000..0f01d2455 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/primitive.lux @@ -0,0 +1,16 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux new file mode 100644 index 000000000..a54e6da57 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" ruby (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.global) + (def: variable _.local)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux new file mode 100644 index 000000000..2ce60a9a1 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux @@ -0,0 +1,403 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux new file mode 100644 index 000000000..c172b43b8 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/structure.lux @@ -0,0 +1,37 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux new file mode 100644 index 000000000..98f7b88bb --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme.lux @@ -0,0 +1,59 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux new file mode 100644 index 000000000..99d115b9d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux @@ -0,0 +1,223 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux new file mode 100644 index 000000000..1880d7700 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension.lux @@ -0,0 +1,14 @@ +(.module: + [library + [lux #* + [data + [collection + ["." dictionary]]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux new file mode 100644 index 000000000..0275e8cd9 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/extension/common.lux @@ -0,0 +1,223 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux new file mode 100644 index 000000000..b12ddcde3 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux @@ -0,0 +1,101 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux new file mode 100644 index 000000000..23718bfc5 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/loop.lux @@ -0,0 +1,64 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux new file mode 100644 index 000000000..a7c2b81b6 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/primitive.lux @@ -0,0 +1,16 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux new file mode 100644 index 000000000..19d46ba19 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/reference.lux @@ -0,0 +1,13 @@ +(.module: + [library + [lux #* + [target + ["_" scheme (#+ Expression)]]]] + [/// + [reference (#+ System)]]) + +(implementation: #export system + (System Expression) + + (def: constant _.var) + (def: variable _.var)) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux new file mode 100644 index 000000000..ec3def7fd --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux @@ -0,0 +1,370 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux new file mode 100644 index 000000000..50a8357f7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/scheme/structure.lux @@ -0,0 +1,40 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/synthesis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis.lux new file mode 100644 index 000000000..47260c0fc --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis.lux @@ -0,0 +1,104 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux new file mode 100644 index 000000000..02938eb7a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -0,0 +1,430 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux new file mode 100644 index 000000000..2b0319266 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -0,0 +1,277 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux new file mode 100644 index 000000000..ed5381e02 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/loop.lux @@ -0,0 +1,187 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux new file mode 100644 index 000000000..07e7a54b9 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/synthesis/variable.lux @@ -0,0 +1,443 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/program.lux b/stdlib/source/library/lux/tool/compiler/language/lux/program.lux new file mode 100644 index 000000000..f33831904 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/program.lux @@ -0,0 +1,57 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/library/lux/tool/compiler/language/lux/syntax.lux new file mode 100644 index 000000000..e41cd0f79 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/syntax.lux @@ -0,0 +1,584 @@ +## 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: + [library + [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 + .prelude_module) + +(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/library/lux/tool/compiler/language/lux/synthesis.lux b/stdlib/source/library/lux/tool/compiler/language/lux/synthesis.lux new file mode 100644 index 000000000..cec608916 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/synthesis.lux @@ -0,0 +1,809 @@ +(.module: + [library + [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/library/lux/tool/compiler/language/lux/version.lux b/stdlib/source/library/lux/tool/compiler/language/lux/version.lux new file mode 100644 index 000000000..dd3676068 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/language/lux/version.lux @@ -0,0 +1,9 @@ +(.module: + [library + [lux #*]] + [//// + [version (#+ Version)]]) + +(def: #export version + Version + 00,06,00) diff --git a/stdlib/source/library/lux/tool/compiler/meta.lux b/stdlib/source/library/lux/tool/compiler/meta.lux new file mode 100644 index 000000000..23cacb4aa --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta.lux @@ -0,0 +1,9 @@ +(.module: + [library + [lux #*]] + [// + [version (#+ Version)]]) + +(def: #export version + Version + 00,01,00) diff --git a/stdlib/source/library/lux/tool/compiler/meta/archive.lux b/stdlib/source/library/lux/tool/compiler/meta/archive.lux new file mode 100644 index 000000000..d04f1227f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive.lux @@ -0,0 +1,280 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/archive/artifact.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/artifact.lux new file mode 100644 index 000000000..33e09e51a --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/artifact.lux @@ -0,0 +1,155 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/descriptor.lux new file mode 100644 index 000000000..2c602ac89 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/descriptor.lux @@ -0,0 +1,49 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/document.lux new file mode 100644 index 000000000..ea5ce1006 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/document.lux @@ -0,0 +1,72 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/archive/key.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/key.lux new file mode 100644 index 000000000..ec6439aa7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/key.lux @@ -0,0 +1,19 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/library/lux/tool/compiler/meta/archive/signature.lux new file mode 100644 index 000000000..e39bb2144 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/archive/signature.lux @@ -0,0 +1,42 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/library/lux/tool/compiler/meta/cache/dependency.lux new file mode 100644 index 000000000..3ba514b5f --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/cache/dependency.lux @@ -0,0 +1,97 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/io.lux b/stdlib/source/library/lux/tool/compiler/meta/io.lux new file mode 100644 index 000000000..fe11727b7 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/io.lux @@ -0,0 +1,20 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux new file mode 100644 index 000000000..b5ed4b84b --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux @@ -0,0 +1,450 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/io/context.lux b/stdlib/source/library/lux/tool/compiler/meta/io/context.lux new file mode 100644 index 000000000..6e619d93d --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/io/context.lux @@ -0,0 +1,170 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/packager.lux b/stdlib/source/library/lux/tool/compiler/meta/packager.lux new file mode 100644 index 000000000..621045e33 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/packager.lux @@ -0,0 +1,43 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/packager/jvm.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/jvm.lux new file mode 100644 index 000000000..f5366ab8e --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/packager/jvm.lux @@ -0,0 +1,145 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/packager/scheme.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/scheme.lux new file mode 100644 index 000000000..bcd06b6fd --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/packager/scheme.lux @@ -0,0 +1,132 @@ +(.module: + [library + [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/library/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux new file mode 100644 index 000000000..ac2b5758c --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/meta/packager/script.lux @@ -0,0 +1,76 @@ +(.module: + [library + [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/library/lux/tool/compiler/phase.lux b/stdlib/source/library/lux/tool/compiler/phase.lux new file mode 100644 index 000000000..d69098f92 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/phase.lux @@ -0,0 +1,119 @@ +(.module: + [library + [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/library/lux/tool/compiler/reference.lux b/stdlib/source/library/lux/tool/compiler/reference.lux new file mode 100644 index 000000000..8823b29e2 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/reference.lux @@ -0,0 +1,85 @@ +(.module: + [library + [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/library/lux/tool/compiler/reference/variable.lux b/stdlib/source/library/lux/tool/compiler/reference/variable.lux new file mode 100644 index 000000000..a8ce4c049 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/reference/variable.lux @@ -0,0 +1,68 @@ +(.module: + [library + [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/library/lux/tool/compiler/version.lux b/stdlib/source/library/lux/tool/compiler/version.lux new file mode 100644 index 000000000..733b86477 --- /dev/null +++ b/stdlib/source/library/lux/tool/compiler/version.lux @@ -0,0 +1,52 @@ +(.module: + [library + [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/library/lux/tool/interpreter.lux b/stdlib/source/library/lux/tool/interpreter.lux new file mode 100644 index 000000000..df48eb420 --- /dev/null +++ b/stdlib/source/library/lux/tool/interpreter.lux @@ -0,0 +1,222 @@ +(.module: + [library + [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/library/lux/tool/mediator.lux b/stdlib/source/library/lux/tool/mediator.lux new file mode 100644 index 000000000..b24309ef1 --- /dev/null +++ b/stdlib/source/library/lux/tool/mediator.lux @@ -0,0 +1,19 @@ +(.module: + [library + [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 !))) |