Added packaging machinery for the JVM compiler.

6 files changed, 177 insertions, 42 deletions

diff --git a/new-luxc/source/luxc/lang/packager.lux b/new-luxc/source/luxc/lang/packager.lux
new file mode 100644
index 000000000..3f8cb36cb
--- /dev/null
+++ b/new-luxc/source/luxc/lang/packager.lux
@@ -0,0 +1,112 @@
+(.module:
+  [lux #*
+   ["." host (#+ import: do-to)]
+   [data
+    ["." binary (#+ Binary)]
+    ["." text]
+    [number
+     ["n" nat]]
+    [collection
+     ["." row]
+     ["." list ("#@." fold)]]]
+   [target
+    [jvm
+     [encoding
+      ["." name]]]]
+   [tool
+    [compiler
+     [phase
+      [generation (#+ Buffer Output)]]
+     [meta
+      [archive
+       [descriptor (#+ Module)]]]]]]
+  [//
+   [host
+    [jvm (#+ Definition)]]])
+
+(import: #long java/lang/Object)
+
+(import: #long java/lang/String)
+
+(import: #long java/util/jar/Attributes
+  (put [java/lang/Object java/lang/Object] #? java/lang/Object))
+
+(import: #long java/util/jar/Attributes$Name
+  (#static MAIN_CLASS java/util/jar/Attributes$Name)
+  (#static MANIFEST_VERSION java/util/jar/Attributes$Name))
+
+(import: #long java/util/jar/Manifest
+  (new [])
+  (getMainAttributes [] java/util/jar/Attributes))
+
+(import: #long java/io/Flushable
+  (flush [] void))
+
+(import: #long java/io/Closeable
+  (close [] void))
+
+(import: #long java/io/OutputStream)
+
+(import: #long java/io/ByteArrayOutputStream
+  (new [int])
+  (toByteArray [] [byte]))
+
+(import: #long java/util/zip/ZipEntry)
+
+(import: #long java/util/zip/ZipOutputStream
+  (write [[byte] int int] void)
+  (closeEntry [] void))
+
+(import: #long java/util/jar/JarEntry
+  (new [java/lang/String]))
+
+(import: #long java/util/jar/JarOutputStream
+  (new [java/io/OutputStream java/util/jar/Manifest])
+  (putNextEntry [java/util/zip/ZipEntry] void))
+
+(def: byte 1)
+(def: kilo-byte (n.* 1,000 byte))
+(def: mega-byte (n.* 1,000 kilo-byte))
+
+(def: manifest-version "1.0")
+
+(def: class-name
+  (-> Module Text)
+  (text.suffix ".class"))
+
+(def: main "_")
+
+(def: (manifest module)
+  (-> Module java/util/jar/Manifest)
+  (let [manifest (java/util/jar/Manifest::new)]
+    (exec (do-to (java/util/jar/Manifest::getMainAttributes manifest)
+            (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MAIN_CLASS) ..main)
+            (java/util/jar/Attributes::put (java/util/jar/Attributes$Name::MANIFEST_VERSION) ..manifest-version))
+      manifest)))
+
+(def: (write-class [def-name [class-name bytecode]] sink)
+  (-> [Name Definition] java/util/jar/JarOutputStream java/util/jar/JarOutputStream)
+  (let [class-name (|> class-name name.internal name.read ..class-name)]
+    (do-to sink
+      (java/util/jar/JarOutputStream::putNextEntry (java/util/jar/JarEntry::new class-name))
+      (java/util/zip/ZipOutputStream::write bytecode +0 (.int (binary.size bytecode)))
+      (java/io/Flushable::flush)
+      (java/util/zip/ZipOutputStream::closeEntry))))
+
+(def: (write-module [module classes] sink)
+  (-> [Module (Buffer Definition)] java/util/jar/JarOutputStream java/util/jar/JarOutputStream)
+  (|> classes
+      row.to-list
+      (list@fold ..write-class sink)))
+
+(def: #export (package module outputs)
+  (-> Module (Output Definition) Binary)
+  (let [buffer (java/io/ByteArrayOutputStream::new (.int mega-byte))
+        sink (java/util/jar/JarOutputStream::new buffer (manifest module))]
+    (exec (|> outputs
+              row.to-list
+              (list@fold ..write-module sink))
+      (do-to sink
+        (java/io/Flushable::flush)
+        (java/io/Closeable::close))
+      (java/io/ByteArrayOutputStream::toByteArray buffer))))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
index d616d62e9..f97831ac5 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
@@ -322,7 +322,7 @@
 (def: reflection (|>> type.reflection reflection.reflection))
 
 (def: translate-runtime
-  (Operation ByteCode)
+  (Operation Any)
   (let [runtime-class (..reflection //.$Runtime)
         bytecode ($d.class #$.V1_6 #$.Public $.finalC runtime-class (list) (type.class "java.lang.Object" (list)) (list)
                            (|>> adt-methods
@@ -331,10 +331,10 @@
                                 io-methods))]
     (do phase.monad
       [_ (generation.execute! runtime-class [runtime-class bytecode])]
-      (wrap bytecode))))
+      (generation.save! false ["" runtime-class] [runtime-class bytecode]))))
 
 (def: translate-function
-  (Operation ByteCode)
+  (Operation Any)
   (let [applyI (|> (list.n/range 2 num-apply-variants)
                    (list@map (function (_ arity)
                                ($d.method #$.Public $.noneM apply-method (apply-signature arity)
@@ -363,7 +363,7 @@
                                    applyI))]
     (do phase.monad
       [_ (generation.execute! function-class [function-class bytecode])]
-      (wrap bytecode))))
+      (generation.save! false ["" function-class] [function-class bytecode]))))
 
 (def: #export translate
   (Operation Any)
diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux
index f22d9ef58..dd44128df 100644
--- a/new-luxc/source/program.lux
+++ b/new-luxc/source/program.lux
@@ -10,6 +10,8 @@
     [parser
      [cli (#+ program:)]]]
    [data
+    [text
+     ["%" format (#+ format)]]
     [collection
      [array (#+ Array)]
      ["." dictionary]]]
@@ -32,6 +34,7 @@
     ["/." cli]]]
   [luxc
    [lang
+    ["." packager]
     [host
      ["_" jvm
       ["$d" def]
@@ -132,8 +135,8 @@
                                      $i.SWAP
                                      ($i.GOTO @loop)
                                      ($i.label @end)
-                                     $i.POP
-                                     ($i.ASTORE 0)))
+                                     $i.POP))
+        feed-inputsI ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1))
         run-ioI (|>> ($i.CHECKCAST jvm.$Function)
                      $i.NULL
                      ($i.INVOKEVIRTUAL jvm.$Function runtime.apply-method (runtime.apply-signature 1)))
@@ -148,19 +151,24 @@
                (list) $Object
                (list)
                (|>> ($d.method #_.Public _.staticM "main" main-type
-                               (|>> prepare-input-listI
-                                    programI
+                               (|>> programI
+                                    prepare-input-listI
+                                    feed-inputsI
                                     run-ioI
-                                    $i.POP
                                     $i.RETURN))))]))
 
 (program: [{service /cli.service}]
-  (/.compiler @.jvm
-              ".jvm"
-              ..expander
-              analysis.bundle
-              ..platform
-              translation.bundle
-              directive.bundle
-              ..program
-              service))
+  (let [(^slots [#/cli.target #/cli.module]) (case service
+                                               (#/cli.Compilation configuration) configuration
+                                               (#/cli.Interpretation configuration) configuration)
+        jar-path (format target (:: file.system separator) "program.jar")]
+    (/.compiler @.jvm
+                ".jvm"
+                ..expander
+                analysis.bundle
+                ..platform
+                translation.bundle
+                directive.bundle
+                ..program
+                service
+                [(packager.package module) jar-path])))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 4ed6d6d42..04937092a 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -24,7 +24,7 @@
      [macro (#+ Expander)]
      ## TODO: Get rid of this import ASAP
      [extension (#+)]
-     ["." generation]
+     ["." generation (#+ Buffer)]
      [analysis
       ["." module]]]
     [meta
@@ -67,8 +67,26 @@
           (///directive.Bundle anchor expression directive)
           (-> expression directive)
           (! (Try <State+>))))
-    (|> platform
-        (get@ #runtime)
+    (|> (do ///phase.monad
+          [_ (:share [anchor expression directive]
+                     {(///directive.Bundle anchor expression directive)
+                      host-directive-bundle}
+                     {(generation.Operation anchor expression directive Any)
+                      (generation.set-buffer (:share [anchor expression directive]
+                                                     {(///directive.Bundle anchor expression directive)
+                                                      host-directive-bundle}
+                                                     {(Buffer directive)
+                                                      generation.empty-buffer}))})
+           _ (:share [anchor expression directive]
+                     {(///directive.Bundle anchor expression directive)
+                      host-directive-bundle}
+                     {(generation.Operation anchor expression directive Any)
+                      (get@ #runtime platform)})]
+          (:share [anchor expression directive]
+                  {(///directive.Bundle anchor expression directive)
+                   host-directive-bundle}
+                  {(generation.Operation anchor expression directive Any)
+                   (generation.save-buffer! "")}))
         ///directive.lift-generation
         (///phase.run' (//init.state target
                                      expander
diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/js.lux
index 8e7988f37..e4c52af5a 100644
--- a/stdlib/source/lux/tool/compiler/meta/packager/script.lux
+++ b/stdlib/source/lux/tool/compiler/meta/packager/js.lux
@@ -1,7 +1,8 @@
 (.module:
   [lux #*
    [control
-    [pipe (#+ case>)]]
+    [pipe (#+ case>)]
+    ["." function]]
    [data
     [binary (#+ Binary)]
     ["." product]
@@ -18,21 +19,15 @@
       [generation (#+ Output)]]]]])
 
 (def: #export (package outputs)
-  (All [statements]
-    (-> (Output statements) Binary))
+  (-> (Output _.Statement) Binary)
   (|> outputs
       row.to-list
-      (list@map (function (_ [module buffer])
-                  (|> buffer
-                      row.to-list
-                      (:coerce (List [Name _.Statement]))
-                      (list@map product.right))))
+      (list@map (|>> product.right
+                     row.to-list
+                     (list@map product.right)))
       list@join
       (case> (#.Cons head tail)
-             (|> (list@fold (function (_ post! pre!)
-                              (_.then pre! post!))
-                            head
-                            tail)
+             (|> (list@fold (function.flip _.then) head tail)
                  (: _.Statement)
                  _.code
                  encoding.to-utf8)
diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux
index 1725e80e5..b9b2995ad 100644
--- a/stdlib/source/program/compositor.lux
+++ b/stdlib/source/program/compositor.lux
@@ -11,6 +11,7 @@
     [security
      ["!" capability]]]
    [data
+    [binary (#+ Binary)]
     ["." product]
     ["." text
      ["%" format (#+ format)]]
@@ -21,7 +22,7 @@
    [time
     ["." instant (#+ Instant)]]
    [world
-    ["." file (#+ File)]
+    ["." file (#+ File Path)]
     ["." console]]
    [tool
     [compiler
@@ -34,9 +35,7 @@
       ["." platform (#+ Platform)]
       ["." syntax]]
      [meta
-      ["." archive (#+ Archive)]
-      [packager
-       ["." script]]]]
+      ["." archive (#+ Archive)]]]
     ## ["." interpreter]
     ]]
   [/
@@ -57,10 +56,11 @@
       (#try.Success output)
       (wrap output))))
 
-(def: (save-artifacts! system state)
+(def: (save-artifacts! system state [packager package])
   (All [anchor expression directive]
     (-> (file.System IO)
         (directive.State+ anchor expression directive)
+        [(-> (generation.Output directive) Binary) Path]
         (IO (Try Any))))
   (let [?outcome (phase.run' state
                              (:share [anchor expression directive]
@@ -73,13 +73,14 @@
       (#try.Success [state output])
       (do (try.with io.monad)
         [file (: (IO (Try (File IO)))
-                 (file.get-file io.monad system "program.js"))]
-        (!.use (:: file over-write) (script.package output)))
+                 (file.get-file io.monad system package))]
+        (!.use (:: file over-write) (packager output)))
 
       (#try.Failure error)
       (:: io.monad wrap (#try.Failure error)))))
 
-(def: #export (compiler target partial-host-extension expander host-analysis platform generation-bundle host-directive-bundle program service)
+(def: #export (compiler target partial-host-extension expander host-analysis platform generation-bundle host-directive-bundle program service
+                        packager,package)
   (All [anchor expression directive]
     (-> Text
         Text
@@ -90,6 +91,7 @@
         (directive.Bundle anchor expression directive)
         (-> expression directive)
         Service
+        [(-> (generation.Output directive) Binary) Path]
         (IO Any)))
   (do io.monad
     [platform platform
@@ -108,7 +110,7 @@
                                       platform}
                                      {(IO (Try [Archive (directive.State+ anchor expression directive)]))
                                       (platform.compile partial-host-extension expander platform configuration archive.empty state)})
-             _ (save-artifacts! (get@ #platform.&file-system platform) state)
+             _ (save-artifacts! (get@ #platform.&file-system platform) state packager,package)
              ## _ (cache/io.clean target ...)
              ]
             (wrap (log! "Compilation complete!"))))