diff options
Diffstat (limited to '')
7 files changed, 149 insertions, 16 deletions
diff --git a/stdlib/source/lux/target/scheme.lux b/stdlib/source/lux/target/scheme.lux index 408f1d9f1..651fca21d 100644 --- a/stdlib/source/lux/target/scheme.lux +++ b/stdlib/source/lux/target/scheme.lux @@ -224,7 +224,8 @@ [reverse/1 "reverse"] [display/1 "display"] [exit/1 "exit"] - [string-length/1 "string-length"]]] + [string-length/1 "string-length"] + [load-relative/1 "load-relative"]]] [apply/2 [_0 _1] [Expression Expression] [[append/2 "append"] diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux index ef13cb2ef..86db4170f 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux @@ -1,6 +1,6 @@ (.module: [lux #* - ["." host] + ["." ffi] [abstract ["." monad (#+ do)]] [control @@ -108,11 +108,11 @@ (def: Nil (for {@.scheme - host.Nil} + ffi.Nil} Any)) (def: Function - (for {@.scheme host.Function} + (for {@.scheme ffi.Function} Any)) (def: bundle::object @@ -153,4 +153,5 @@ (bundle.install "constant" scheme::constant) (bundle.install "apply" scheme::apply) + (bundle.install "script universe" (/.nullary .Bit)) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux index 55e46ad23..6072d29e5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux @@ -104,4 +104,5 @@ (/.install "constant" scheme::constant) (/.install "apply" scheme::apply) + (/.install "script universe" (nullary (function.constant (_.bool reference.universe)))) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux index bd1db66bf..9cca8b8e5 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 @@ -22,7 +22,9 @@ ## Cannot make all definitions be local variables because of limitations with JRuby. @.ruby (not ("ruby script universe")) ## Cannot make all definitions be local variables because of limitations with PHP itself. - @.php (not ("php script universe"))} + @.php (not ("php script universe")) + ## Cannot make all definitions be local variables because of limitations with Kawa. + @.scheme (not ("scheme script universe"))} #0)) (def: universe_label @@ -30,7 +32,8 @@ (with_expansions [<label> (format "u" (%.nat (if ..universe 1 0)))] (for {@.lua <label> @.ruby <label> - @.php <label>} + @.php <label> + @.scheme <label>} ""))) (def: #export (artifact [module artifact]) diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux index a00c5c50b..3ff972838 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -193,7 +193,7 @@ cached_files (!.use (\ module_dir files) [])] (|> cached_files (list\map (function (_ file) - [(!.use (\ file name) []) + [(file.name system (!.use (\ file path) [])) (!.use (\ file path) [])])) (list.filter (|>> product.left (text\= ..module_descriptor_file) not)) (monad.map ! (function (_ [name path]) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux b/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux new file mode 100644 index 000000000..64d7418eb --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/packager/scheme.lux @@ -0,0 +1,133 @@ +(.module: + [lux (#- Module) + [type (#+ :share)] + [abstract + ["." monad (#+ Monad do)]] + [control + ["." try (#+ Try)] + [security + ["!" capability]]] + [data + [binary (#+ Binary)] + ["." product] + ["." text + ["%" format (#+ format)] + ["." encoding]] + [collection + ["." row] + ["." list ("#\." functor fold)] + ["." dictionary (#+ Dictionary)] + ["." set]] + [format + ["." tar] + ["." binary]]] + [target + ["_" scheme]] + [time + ["." instant (#+ Instant)]] + [world + ["." file (#+ Path File Directory)]]] + [program + [compositor + ["." static (#+ Static)]]] + ["." // (#+ Packager) + [// + ["." archive (#+ Output) + ["." descriptor (#+ Module Descriptor)] + ["." artifact] + ["." document (#+ Document)]] + [cache + ["." dependency]] + ["." io #_ + ["#" archive]] + [// + [language + ["$" lux + [generation (#+ Context)]]]]]]) + +## TODO: Delete ASAP +(type: (Action ! a) + (! (Try a))) + +(def: (then pre post) + (-> _.Expression _.Expression _.Expression) + (_.manual (format (_.code pre) + text.new_line + (_.code post)))) + +(def: bundle_module + (-> Output (Try _.Expression)) + (|>> row.to_list + (list\map product.right) + (monad.fold try.monad + (function (_ content so_far) + (|> content + (\ encoding.utf8 decode) + (\ try.monad map + (|>> :assume + (:share [directive] + directive + so_far + + directive) + (..then so_far))))) + (: _.Expression (_.manual ""))))) + +(def: module_file + (-> archive.ID Path) + (|>> %.nat (text.suffix ".scm"))) + +(def: mode + tar.Mode + ($_ tar.and + tar.read_by_group + tar.read_by_owner + + tar.write_by_other + tar.write_by_group + tar.write_by_owner)) + +(def: owner + tar.Owner + {#tar.name tar.anonymous + #tar.id tar.no_id}) + +(def: ownership + {#tar.user ..owner + #tar.group ..owner}) + +(def: (write_module now mapping [module [module_id [descriptor document output]]]) + (-> Instant (Dictionary Module archive.ID) + [Module [archive.ID [Descriptor (Document .Module) Output]]] + (Try tar.Entry)) + (do {! try.monad} + [bundle (: (Try _.Expression) + (..bundle_module output)) + entry_content (: (Try tar.Content) + (|> descriptor + (get@ #descriptor.references) + set.to_list + (list.all (function (_ module) (dictionary.get module mapping))) + (list\map (|>> ..module_file _.string _.load-relative/1)) + (list\fold ..then bundle) + (: _.Expression) + _.code + (\ encoding.utf8 encode) + tar.content)) + module_file (tar.path (..module_file module_id))] + (wrap (#tar.Normal [module_file now ..mode ..ownership entry_content])))) + +(def: #export (package now) + (-> Instant Packager) + (function (package archive program) + (do {! try.monad} + [order (dependency.load_order $.key archive) + #let [mapping (|> order + (list\map (function (_ [module [module_id [descriptor document output]]]) + [module module_id])) + (dictionary.from_list text.hash) + (: (Dictionary Module archive.ID)))] + entries (monad.map ! (..write_module now mapping) order)] + (wrap (|> entries + row.from_list + (binary.run tar.writer)))))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/script.lux index 95026ae37..e8685ce2b 100644 --- a/stdlib/source/lux/tool/compiler/meta/packager/script.lux +++ b/stdlib/source/lux/tool/compiler/meta/packager/script.lux @@ -39,9 +39,9 @@ (type: (Action ! a) (! (Try a))) -(def: (write_module sequence [module artifacts output] so_far) +(def: (write_module sequence [module output] so_far) (All [directive] - (-> (-> directive directive directive) [archive.ID (List artifact.ID) Output] directive + (-> (-> directive directive directive) [archive.ID Output] directive (Try directive))) (|> output row.to_list @@ -73,12 +73,6 @@ [order (dependency.load_order $.key archive)] (|> order (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)))) - output])) + [module_id output])) (monad.fold ! (..write_module sequence) header) (\ ! map (|>> scope to_code (\ encoding.utf8 encode))))))) |