aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2021-02-12 02:19:43 -0400
committerEduardo Julian2021-02-12 02:19:43 -0400
commitee3240679a7c1c4d216b35e1d2db1544e5c16863 (patch)
treec0f03fe917c77ce5c6413782ba116006bc84ea7c
parenta5e2f99430384fff580646a553b1e8ae27e07acd (diff)
More Lua + optimizations.
Diffstat
-rw-r--r--compilers.md2
-rw-r--r--lux-lua/source/program.lux765
-rw-r--r--stdlib/source/lux/control/concurrency/thread.lux49
-rw-r--r--stdlib/source/lux/data/collection/dictionary.lux71
-rw-r--r--stdlib/source/lux/target/lua.lux48
-rw-r--r--stdlib/source/lux/tool/compiler.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/default/init.lux9
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux26
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/lua.lux1
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/common.lux48
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/lua/host.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/loop.lux49
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/lua/runtime.lux143
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux22
-rw-r--r--stdlib/source/lux/tool/compiler/meta/cache/dependency.lux8
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/archive.lux34
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager/script.lux67
-rw-r--r--stdlib/source/program/compositor.lux50
-rw-r--r--stdlib/source/test/lux/host.lua.lux24
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))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 01:41:09 +0000