diff options
Diffstat (limited to '')
22 files changed, 828 insertions, 622 deletions
diff --git a/compilers.md b/compilers.md index 14c8280f1..b99960dd4 100644 --- a/compilers.md +++ b/compilers.md @@ -208,7 +208,7 @@ cd ~/lux/lux-lua/ \ ## Use Lua-based compiler to produce another Lua-based compiler. cd ~/lux/lux-lua/ \ && lein clean \ -&& time lua host_based_compiler.lua build --source ~/lux/lux-lua/source --target ~/lux/lux-lua/target --module program \ +&& time ~/lua-5.4.2/install/bin/lua host_based_compiler.lua build --source ~/lux/lux-lua/source --target ~/lux/lux-lua/target --module program \ && mv target/program.lua lux.lua ``` diff --git a/lux-lua/source/program.lux b/lux-lua/source/program.lux index 517d0e746..180757de6 100644 --- a/lux-lua/source/program.lux +++ b/lux-lua/source/program.lux @@ -60,339 +60,388 @@ ["#." cli] ["#." static]]]) -(host.import: java/lang/String) +(for {@.old + (as_is (host.import: java/lang/String) + + (host.import: (java/lang/Class a)) + + (host.import: java/lang/Object + ["#::." + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))]) + + (host.import: java/lang/Long + ["#::." + (intValue [] java/lang/Integer)]) + + (host.import: net/sandius/rembulan/StateContext) + + (host.import: net/sandius/rembulan/impl/StateContexts + ["#::." + (#static newDefaultInstance [] net/sandius/rembulan/StateContext)]) + + (host.import: net/sandius/rembulan/env/RuntimeEnvironment) + + (host.import: net/sandius/rembulan/env/RuntimeEnvironments + ["#::." + (#static system [] net/sandius/rembulan/env/RuntimeEnvironment)]) + + (host.import: net/sandius/rembulan/Table + ["#::." + (rawget #as get_idx [long] #? java/lang/Object) + (rawget #as get_key [java/lang/Object] #? java/lang/Object) + (rawlen [] long)]) + + (host.import: net/sandius/rembulan/ByteString + ["#::." + (decode [] java/lang/String)]) + + (host.import: net/sandius/rembulan/impl/DefaultTable) + + (host.import: net/sandius/rembulan/impl/ImmutableTable) + + (host.import: net/sandius/rembulan/impl/ImmutableTable$Builder + ["#::." + (new []) + (build [] net/sandius/rembulan/impl/ImmutableTable)]) + + (host.import: net/sandius/rembulan/lib/StandardLibrary + ["#::." + (#static in [net/sandius/rembulan/env/RuntimeEnvironment] net/sandius/rembulan/lib/StandardLibrary) + (installInto [net/sandius/rembulan/StateContext] net/sandius/rembulan/Table)]) + + (host.import: net/sandius/rembulan/Variable + ["#::." + (new [java/lang/Object])]) + + (host.import: net/sandius/rembulan/runtime/LuaFunction) + + (host.import: net/sandius/rembulan/load/ChunkLoader + ["#::." + (loadTextChunk [net/sandius/rembulan/Variable + java/lang/String + java/lang/String] + #try net/sandius/rembulan/runtime/LuaFunction)]) + + (host.import: net/sandius/rembulan/compiler/CompilerChunkLoader + ["#::." + (#static of [java/lang/String] net/sandius/rembulan/compiler/CompilerChunkLoader)]) + + (host.import: net/sandius/rembulan/runtime/SchedulingContext) + + (host.import: net/sandius/rembulan/runtime/SchedulingContextFactory) + + (host.import: net/sandius/rembulan/exec/DirectCallExecutor + ["#::." + (#static newExecutor [] net/sandius/rembulan/exec/DirectCallExecutor) + (schedulingContextFactory [] net/sandius/rembulan/runtime/SchedulingContextFactory) + (call [net/sandius/rembulan/StateContext java/lang/Object [java/lang/Object]] #try [java/lang/Object])]) + + (exception: (unknown_kind_of_object {object java/lang/Object}) + (exception.report + ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))] + ["Object" (java/lang/Object::toString object)])) + + (template [<name>] + [(host.interface: <name> + (getValue [] java/lang/Object)) + + (`` (host.import: (~~ (template.identifier ["program/" <name>])) + ["#::." + (getValue [] java/lang/Object)]))] + + [StructureValue] + ) + + (def: (lux_structure value) + (-> (Array java/lang/Object) program/StructureValue) + (let [re_wrap (function (_ unwrapped) + (case (host.check [java/lang/Object] unwrapped) + (#.Some sub_value) + (|> sub_value (:coerce (Array java/lang/Object)) lux_structure (:coerce java/lang/Object)) + + #.None + unwrapped))] + (host.object [] net/sandius/rembulan/impl/DefaultTable [program/StructureValue] + [] + ## Methods + (program/StructureValue + [] (getValue self) java/lang/Object + (:coerce (Array java/lang/Object) value)) + + (net/sandius/rembulan/impl/DefaultTable + [] (rawlen self) long + (|> value array.size (:coerce java/lang/Long))) + + (net/sandius/rembulan/impl/DefaultTable + [] (rawget self {idx long}) java/lang/Object + (|> value (array.read (|> idx (:coerce Nat) dec)) maybe.assume re_wrap)) + + (net/sandius/rembulan/impl/DefaultTable + [] (rawget self {field java/lang/Object}) java/lang/Object + (case (host.check net/sandius/rembulan/ByteString field) + (#.Some field) + (case (net/sandius/rembulan/ByteString::decode field) + (^ (static runtime.variant_tag_field)) + (|> value (array.read 0) maybe.assume) + + (^ (static runtime.variant_flag_field)) + (case (array.read 1 value) + (#.Some _) + "" -(host.import: (java/lang/Class a)) - -(host.import: java/lang/Object - ["#::." - (toString [] java/lang/String) - (getClass [] (java/lang/Class java/lang/Object))]) - -(host.import: java/lang/Long - ["#::." - (intValue [] java/lang/Integer)]) - -(host.import: net/sandius/rembulan/StateContext) - -(host.import: net/sandius/rembulan/impl/StateContexts - ["#::." - (#static newDefaultInstance [] net/sandius/rembulan/StateContext)]) - -(host.import: net/sandius/rembulan/env/RuntimeEnvironment) - -(host.import: net/sandius/rembulan/env/RuntimeEnvironments - ["#::." - (#static system [] net/sandius/rembulan/env/RuntimeEnvironment)]) - -(host.import: net/sandius/rembulan/Table - ["#::." - (rawget #as get_idx [long] #? java/lang/Object) - (rawget #as get_key [java/lang/Object] #? java/lang/Object) - (rawlen [] long)]) - -(host.import: net/sandius/rembulan/ByteString - ["#::." - (decode [] java/lang/String)]) - -(host.import: net/sandius/rembulan/impl/DefaultTable) - -(host.import: net/sandius/rembulan/impl/ImmutableTable) - -(host.import: net/sandius/rembulan/impl/ImmutableTable$Builder - ["#::." - (new []) - (build [] net/sandius/rembulan/impl/ImmutableTable)]) - -(host.import: net/sandius/rembulan/lib/StandardLibrary - ["#::." - (#static in [net/sandius/rembulan/env/RuntimeEnvironment] net/sandius/rembulan/lib/StandardLibrary) - (installInto [net/sandius/rembulan/StateContext] net/sandius/rembulan/Table)]) - -(host.import: net/sandius/rembulan/Variable - ["#::." - (new [java/lang/Object])]) - -(host.import: net/sandius/rembulan/runtime/LuaFunction) - -(host.import: net/sandius/rembulan/load/ChunkLoader - ["#::." - (loadTextChunk [net/sandius/rembulan/Variable - java/lang/String - java/lang/String] - #try net/sandius/rembulan/runtime/LuaFunction)]) - -(host.import: net/sandius/rembulan/compiler/CompilerChunkLoader - ["#::." - (#static of [java/lang/String] net/sandius/rembulan/compiler/CompilerChunkLoader)]) - -(host.import: net/sandius/rembulan/runtime/SchedulingContext) - -(host.import: net/sandius/rembulan/runtime/SchedulingContextFactory) - -(host.import: net/sandius/rembulan/exec/DirectCallExecutor - ["#::." - (#static newExecutor [] net/sandius/rembulan/exec/DirectCallExecutor) - (schedulingContextFactory [] net/sandius/rembulan/runtime/SchedulingContextFactory) - (call [net/sandius/rembulan/StateContext java/lang/Object [java/lang/Object]] #try [java/lang/Object])]) - -(exception: (unknown_kind_of_object {object java/lang/Object}) - (exception.report - ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))] - ["Object" (java/lang/Object::toString object)])) - -(template [<name>] - [(host.interface: <name> - (getValue [] java/lang/Object)) - - (`` (host.import: (~~ (template.identifier ["program/" <name>])) - ["#::." - (getValue [] java/lang/Object)]))] - - [StructureValue] - ) - -(def: (lux_structure value) - (-> (Array java/lang/Object) program/StructureValue) - (let [re_wrap (function (_ unwrapped) - (case (host.check [java/lang/Object] unwrapped) - (#.Some sub_value) - (|> sub_value (:coerce (Array java/lang/Object)) lux_structure (:coerce java/lang/Object)) - - #.None - unwrapped))] - (host.object [] net/sandius/rembulan/impl/DefaultTable [program/StructureValue] - [] - ## Methods - (program/StructureValue - [] (getValue self) java/lang/Object - (:coerce (Array java/lang/Object) value)) - - (net/sandius/rembulan/impl/DefaultTable - [] (rawlen self) long - (|> value array.size (:coerce java/lang/Long))) - - (net/sandius/rembulan/impl/DefaultTable - [] (rawget self {idx long}) java/lang/Object - (|> value (array.read (|> idx (:coerce Nat) dec)) maybe.assume re_wrap)) - - (net/sandius/rembulan/impl/DefaultTable - [] (rawget self {field java/lang/Object}) java/lang/Object - (case (host.check net/sandius/rembulan/ByteString field) - (#.Some field) - (case (net/sandius/rembulan/ByteString::decode field) - (^ (static runtime.variant_tag_field)) - (|> value (array.read 0) maybe.assume) - - (^ (static runtime.variant_flag_field)) - (case (array.read 1 value) - (#.Some _) - "" - - #.None - (host.null)) - - (^ (static runtime.variant_value_field)) - (|> value (array.read 2) maybe.assume re_wrap) - - _ - (error! (exception.construct ..unknown_kind_of_object field))) - - #.None - (case (host.check java/lang/Long field) - (#.Some idx) - (|> value (array.read (|> idx (:coerce Nat) dec)) maybe.assume re_wrap) - - #.None - (error! (exception.construct ..unknown_kind_of_object field))))) - ))) - -(type: Translator - (-> java/lang/Object (Try Any))) - -(def: (read_variant read host_object) - (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any)) - (case [(net/sandius/rembulan/Table::get_key runtime.variant_tag_field host_object) - (net/sandius/rembulan/Table::get_key runtime.variant_flag_field host_object) - (net/sandius/rembulan/Table::get_key runtime.variant_value_field host_object)] - (^multi [(#.Some tag) ?flag (#.Some value)] - [(read value) - (#.Some value)]) - (#try.Success [(java/lang/Long::intValue (:coerce java/lang/Long tag)) - (: Any (case ?flag (#.Some _) "" #.None (host.null))) - value]) - - _ - (exception.throw ..unknown_kind_of_object host_object))) - -(def: (read_tuple read host_object) - (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any)) - (let [init_num_keys (.nat (net/sandius/rembulan/Table::rawlen host_object))] - (loop [num_keys init_num_keys - idx 0 - output (: (Array java/lang/Object) - (array.new init_num_keys))] - (if (n.< num_keys idx) - (case (net/sandius/rembulan/Table::get_idx (:coerce java/lang/Long (inc idx)) host_object) - #.None - (recur num_keys (inc idx) output) - - (#.Some member) - (case (read member) - (#try.Success parsed_member) - (recur num_keys (inc idx) (array.write! idx (:coerce java/lang/Object parsed_member) output)) - - (#try.Failure error) - (#try.Failure error))) - (#try.Success output))))) - -(exception: #export nil_has_no_lux_representation) - -(def: (read host_object) - Translator - (`` (<| (if (host.null? host_object) - (exception.throw ..nil_has_no_lux_representation [])) - (~~ (template [<class> <post_processing>] - [(case (host.check <class> host_object) - (#.Some typed_object) - (|> typed_object <post_processing>) - - _)] - - [java/lang/Boolean #try.Success] - [java/lang/Long #try.Success] - [java/lang/Double #try.Success] - [java/lang/String #try.Success] - [net/sandius/rembulan/runtime/LuaFunction #try.Success] - [net/sandius/rembulan/ByteString (<| #try.Success net/sandius/rembulan/ByteString::decode)] - [program/StructureValue (<| #try.Success program/StructureValue::getValue)] - )) - (case (host.check net/sandius/rembulan/impl/DefaultTable host_object) - (#.Some typed_object) - (case (read_variant read typed_object) - (#try.Success value) - (#try.Success value) - - (#try.Failure error) - (read_tuple read typed_object)) - - _) - (exception.throw ..unknown_kind_of_object host_object) - ))) - -(exception: (cannot_apply_a_non_function {object java/lang/Object}) - (exception.report - ["Non-function" (java/lang/Object::toString object)])) - -(def: ensure_function - (-> Macro (Maybe net/sandius/rembulan/runtime/LuaFunction)) - (|>> (:coerce java/lang/Object) (host.check net/sandius/rembulan/runtime/LuaFunction))) - -(type: Baggage - [net/sandius/rembulan/StateContext - net/sandius/rembulan/exec/DirectCallExecutor]) - -(def: (call_macro [state_context executor] inputs lux macro) - (-> Baggage (List Code) Lux net/sandius/rembulan/runtime/LuaFunction (Try Any)) - (do try.monad - [output (net/sandius/rembulan/exec/DirectCallExecutor::call state_context - (:coerce java/lang/Object macro) - (|> (array.new 2) - (array.write! 0 ## (:coerce java/lang/Object inputs) - ## (net/sandius/rembulan/impl/ImmutableTable$Builder::build (net/sandius/rembulan/impl/ImmutableTable$Builder::new)) - (:coerce java/lang/Object (lux_structure (:coerce (Array java/lang/Object) inputs)))) - (array.write! 1 ## (:coerce java/lang/Object lux) - ## (net/sandius/rembulan/impl/ImmutableTable$Builder::build (net/sandius/rembulan/impl/ImmutableTable$Builder::new)) - (:coerce java/lang/Object (lux_structure (:coerce (Array java/lang/Object) lux))))) - executor)] - (|> output (array.read 0) maybe.assume (:coerce java/lang/Object) ..read))) - -(def: (expander baggage macro inputs lux) - (-> Baggage Expander) - (case (..ensure_function macro) - (#.Some macro) - (case (..call_macro baggage inputs lux macro) - (#try.Success output) - (|> output - (:coerce (Try [Lux (List Code)])) - #try.Success) - - (#try.Failure error) - (#try.Failure error)) - - #.None - (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro)))) - -(def: host - (IO [Baggage (Host _.Expression _.Statement)]) - (io (let [runtime_env (net/sandius/rembulan/env/RuntimeEnvironments::system) - std_lib (net/sandius/rembulan/lib/StandardLibrary::in runtime_env) - state_context (net/sandius/rembulan/impl/StateContexts::newDefaultInstance) - table (net/sandius/rembulan/lib/StandardLibrary::installInto state_context std_lib) - variable (net/sandius/rembulan/Variable::new table) - loader (net/sandius/rembulan/compiler/CompilerChunkLoader::of "_lux_definition") - executor (net/sandius/rembulan/exec/DirectCallExecutor::newExecutor) - scheduling_context (net/sandius/rembulan/exec/DirectCallExecutor::schedulingContextFactory executor) - run! (: (-> _.Statement (Try Any)) - (function (_ code) - (do try.monad - [lua_function (net/sandius/rembulan/load/ChunkLoader::loadTextChunk variable "lux compilation" (_.code code) loader) - output (net/sandius/rembulan/exec/DirectCallExecutor::call state_context (:coerce java/lang/Object lua_function) (array.new 0) - executor)] - (case (array.read 0 output) #.None - (wrap []) - - (#.Some value) - (read value)))))] - [[state_context executor] - (: (Host _.Expression _.Statement) - (structure - (def: (evaluate! context code) - (run! (_.return code))) - - (def: execute! run!) - - (def: (define! context input) - (let [global (reference.artifact context) - @global (_.var global)] - (do try.monad - [#let [definition (_.set (list @global) input)] - _ (run! definition) - value (run! (_.return @global))] - (wrap [global value definition])))) - - (def: (ingest context content) - (|> content (\ encoding.utf8 decode) try.assume (:coerce _.Statement))) - - (def: (re_learn context content) - (run! content)) - - (def: (re_load context content) + (host.null)) + + (^ (static runtime.variant_value_field)) + (|> value (array.read 2) maybe.assume re_wrap) + + _ + (error! (exception.construct ..unknown_kind_of_object field))) + + #.None + (case (host.check java/lang/Long field) + (#.Some idx) + (|> value (array.read (|> idx (:coerce Nat) dec)) maybe.assume re_wrap) + + #.None + (error! (exception.construct ..unknown_kind_of_object field))))) + ))) + + (type: Translator + (-> java/lang/Object (Try Any))) + + (def: (read_variant read host_object) + (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any)) + (case [(net/sandius/rembulan/Table::get_key runtime.variant_tag_field host_object) + (net/sandius/rembulan/Table::get_key runtime.variant_flag_field host_object) + (net/sandius/rembulan/Table::get_key runtime.variant_value_field host_object)] + (^multi [(#.Some tag) ?flag (#.Some value)] + [(read value) + (#.Some value)]) + (#try.Success [(java/lang/Long::intValue (:coerce java/lang/Long tag)) + (: Any (case ?flag (#.Some _) "" #.None (host.null))) + value]) + + _ + (exception.throw ..unknown_kind_of_object host_object))) + + (def: (read_tuple read host_object) + (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any)) + (let [init_num_keys (.nat (net/sandius/rembulan/Table::rawlen host_object))] + (loop [num_keys init_num_keys + idx 0 + output (: (Array java/lang/Object) + (array.new init_num_keys))] + (if (n.< num_keys idx) + (case (net/sandius/rembulan/Table::get_idx (:coerce java/lang/Long (inc idx)) host_object) + #.None + (recur num_keys (inc idx) output) + + (#.Some member) + (case (read member) + (#try.Success parsed_member) + (recur num_keys (inc idx) (array.write! idx (:coerce java/lang/Object parsed_member) output)) + + (#try.Failure error) + (#try.Failure error))) + (#try.Success output))))) + + (exception: #export nil_has_no_lux_representation) + + (def: (read host_object) + Translator + (`` (<| (if (host.null? host_object) + (exception.throw ..nil_has_no_lux_representation [])) + (~~ (template [<class> <post_processing>] + [(case (host.check <class> host_object) + (#.Some typed_object) + (|> typed_object <post_processing>) + + _)] + + [java/lang/Boolean #try.Success] + [java/lang/Long #try.Success] + [java/lang/Double #try.Success] + [java/lang/String #try.Success] + [net/sandius/rembulan/runtime/LuaFunction #try.Success] + [net/sandius/rembulan/ByteString (<| #try.Success net/sandius/rembulan/ByteString::decode)] + [program/StructureValue (<| #try.Success program/StructureValue::getValue)] + )) + (case (host.check net/sandius/rembulan/impl/DefaultTable host_object) + (#.Some typed_object) + (case (read_variant read typed_object) + (#try.Success value) + (#try.Success value) + + (#try.Failure error) + (read_tuple read typed_object)) + + _) + (exception.throw ..unknown_kind_of_object host_object) + ))) + + (exception: (cannot_apply_a_non_function {object java/lang/Object}) + (exception.report + ["Non-function" (java/lang/Object::toString object)])) + + (def: ensure_function + (-> Macro (Maybe net/sandius/rembulan/runtime/LuaFunction)) + (|>> (:coerce java/lang/Object) (host.check net/sandius/rembulan/runtime/LuaFunction))) + + (type: Baggage + [net/sandius/rembulan/StateContext + net/sandius/rembulan/exec/DirectCallExecutor]) + + (def: (call_macro [state_context executor] inputs lux macro) + (-> Baggage (List Code) Lux net/sandius/rembulan/runtime/LuaFunction (Try Any)) (do try.monad - [_ (run! content)] - (run! (_.return (_.var (reference.artifact context))))))))]))) - -(def: platform - (IO [Baggage (Platform [Register _.Label] _.Expression _.Statement)]) - (do io.monad - [[baggage host] ..host] - (wrap [baggage - {#platform.&file_system (file.async file.default) - #platform.host host - #platform.phase lua.generate - #platform.runtime runtime.generate - #platform.write (|>> _.code (\ encoding.utf8 encode))}]))) + [output (net/sandius/rembulan/exec/DirectCallExecutor::call state_context + (:coerce java/lang/Object macro) + (|> (array.new 2) + (array.write! 0 ## (:coerce java/lang/Object inputs) + ## (net/sandius/rembulan/impl/ImmutableTable$Builder::build (net/sandius/rembulan/impl/ImmutableTable$Builder::new)) + (:coerce java/lang/Object (lux_structure (:coerce (Array java/lang/Object) inputs)))) + (array.write! 1 ## (:coerce java/lang/Object lux) + ## (net/sandius/rembulan/impl/ImmutableTable$Builder::build (net/sandius/rembulan/impl/ImmutableTable$Builder::new)) + (:coerce java/lang/Object (lux_structure (:coerce (Array java/lang/Object) lux))))) + executor)] + (|> output (array.read 0) maybe.assume (:coerce java/lang/Object) ..read))) + + (def: (expander baggage macro inputs lux) + (-> Baggage Expander) + (case (..ensure_function macro) + (#.Some macro) + (case (..call_macro baggage inputs lux macro) + (#try.Success output) + (|> output + (:coerce (Try [Lux (List Code)])) + #try.Success) + + (#try.Failure error) + (#try.Failure error)) + + #.None + (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro))))) + + @.lua + (def: (expander macro inputs lux) + Expander + (#try.Success ((:coerce Macro' macro) inputs lux)))}) + +(for {@.old (def: host + (IO [Baggage (Host _.Expression _.Statement)]) + (io (let [runtime_env (net/sandius/rembulan/env/RuntimeEnvironments::system) + std_lib (net/sandius/rembulan/lib/StandardLibrary::in runtime_env) + state_context (net/sandius/rembulan/impl/StateContexts::newDefaultInstance) + table (net/sandius/rembulan/lib/StandardLibrary::installInto state_context std_lib) + variable (net/sandius/rembulan/Variable::new table) + loader (net/sandius/rembulan/compiler/CompilerChunkLoader::of "_lux_definition") + executor (net/sandius/rembulan/exec/DirectCallExecutor::newExecutor) + scheduling_context (net/sandius/rembulan/exec/DirectCallExecutor::schedulingContextFactory executor) + run! (: (-> _.Statement (Try Any)) + (function (_ code) + (do try.monad + [lua_function (net/sandius/rembulan/load/ChunkLoader::loadTextChunk variable "lux compilation" (_.code code) loader) + output (net/sandius/rembulan/exec/DirectCallExecutor::call state_context (:coerce java/lang/Object lua_function) (array.new 0) + executor)] + (case (array.read 0 output) + #.None + (wrap []) + + (#.Some value) + (read value)))))] + [[state_context executor] + (: (Host _.Expression _.Statement) + (structure + (def: (evaluate! context code) + (run! (_.return code))) + + (def: execute! run!) + + (def: (define! context input) + (let [global (reference.artifact context) + @global (_.var global)] + (do try.monad + [#let [definition (_.set (list @global) input)] + _ (run! definition) + value (run! (_.return @global))] + (wrap [global value definition])))) + + (def: (ingest context content) + (|> content (\ encoding.utf8 decode) try.assume (:coerce _.Statement))) + + (def: (re_learn context content) + (run! content)) + + (def: (re_load context content) + (do try.monad + [_ (run! content)] + (run! (_.return (_.var (reference.artifact context))))))))]))) + @.lua (as_is (host.import: (load [host.String] #try host.Function)) + (def: host + (IO (Host _.Expression _.Statement)) + (io (let [run! (: (-> _.Statement (Try Any)) + (function (_ code) + (do try.monad + [lua_function (..load (_.code code))] + (let [output ("lua apply" lua_function)] + (#try.Success (if ("lua object nil?" output) + [] + output))))))] + (: (Host _.Expression _.Statement) + (structure + (def: (evaluate! context code) + (run! (_.return code))) + + (def: execute! run!) + + (def: (define! context input) + (let [global (reference.artifact context) + @global (_.var global)] + (do try.monad + [#let [definition (_.set (list @global) input)] + _ (run! definition) + value (run! (_.return @global))] + (wrap [global value definition])))) + + (def: (ingest context content) + (|> content (\ encoding.utf8 decode) try.assume (:coerce _.Statement))) + + (def: (re_learn context content) + (run! content)) + + (def: (re_load context content) + (do try.monad + [_ (run! content)] + (run! (_.return (_.var (reference.artifact context))))))))))))}) + +(for {@.old (def: platform + (IO [Baggage (Platform [Register _.Label] _.Expression _.Statement)]) + (do io.monad + [[baggage host] ..host] + (wrap [baggage + {#platform.&file_system (file.async file.default) + #platform.host host + #platform.phase lua.generate + #platform.runtime runtime.generate + #platform.write (|>> _.code (\ encoding.utf8 encode))}]))) + @.lua (def: platform + (IO (Platform [Register _.Label] _.Expression _.Statement)) + (do io.monad + [host ..host] + (wrap {#platform.&file_system (file.async file.default) + #platform.host host + #platform.phase lua.generate + #platform.runtime runtime.generate + #platform.write (|>> _.code (\ encoding.utf8 encode))})))}) (def: (program context program) (Program _.Expression _.Statement) (let [$program (_.var (reference.artifact context))] - ($_ _.then - (_.function $program (list) - (_.statement (_.apply/* (list (runtime.lux//program_args (_.var "arg")) - runtime.unit) - program))) - (_.statement (_.apply/* (list) $program))))) + (_.statement (_.apply/* (list (runtime.lux//program_args (_.var "arg")) + runtime.unit) + program)))) (for {@.old (def: (extender [state_context executor]) @@ -437,35 +486,35 @@ (-> Any (Promise Any)) (promise.future (\ world/program.default exit +0))) -(def: (scope program) - (-> _.Statement _.Statement) - (let [$program (_.var "lux_program")] - ($_ _.then - (_.function $program (list) program) - (_.statement (_.apply/* (list) $program))))) - -(program: [{service /cli.service}] - (let [extension ".lua"] - (do io.monad - [[baggage platform] ..platform] - (exec (do promise.monad - [_ (/.compiler {#/static.host @.lua - #/static.host_module_extension extension - #/static.target (/cli.target service) - #/static.artifact_extension extension} - (..expander baggage) - analysis.bundle - (io.io platform) - generation.bundle - extension/bundle.empty - ..program - [(& Register _.Label) _.Expression _.Statement] - (..extender baggage) - service - [(packager.package (_.manual "") _.code _.then ..scope) - (format (/cli.target service) - (\ file.default separator) - "program" - extension)])] - (..declare_success! [])) - (io.io []))))) +(`` (program: [{service /cli.service}] + (let [extension ".lua"] + (do io.monad + [(~~ (for {@.old [baggage platform] + @.lua platform})) + ..platform] + (exec (do promise.monad + [_ (/.compiler {#/static.host @.lua + #/static.host_module_extension extension + #/static.target (/cli.target service) + #/static.artifact_extension extension} + (for {@.old (..expander baggage) + @.lua ..expander}) + analysis.bundle + (io.io platform) + generation.bundle + extension/bundle.empty + ..program + [(& Register _.Label) _.Expression _.Statement] + (for {@.old (..extender baggage) + @.lua ..extender}) + service + [(packager.package (_.manual "") + _.code + _.then + (|>>)) + (format (/cli.target service) + (\ file.default separator) + "program" + extension)])] + (..declare_success! [])) + (io.io [])))))) diff --git a/stdlib/source/lux/control/concurrency/thread.lux b/stdlib/source/lux/control/concurrency/thread.lux index a34e050d5..d07edd0d8 100644 --- a/stdlib/source/lux/control/concurrency/thread.lux +++ b/stdlib/source/lux/control/concurrency/thread.lux @@ -131,28 +131,29 @@ ## Default (as_is (exception: #export cannot_continue_running_threads) - (def: #export (run! _) - (-> Any (IO Any)) - (do {! io.monad} - [threads (atom.read ..runner)] - (case threads - ## And... we're done! - #.Nil - (wrap []) - - _ - (do ! - [#let [now (.nat ("lux io current-time")) - [ready pending] (list.partition (function (_ thread) - (|> (get@ #creation thread) - (n.+ (get@ #delay thread)) - (n.<= now))) - threads)] - swapped? (atom.compare_and_swap threads pending ..runner)] - (if swapped? - (do ! - [_ (monad.map ! (get@ #action) ready)] - (run! [])) - (error! (exception.construct ..cannot_continue_running_threads [])))) - ))) + (def: #export run! + (IO Any) + (loop [_ []] + (do {! io.monad} + [threads (atom.read ..runner)] + (case threads + ## And... we're done! + #.Nil + (wrap []) + + _ + (do ! + [#let [now (.nat ("lux io current-time")) + [ready pending] (list.partition (function (_ thread) + (|> (get@ #creation thread) + (n.+ (get@ #delay thread)) + (n.<= now))) + threads)] + swapped? (atom.compare_and_swap threads pending ..runner)] + (if swapped? + (do ! + [_ (monad.map ! (get@ #action) ready)] + (recur [])) + (error! (exception.construct ..cannot_continue_running_threads [])))) + )))) )) diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux index 8e07a4ab4..732c5ff85 100644 --- a/stdlib/source/lux/data/collection/dictionary.lux +++ b/stdlib/source/lux/data/collection/dictionary.lux @@ -31,7 +31,7 @@ ## Represents the position of a node in a BitMap. ## It's meant to be a single bit set on a 32-bit word. ## The position of the bit reflects whether an entry in an analogous -## position exists within a #Base, as reflected in it's BitMap. +## position exists within a #Base, as reflected in its BitMap. (type: BitPosition Nat) @@ -161,13 +161,15 @@ (-> Level Level) (n.+ branching_exponent)) -(def: hierarchy_mask BitMap (dec hierarchy_nodes_size)) +(def: hierarchy_mask + BitMap + (dec hierarchy_nodes_size)) ## Gets the branching-factor sized section of the hash corresponding ## to a particular level, and uses that as an index into the array. (def: (level_index level hash) (-> Level Hash_Code Index) - (i64.and hierarchy_mask + (i64.and ..hierarchy_mask (i64.right_shift level hash))) ## A mechanism to go from indices to bit-positions. @@ -182,7 +184,10 @@ (def: (bit_position_is_set? bit bitmap) (-> BitPosition BitMap Bit) - (not (n.= clean_bitmap (i64.and bit bitmap)))) + (|> bitmap + (i64.and bit) + (n.= clean_bitmap) + not)) ## Figures out whether a bitmap only contains a single bit-position. (def: only_bit_position? @@ -210,7 +215,7 @@ (-> BitPosition BitMap) dec) -## The index on the base array, based on it's bit-position. +## The index on the base array, based on its bit-position. (def: (base_index bit_position bitmap) (-> BitPosition BitMap Index) (bitmap_size (i64.and (bit_position_mask bit_position) @@ -243,7 +248,7 @@ (list.indices (array.size h_array))))) ## When #Base nodes grow too large, they're promoted to #Hierarchy to -## add some depth to the tree and help keep it's balance. +## add some depth to the tree and help keep its balance. (def: hierarchy_indices (List Index) (list.indices hierarchy_nodes_size)) (def: (promote_base put' Hash<k> level bitmap base) @@ -287,8 +292,8 @@ (def: (put' level hash key val Hash<k> node) (All [k v] (-> Level Hash_Code k v (Hash k) (Node k v) (Node k v))) (case node - ## For #Hierarchy nodes, I check whether I can add the element to - ## a sub-node. If impossible, I introduced a new singleton sub-node. + ## For #Hierarchy nodes, check whether one can add the element to + ## a sub-node. If impossible, introduce a new singleton sub-node. (#Hierarchy _size hierarchy) (let [idx (level_index level hash) [_size' sub_node] (case (array.read idx hierarchy) @@ -301,7 +306,7 @@ (update! idx (put' (level_up level) hash key val Hash<k> sub_node) hierarchy))) - ## For #Base nodes, I check if the corresponding BitPosition has + ## For #Base nodes, check if the corresponding BitPosition has ## already been used. (#Base bitmap base) (let [bit (bit_position level hash)] @@ -309,20 +314,17 @@ ## If so... (let [idx (base_index bit bitmap)] (case (array.read idx base) - #.None - (undefined) - - ## If it's being used by a node, I add the KV to it. + ## If it's being used by a node, add the KV to it. (#.Some (#.Left sub_node)) (let [sub_node' (put' (level_up level) hash key val Hash<k> sub_node)] (#Base bitmap (update! idx (#.Left sub_node') base))) - ## Otherwise, if it's being used by a KV, I compare the keys. + ## Otherwise, if it's being used by a KV, compare the keys. (#.Some (#.Right key' val')) (if (\ Hash<k> = key key') - ## If the same key is found, I replace the value. + ## If the same key is found, replace the value. (#Base bitmap (update! idx (#.Right key val) base)) - ## Otherwise, I compare the hashes of the keys. + ## Otherwise, compare the hashes of the keys. (#Base bitmap (update! idx (#.Left (let [hash' (\ Hash<k> hash key')] (if (n.= hash hash') @@ -333,38 +335,41 @@ (#Collisions hash (|> (array.new 2) (array.write! 0 [key' val']) (array.write! 1 [key val]))) - ## Otherwise, I can + ## Otherwise, one can ## just keep using - ## #Base nodes, so I + ## #Base nodes, so ## add both KV-pairs ## to the empty one. (let [next_level (level_up level)] (|> empty (put' next_level hash' key' val' Hash<k>) (put' next_level hash key val Hash<k>)))))) - base))))) - ## However, if the BitPosition has not been used yet, I check + base))) + + #.None + (undefined))) + ## However, if the BitPosition has not been used yet, check ## whether this #Base node is ready for a promotion. (let [base_count (bitmap_size bitmap)] (if (n.>= ..promotion_threshold base_count) - ## If so, I promote it to a #Hierarchy node, and add the new + ## If so, promote it to a #Hierarchy node, and add the new ## KV-pair as a singleton node to it. (#Hierarchy (inc base_count) (|> (promote_base put' Hash<k> level bitmap base) (array.write! (level_index level hash) (put' (level_up level) hash key val Hash<k> empty)))) - ## Otherwise, I just resize the #Base node to accommodate the + ## Otherwise, just resize the #Base node to accommodate the ## new KV-pair. (#Base (set_bit_position bit bitmap) (insert! (base_index bit bitmap) (#.Right [key val]) base)))))) - ## For #Collisions nodes, I compare the hashes. + ## For #Collisions nodes, compare the hashes. (#Collisions _hash _colls) (if (n.= hash _hash) ## If they're equal, that means the new KV contributes to the ## collisions. (case (collision_index Hash<k> key _colls) - ## If the key was already present in the collisions-list, it's + ## If the key was already present in the collisions-list, its ## value gets updated. (#.Some coll_idx) (#Collisions _hash (update! coll_idx [key val] _colls)) @@ -372,7 +377,7 @@ ## Otherwise, the KV-pair is added to the collisions-list. #.None (#Collisions _hash (insert! (array.size _colls) [key val] _colls))) - ## If the hashes are not equal, I create a new #Base node that + ## If the hashes are not equal, create a new #Base node that ## contains the old #Collisions node, plus the new KV-pair. (|> (#Base (bit_position level _hash) (|> (array.new 1) @@ -417,9 +422,6 @@ (if (bit_position_is_set? bit bitmap) (let [idx (base_index bit bitmap)] (case (array.read idx base) - #.None - (undefined) - ## If set, check if it's a sub_node, and remove the KV ## from it. (#.Some (#.Left sub_node)) @@ -451,7 +453,10 @@ (#Base (unset_bit_position bit bitmap) (remove! idx base)) ## Otherwise, there's nothing to remove. - node))) + node) + + #.None + (undefined))) ## If the BitPosition is not set, there's nothing to remove. node)) @@ -486,16 +491,16 @@ (let [bit (bit_position level hash)] (if (bit_position_is_set? bit bitmap) (case (array.read (base_index bit bitmap) base) - #.None - (undefined) - (#.Some (#.Left sub_node)) (get' (level_up level) hash key Hash<k> sub_node) (#.Some (#.Right [key' val'])) (if (\ Hash<k> = key key') (#.Some val') - #.None)) + #.None) + + #.None + (undefined)) #.None)) ## For #Collisions nodes, do a linear scan of all the known KV-pairs. diff --git a/stdlib/source/lux/target/lua.lux b/stdlib/source/lux/target/lua.lux index ef646cddc..586b060a2 100644 --- a/stdlib/source/lux/target/lua.lux +++ b/stdlib/source/lux/target/lua.lux @@ -1,5 +1,7 @@ (.module: [lux (#- Location Code int if cond function or and not let ^) + ["@" target] + ["." host] [abstract [equivalence (#+ Equivalence)] [hash (#+ Hash)] @@ -25,13 +27,23 @@ [type abstract]]) -(def: input_separator ", ") -(def: statement_suffix ";") +(for {@.old (as_is (host.import: java/lang/CharSequence) + (host.import: java/lang/String + ["#::." + (replace [java/lang/CharSequence java/lang/CharSequence] java/lang/String)]))} + (as_is)) (def: nest (-> Text Text) - (|>> (format text.new_line) - (text.replace_all text.new_line (format text.new_line text.tab)))) + (.let [nested_new_line (format text.new_line text.tab)] + (for {@.old (|>> (format text.new_line) + (:coerce java/lang/String) + (java/lang/String::replace (:coerce java/lang/CharSequence text.new_line) + (:coerce java/lang/CharSequence nested_new_line)))} + (|>> (format text.new_line) + (text.replace_all text.new_line nested_new_line))))) + +(def: input_separator ", ") (abstract: #export (Code brand) Text @@ -231,7 +243,7 @@ (def: #export statement (-> Expression Statement) - (|>> :representation (text.suffix ..statement_suffix) :abstraction)) + (|>> :representation :abstraction)) (def: #export (then pre! post!) (-> Statement Statement Statement) @@ -247,39 +259,39 @@ (def: #export (local vars) (-> (List Var) Statement) - (:abstraction (format "local " (..locations vars) ..statement_suffix))) + (:abstraction (format "local " (..locations vars)))) (def: #export (set vars value) (-> (List Location) Expression Statement) - (:abstraction (format (..locations vars) " = " (:representation value) ..statement_suffix))) + (:abstraction (format (..locations vars) " = " (:representation value)))) (def: #export (let vars value) (-> (List Var) Expression Statement) - (:abstraction (format "local " (..locations vars) " = " (:representation value) ..statement_suffix))) + (:abstraction (format "local " (..locations vars) " = " (:representation value)))) (def: #export (local/1 var value) (-> Var Expression Statement) - (:abstraction (format "local " (:representation var) " = " (:representation value) ..statement_suffix))) + (:abstraction (format "local " (:representation var) " = " (:representation value)))) (def: #export (if test then! else!) (-> Expression Statement Statement Statement) (:abstraction (format "if " (:representation test) text.new_line "then" (..nest (:representation then!)) text.new_line "else" (..nest (:representation else!)) - text.new_line "end" ..statement_suffix))) + text.new_line "end"))) (def: #export (when test then!) (-> Expression Statement Statement) (:abstraction (format "if " (:representation test) text.new_line "then" (..nest (:representation then!)) - text.new_line "end" ..statement_suffix))) + text.new_line "end"))) (def: #export (while test body!) (-> Expression Statement Statement) (:abstraction (format "while " (:representation test) " do" (..nest (:representation body!)) - text.new_line "end" ..statement_suffix))) + text.new_line "end"))) (def: #export (for_in vars source body!) (-> (List Var) Expression Statement Statement) @@ -289,7 +301,7 @@ (text.join_with ..input_separator)) " in " (:representation source) " do" (..nest (:representation body!)) - text.new_line "end" ..statement_suffix))) + text.new_line "end"))) (def: #export (for_step var from to step body!) (-> Var Expression Expression Expression Statement @@ -300,11 +312,11 @@ ..input_separator (:representation to) ..input_separator (:representation step) " do" (..nest (:representation body!)) - text.new_line "end" ..statement_suffix))) + text.new_line "end"))) (def: #export (return value) (-> Expression Statement) - (:abstraction (format "return " (:representation value) ..statement_suffix))) + (:abstraction (format "return " (:representation value)))) (def: #export (closure args body!) (-> (List Var) Statement Expression) @@ -325,7 +337,7 @@ ..locations (text.enclose ["(" ")"])) (..nest (:representation body!)) - text.new_line "end" ..statement_suffix)))] + text.new_line "end")))] [function "function"] [local_function "local function"] @@ -333,9 +345,7 @@ (def: #export break Statement - (|> "break" - (text.suffix ..statement_suffix) - :abstraction)) + (:abstraction "break")) (def: #export (set_label label) (-> Label Statement) diff --git a/stdlib/source/lux/tool/compiler.lux b/stdlib/source/lux/tool/compiler.lux index c64f03ab5..eda74d121 100644 --- a/stdlib/source/lux/tool/compiler.lux +++ b/stdlib/source/lux/tool/compiler.lux @@ -12,7 +12,7 @@ ["." file (#+ Path)]]] [/ [meta - ["." archive (#+ Archive) + ["." archive (#+ Output Archive) [key (#+ Key)] [descriptor (#+ Descriptor Module)] [document (#+ Document)]]]]) @@ -29,14 +29,11 @@ #hash Nat #code Code}) -(type: #export Output - (Row [Text Binary])) - (type: #export (Compilation s d o) {#dependencies (List Module) #process (-> s Archive (Try [s (Either (Compilation s d o) - [[Descriptor (Document d)] Output])]))}) + [Descriptor (Document d) Output])]))}) (type: #export (Compiler s d o) (-> Input (Compilation s d o))) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index 70f66d8bb..993dd150d 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -245,10 +245,11 @@ #descriptor.state #.Compiled #descriptor.registry final_registry}]] (wrap [state - (#.Right [[descriptor (document.write key analysis_module)] - (|> final_buffer - (row\map (function (_ [name directive]) - [name (write_directive directive)])))])])) + (#.Right [descriptor + (document.write key analysis_module) + (row\map (function (_ [name directive]) + [name (write_directive directive)]) + final_buffer)])])) (#.Some [source requirements temporary_payload]) (let [[temporary_buffer temporary_registry] temporary_payload] diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 72642db8d..cb006d9f7 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -30,7 +30,7 @@ ["." file (#+ Path)]]] ["." // #_ ["#." init] - ["/#" // (#+ Output) + ["/#" // ["#." phase] [language [lux @@ -48,7 +48,7 @@ [analysis ["." module]]]]] [meta - ["." archive (#+ Archive) + ["." archive (#+ Output Archive) ["." artifact (#+ Registry)] ["." descriptor (#+ Descriptor Module)] ["." document (#+ Document)]] @@ -87,9 +87,9 @@ (_.and descriptor.writer (document.writer $.writer))) - (def: (cache_module static platform module_id [[descriptor document] output]) + (def: (cache_module static platform module_id [descriptor document output]) (All [<type_vars>] - (-> Static <Platform> archive.ID [[Descriptor (Document Any)] Output] + (-> Static <Platform> archive.ID [Descriptor (Document Any) Output] (Promise (Try Any)))) (let [system (get@ #&file_system platform) write_artifact! (: (-> [Text Binary] (Action Any)) @@ -142,17 +142,17 @@ (All [<type_vars>] (-> Archive <Platform> (///directive.Operation <type_vars> - [Archive [[Descriptor (Document .Module)] Output]]))) + [Archive [Descriptor (Document .Module) Output]]))) (do ///phase.monad [[registry payload] (///directive.lift_generation (..compile_runtime! platform)) - #let [descriptor,document [(..runtime_descriptor registry) ..runtime_document]] + #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 archive) + (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 archive))))] - (wrap [archive [descriptor,document payload]]))) + (archive.add archive.runtime_module [descriptor document payload] archive))))] + (wrap [archive [descriptor document payload]]))) (def: (initialize_state extender [analysers @@ -436,7 +436,7 @@ (do {! try.monad} [modules (monad.map ! (function (_ module) (do ! - [[descriptor document] (archive.find module archive) + [[descriptor document output] (archive.find module archive) lux_module (document.read $.key document)] (wrap [module lux_module]))) (archive.archived archive)) @@ -528,12 +528,12 @@ (#.Left more) (continue! [archive state] more all_dependencies) - (#.Right [[descriptor document] output]) + (#.Right [descriptor document output]) (do ! [#let [_ (debug.log! (..module_compilation_log 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] archive) + _ (..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)]) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux index 596000060..04df1bdbb 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux @@ -248,4 +248,5 @@ (bundle.install "power" lua::power) (bundle.install "import" lua::import) (bundle.install "function" python::function) + (bundle.install "script universe" (/.nullary .Bit)) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux index e619e76f8..205b12183 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux @@ -17,7 +17,7 @@ [math [number ["f" frac]]] - [target + ["@" target ["_" lua (#+ Expression)]]] ["." //// #_ ["/" bundle] @@ -50,9 +50,43 @@ (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)))) @@ -63,7 +97,7 @@ (/.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 _.bit_shl))) + (/.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 _.+))) @@ -73,7 +107,10 @@ (/.install "/" (binary (product.uncurry _.//))) (/.install "%" (binary (product.uncurry _.%))) (/.install "f64" (unary (_./ (_.float +1.0)))) - (/.install "char" (unary (!unary "string.char"))) + (/.install "char" (unary //runtime.i64//char)) + ## TODO: Use version below once the Lua compiler becomes self-hosted. + ## (/.install "char" (unary (for {@.lua (!unary "utf8.char")} + ## (!unary "string.char")))) ))) (def: f64//decode @@ -115,7 +152,10 @@ (/.install "<" (binary (product.uncurry _.<))) (/.install "concat" (binary (product.uncurry (function.flip _.concat)))) (/.install "index" (trinary ..text//index)) - (/.install "size" (unary (|>> list _.apply/* (|> (_.var "string.len"))))) + (/.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)) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux index 03600ab57..c9c5acec8 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux @@ -23,6 +23,7 @@ [generation [extension (#+ Nullary Unary Binary Trinary nullary unary binary trinary)] + ["." reference] ["//" lua #_ ["#." runtime (#+ Operation Phase Handler Bundle with_vars)]]] @@ -194,4 +195,5 @@ (/.install "power" lua::power) (/.install "import" lua::import) (/.install "function" lua::function) + (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux index 7f16a8d5f..3f64c53bf 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux @@ -53,7 +53,9 @@ (/case.if! statement expression archive if) (^ (synthesis.loop/scope scope)) - (/loop.scope! statement expression archive 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) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux index 7fc7ebbfd..46fa94dd2 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux @@ -24,6 +24,8 @@ ["#." generation] ["//#" /// #_ ["#." phase] + [meta + [archive (#+ Archive)]] [reference [variable (#+ Register)]]]]]]) @@ -31,23 +33,29 @@ (-> Nat Label) (|>> %.nat (format "scope") _.label)) -(def: (setup initial? offset bindings body) - (-> Bit Register (List Expression) Statement Statement) +(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)))] - ($_ _.then - (if initial? - (_.let variables (_.multi bindings)) - (_.set variables (_.multi bindings))) - body))) + (if as_expression? + body + ($_ _.then + (if initial? + (_.let variables (_.multi bindings)) + (_.set variables (_.multi bindings))) + body)))) -(def: #export (scope! statement expression archive [start initsS+ bodyS]) - (Generator! (Scope Synthesis)) +(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 - (statement expression archive bodyS) + (|> bodyS + (statement expression archive) + (\ ///////phase.monad map (|>> [(list)]))) ## true loop _ @@ -56,10 +64,11 @@ initsO+ (monad.map ! (expression archive) initsS+) body! (/////generation.with_anchor [start @scope] (statement expression archive bodyS))] - (wrap (..setup true start initsO+ - ($_ _.then - (_.set_label @scope) - body!)))))) + (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))) @@ -71,10 +80,10 @@ ## true loop _ (do {! ///////phase.monad} - [[[artifact_module artifact_id] scope!] (/////generation.with_new_context archive - (scope! statement expression archive [start initsS+ bodyS])) + [[[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 (|> initsS+ + locals (|> initsO+ list.enumeration (list\map (|>> product.left (n.+ start) //case.register))) [directive instantiation] (: [Statement Expression] @@ -96,14 +105,14 @@ scope!) (_.return @loop) )) - (_.apply/* foreigns @context)])))] + (|> @context (_.apply/* foreigns))])))] _ (/////generation.execute! directive) _ (/////generation.save! (%.nat artifact_id) directive)] - (wrap instantiation)))) + (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+ (_.go_to @scope))))) + (wrap (..setup false offset argsO+ false (_.go_to @scope))))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux index 46911bcc4..84db5eb1d 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux @@ -21,19 +21,19 @@ [math [number (#+ hex) ["." i64]]] - [target + ["@" target ["_" lua (#+ Expression Location Var Computation Literal Label Statement)]]] ["." /// #_ ["#." reference] ["//#" /// #_ ["#." synthesis (#+ Synthesis)] ["#." generation] - ["//#" /// (#+ Output) + ["//#" /// ["#." phase] [reference [variable (#+ Register)]] [meta - [archive (#+ Archive) + [archive (#+ Output Archive) ["." artifact (#+ Registry)]]]]]]) (template [<name> <base>] @@ -115,43 +115,48 @@ 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) - (macro.with_gensyms [g!_ runtime] - (let [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))))))))))))))) + (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) @@ -278,18 +283,41 @@ @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)))] - (_.return (|> subject - (_.bit_shr param) - (_.bit_and mask))))) + ($_ _.then + (_.set (list param) (..cap_shift param)) + (_.return (|> subject + (_.bit_shr param) + (_.bit_and mask)))))) + +## TODO: Remove this once the Lua compiler becomes self-hosted. +(def: on_rembulan? + (_.= (_.string "Lua 5.3") + (_.var "_VERSION"))) + +(runtime: (i64//char subject) + (with_expansions [<rembulan> (_.return (_.apply/1 (_.var "string.char") subject)) + <normal> (_.return (_.apply/1 (_.var "utf8.char") subject))] + (for {@.lua <normal>} + (_.if ..on_rembulan? + <rembulan> + <normal>)))) (def: runtime//i64 Statement ($_ _.then + @i64//left_shift @i64//right_shift + @i64//char )) (runtime: (text//index subject param start) @@ -305,20 +333,39 @@ (_.return (_.apply/* (list text (_.+ (_.int +1) offset) (_.+ offset length)) (_.var "string.sub")))) +(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_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))))) + (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 )) @@ -349,11 +396,11 @@ (Operation [Registry Output]) (do ///////phase.monad [_ (/////generation.execute! ..runtime) - _ (/////generation.save! "0" ..runtime)] + _ (/////generation.save! (%.nat ..module_id) ..runtime)] (wrap [(|> artifact.empty artifact.resource product.right) - (row.row ["0" + (row.row [(%.nat ..module_id) (|> ..runtime _.code (\ encoding.utf8 encode))])]))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux index 0bb5694b7..6bfd7182e 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux @@ -1,5 +1,6 @@ (.module: [lux #* + ["@" target] [data [text ["%" format (#+ format)]]]] @@ -13,10 +14,22 @@ [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"))} + #0)) + +(def: universe_label + Text + (for {@.lua (format "u" (%.nat (if ..universe 1 0)))} + "")) + (def: #export (artifact [module artifact]) (-> Context Text) - (format "lux_" - "v" (%.nat version.version) + (format "l" (%.nat version.version) + ..universe_label "m" (%.nat module) "a" (%.nat artifact))) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux index 3b12dc37a..d6d5e6d5d 100644 --- a/stdlib/source/lux/tool/compiler/meta/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -20,7 +20,8 @@ [collection ["." list ("#\." functor fold)] ["." dictionary (#+ Dictionary)] - ["." set]]] + ["." set] + ["." row (#+ Row)]]] [math [number ["n" nat ("#\." equivalence)]]] @@ -34,6 +35,9 @@ [/// [version (#+ Version)]]]) +(type: #export Output + (Row [Text Binary])) + (exception: #export (unknown_document {module Module} {known_modules (List Module)}) (exception.report @@ -69,7 +73,7 @@ (abstract: #export Archive {#next ID - #resolver (Dictionary Module [ID (Maybe [Descriptor (Document Any)])])} + #resolver (Dictionary Module [ID (Maybe [Descriptor (Document Any) Output])])} (def: next (-> Archive ID) @@ -106,17 +110,17 @@ (update@ #..next inc) :abstraction)])))) - (def: #export (add module [descriptor document] archive) - (-> Module [Descriptor (Document Any)] Archive (Try Archive)) + (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])])) + (update@ #..resolver (dictionary.put module [id (#.Some [descriptor document output])])) :abstraction)) - (#.Some [id (#.Some [existing_descriptor existing_document])]) + (#.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) @@ -126,11 +130,11 @@ (exception.throw ..module_must_be_reserved_before_it_can_be_added [module])))) (def: #export (find module archive) - (-> Module Archive (Try [Descriptor (Document Any)])) + (-> Module Archive (Try [Descriptor (Document Any) Output])) (let [(^slots [#..resolver]) (:representation archive)] (case (dictionary.get module resolver) - (#.Some [id (#.Some document)]) - (#try.Success document) + (#.Some [id (#.Some entry)]) + (#try.Success entry) (#.Some [id #.None]) (exception.throw ..module_is_only_reserved [module]) diff --git a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux index 05d75c129..2a9389235 100644 --- a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux +++ b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux @@ -16,7 +16,7 @@ ["." dictionary (#+ Dictionary)] ["." set (#+ Set)]]]] [/// - ["." archive (#+ Archive) + ["." archive (#+ Output Archive) [key (#+ Key)] ["." descriptor (#+ Module Descriptor)] ["." document (#+ Document)]]]) @@ -79,7 +79,7 @@ (set.member? target_ancestry source))) (type: #export Order - (List [Module [archive.ID [Descriptor (Document .Module)]]])) + (List [Module [archive.ID [Descriptor (Document .Module) Output]]])) (def: #export (load_order key archive) (-> (Key .Module) Archive (Try Order)) @@ -91,6 +91,6 @@ (function (_ module) (do try.monad [module_id (archive.id module archive) - [descriptor document] (archive.find module archive) + [descriptor document output] (archive.find module archive) document (document.check key document)] - (wrap [module [module_id [descriptor document]]]))))))) + (wrap [module [module_id [descriptor document output]]]))))))) diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux index a755d2bec..a00c5c50b 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -35,7 +35,7 @@ ["." // (#+ Context) ["#." context] ["/#" // - ["." archive (#+ Archive) + ["." archive (#+ Output Archive) ["." artifact (#+ Artifact)] ["." descriptor (#+ Module Descriptor)] ["." document (#+ Document)]] @@ -180,7 +180,7 @@ [modules (: (Try (List [Module .Module])) (monad.map ! (function (_ module) (do ! - [[descriptor document] (archive.find module archive) + [[descriptor document output] (archive.find module archive) content (document.read $.key document)] (wrap [module content]))) (archive.archived archive)))] @@ -323,17 +323,17 @@ (wrap [(document.write $.key (set@ #.definitions definitions content)) bundles]))) -(def: (load_definitions system static module_id host_environment [descriptor document]) +(def: (load_definitions system static module_id host_environment [descriptor document output]) (All [expression directive] (-> (file.System Promise) Static archive.ID (generation.Host expression directive) - [Descriptor (Document .Module)] - (Promise (Try [[Descriptor (Document .Module)] + [Descriptor (Document .Module) Output] + (Promise (Try [[Descriptor (Document .Module) Output] Bundles])))) (do (try.with promise.monad) [actual (cached_artifacts system 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] bundles]))) + (wrap [[descriptor document output] bundles]))) (def: (purge! system static [module_name module_id]) (-> (file.System Promise) Static [Module archive.ID] (Promise (Try Any))) @@ -358,7 +358,7 @@ (Dictionary Module archive.ID)) (def: initial_purge - (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module)]]]]) + (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]]) Purge) (|>> (list.all (function (_ [valid_cache? [module_name [module_id _]]]) (if valid_cache? @@ -367,10 +367,10 @@ (dictionary.from_list text.hash))) (def: (full_purge caches load_order) - (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module)]]]]) + (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module) Output]]]]) dependency.Order Purge) - (list\fold (function (_ [module_name [module_id [descriptor document]]] purge) + (list\fold (function (_ [module_name [module_id [descriptor document output]]] purge) (let [purged? (: (Predicate Module) (dictionary.key? purge))] (if (purged? module_name) @@ -397,16 +397,16 @@ [descriptor document] (promise\wrap (<b>.run ..parser data))] (if (text\= archive.runtime_module module_name) (wrap [true - [module_name [module_id [descriptor document]]]]) + [module_name [module_id [descriptor document (: Output row.empty)]]]]) (do ! [input (//context.read system import contexts (get@ #static.host_module_extension static) module_name)] (wrap [(..valid_cache? descriptor input) - [module_name [module_id [descriptor document]]]]))))))) + [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]] archive) - (archive.add module descriptor,document archive)) + (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) @@ -416,12 +416,12 @@ dictionary.entries (monad.map ! (..purge! system static))) loaded_caches (|> load_order - (list.filter (function (_ [module_name [module_id [descriptor document]]]) + (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]]) + (monad.map ! (function (_ [module_name [module_id descriptor,document,output]]) (do ! - [[descriptor,document bundles] (..load_definitions system static module_id host_environment descriptor,document)] - (wrap [[module_name descriptor,document] + [[descriptor,document,output bundles] (..load_definitions system static module_id host_environment descriptor,document,output)] + (wrap [[module_name descriptor,document,output] bundles])))))] (promise\wrap (do {! try.monad} diff --git a/stdlib/source/lux/tool/compiler/meta/packager.lux b/stdlib/source/lux/tool/compiler/meta/packager.lux index c29d0d9ed..fff07d28f 100644 --- a/stdlib/source/lux/tool/compiler/meta/packager.lux +++ b/stdlib/source/lux/tool/compiler/meta/packager.lux @@ -25,8 +25,8 @@ [lux [generation (#+ Context)]]]]]) -(type: #export (Packager !) - (-> (Monad !) (file.System !) Static Archive Context (! (Try Binary)))) +(type: #export Packager + (-> Archive Context (Try Binary))) (type: #export Order (List [archive.ID (List artifact.ID)])) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/script.lux index bf4b2315f..c874cfd88 100644 --- a/stdlib/source/lux/tool/compiler/meta/packager/script.lux +++ b/stdlib/source/lux/tool/compiler/meta/packager/script.lux @@ -9,6 +9,7 @@ ["!" capability]]] [data [binary (#+ Binary)] + ["." product] [text ["%" format (#+ format)] ["." encoding]] @@ -22,7 +23,7 @@ ["." static (#+ Static)]]] ["." // (#+ Packager) [// - ["." archive + ["." archive (#+ Output) ["." descriptor] ["." artifact]] [cache @@ -38,51 +39,45 @@ (type: (Action ! a) (! (Try a))) -(def: (write_artifact monad file_system static context) - (All [!] - (-> (Monad !) (file.System !) Static Context - (Action ! Binary))) - (do (try.with monad) - [artifact (let [[module artifact] context] - (!.use (\ file_system file) [(io.artifact file_system static module (%.nat artifact))]))] - (!.use (\ artifact content) []))) - -(def: (write_module monad file_system static sequence [module artifacts] so_far) - (All [! directive] - (-> (Monad !) (file.System !) Static (-> directive directive directive) [archive.ID (List artifact.ID)] directive - (Action ! directive))) - (monad.fold (:assume (try.with monad)) - (function (_ artifact so_far) - (do (try.with monad) - [content (..write_artifact monad file_system static [module artifact]) - content (\ monad wrap (\ encoding.utf8 decode content))] - (wrap (sequence so_far - (:share [directive] - {directive - so_far} - {directive - (:assume content)}))))) - so_far - artifacts)) +(def: (write_module sequence [module artifacts output] so_far) + (All [directive] + (-> (-> directive directive directive) [archive.ID (List artifact.ID) Output] directive + (Try directive))) + (|> output + row.to_list + (list\map product.right) + (monad.fold try.monad + (function (_ content so_far) + (|> content + (\ encoding.utf8 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] + (All [directive] (-> directive (-> directive Text) (-> directive directive directive) (-> directive directive) - (Packager !))) - (function (package monad file_system static archive program) - (do {! (try.with monad)} - [cache (!.use (\ file_system directory) [(get@ #static.target static)]) - order (\ monad wrap (dependency.load_order $.key archive))] + Packager)) + (function (package archive program) + (do {! try.monad} + [order (dependency.load_order $.key archive)] (|> order - (list\map (function (_ [module [module_id [descriptor document]]]) + (list\map (function (_ [module [module_id [descriptor document output]]]) [module_id (|> descriptor (get@ #descriptor.registry) artifact.artifacts row.to_list - (list\map (|>> (get@ #artifact.id))))])) - (monad.fold ! (..write_module monad file_system static sequence) header) + (list\map (|>> (get@ #artifact.id)))) + output])) + (monad.fold ! (..write_module sequence) header) (\ ! map (|>> scope to_code (\ encoding.utf8 encode))))))) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index 63325ff0b..a66022594 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -74,32 +74,38 @@ (def: (package! monad file_system [packager package] static archive context) (All [!] (-> (Monad !) (file.System !) [Packager Path] Static Archive Context (! (Try Any)))) (for {@.old - (do (try.with monad) - [#let [packager (:share [!] {(Monad !) monad} {(Packager !) packager})] - content (packager monad file_system static archive context) - package (:share [!] - {(Monad !) - monad} - {(! (Try (File !))) - (:assume (file.get_file monad file_system package))})] - (!.use (\ (:share [!] - {(Monad !) - monad} - {(File !) - (:assume package)}) - over_write) - [content]))} + (case (packager archive context) + (#try.Success content) + (do (try.with monad) + [package (:share [!] + {(Monad !) + monad} + {(! (Try (File !))) + (:assume (file.get_file monad file_system package))})] + (!.use (\ (:share [!] + {(Monad !) + monad} + {(File !) + (:assume package)}) + over_write) + [content])) + + (#try.Failure error) + (\ monad wrap (#try.Failure error)))} ## TODO: Fix whatever type_checker bug is forcing me into this compromise... (:assume (: (Promise (Try Any)) (let [monad (:coerce (Monad Promise) monad) - file_system (:coerce (file.System Promise) file_system) - packager (:coerce (Packager Promise) packager)] - (do (try.with monad) - [content (packager monad file_system static archive context) - package (: (Promise (Try (File Promise))) - (file.get_file monad file_system package))] - (!.use (\ (: (File Promise) package) over_write) [content]))))))) + file_system (:coerce (file.System Promise) file_system)] + (case (packager archive context) + (#try.Success content) + (do (try.with monad) + [package (: (Promise (Try (File Promise))) + (file.get_file monad file_system package))] + (!.use (\ (: (File Promise) package) over_write) [content])) + + (#try.Failure error) + (\ monad wrap (#try.Failure error)))))))) (with_expansions [<parameters> (as_is anchor expression artifact)] (def: #export (compiler static diff --git a/stdlib/source/test/lux/host.lua.lux b/stdlib/source/test/lux/host.lua.lux new file mode 100644 index 000000000..0b6cac81b --- /dev/null +++ b/stdlib/source/test/lux/host.lua.lux @@ -0,0 +1,24 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try]] + [data + ["." text ("#\." equivalence)]] + [math + ["." random (#+ Random)] + [number + ["." nat] + ["." frac]]]] + {1 + ["." /]}) + +(def: #export test + Test + (do {! random.monad} + [] + (<| (_.covering /._) + (_.test "TBD" + true)))) |