From 38c2eb5d39838e415a8c1f51b79099086b391a22 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sun, 30 May 2021 19:33:34 -0400
Subject: Giving up on Kawa for now...

---
 lux-scheme/commands.md                             |   2 +
 lux-scheme/source/program.lux                      |  29 ++---
 stdlib/source/lux/target/scheme.lux                |   3 +-
 .../lux/phase/extension/analysis/scheme.lux        |   7 +-
 .../lux/phase/extension/generation/scheme/host.lux |   1 +
 .../language/lux/phase/generation/reference.lux    |   7 +-
 .../source/lux/tool/compiler/meta/io/archive.lux   |   2 +-
 .../lux/tool/compiler/meta/packager/scheme.lux     | 133 +++++++++++++++++++++
 .../lux/tool/compiler/meta/packager/script.lux     |  12 +-
 9 files changed, 158 insertions(+), 38 deletions(-)
 create mode 100644 stdlib/source/lux/tool/compiler/meta/packager/scheme.lux

diff --git a/lux-scheme/commands.md b/lux-scheme/commands.md
index 7c915200c..11d6e2945 100644
--- a/lux-scheme/commands.md
+++ b/lux-scheme/commands.md
@@ -26,5 +26,7 @@ cd ~/lux/stdlib/ \
 && time java -jar ~/lux/lux-scheme/target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux
 
 clear && time kawa ~/lux/stdlib/target/program.scm
+
+clear && time kawa ~/lux/stdlib/target/program/1.scm
 ```
 
diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux
index 24d26945d..d71daa6e7 100644
--- a/lux-scheme/source/program.lux
+++ b/lux-scheme/source/program.lux
@@ -25,6 +25,8 @@
     [number (#+ hex)
      ["n" nat]
      ["." i64]]]
+   [time
+    ["." instant]]
    ["." world #_
     ["." file]
     ["#/." program]]
@@ -57,7 +59,7 @@
       ["." platform (#+ Platform)]]
      [meta
       ["." packager #_
-       ["#" script]]]]]]
+       ["#" scheme]]]]]]
   [program
    ["/" compositor
     ["#." cli]
@@ -442,24 +444,11 @@
   (-> Any (Promise Any))
   (promise.future (\ world/program.default exit +0)))
 
-(def: (then pre post)
-  (-> _.Expression _.Expression _.Expression)
-  (_.manual (format (_.code pre)
-                    text.new_line
-                    (_.code post))))
-
-(def: (scope body)
-  (-> _.Expression _.Expression)
-  (let [@program (_.var "lux_program")]
-    ($_ ..then
-        (_.define_function @program [(list) #.None] body)
-        (_.apply/* (list) @program)
-        )))
-
 (`` (program: [{service /cli.service}]
       (let [extension ".scm"]
         (do io.monad
-          [platform ..platform]
+          [platform ..platform
+           now instant.now]
           (exec (do promise.monad
                   [_ (/.compiler {#/static.host @.scheme
                                   #/static.host_module_extension extension
@@ -474,13 +463,9 @@
                                  [_.Var _.Expression _.Expression]
                                  ..extender
                                  service
-                                 [(packager.package (_.manual "")
-                                                    _.code
-                                                    ..then
-                                                    ..scope)
+                                 [(packager.package now)
                                   (format (/cli.target service)
                                           (\ file.default separator)
-                                          "program"
-                                          extension)])]
+                                          "program.tar")])]
                   (..declare_success! []))
             (io.io []))))))
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)))))))
-- 
cgit v1.2.3