aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2021-05-30 19:33:34 -0400
committerEduardo Julian2021-05-30 19:33:34 -0400
commit38c2eb5d39838e415a8c1f51b79099086b391a22 (patch)
tree6d4ad65a1741340e6763353de06ecec7f3a12b2c /stdlib/source
parent7a2ab85f1c86e7256c5b45672b2fe8f157e35c9a (diff)
Giving up on Kawa for now...
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/target/scheme.lux3
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux1
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/reference.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/archive.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager/scheme.lux133
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager/script.lux12
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)))))))