Caching compiler artifacts into TAR files, instead of huge directories.

1 files changed, 251 insertions, 62 deletions

diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux
index 474a267a3..d6cd14da5 100644
--- a/stdlib/source/program/compositor.lux
+++ b/stdlib/source/program/compositor.lux
@@ -16,7 +16,11 @@
     ["[0]" text (.only)
      ["%" \\format (.only format)]]
     [collection
-     ["[0]" dictionary (.only Dictionary)]]]
+     ["[0]" dictionary (.only Dictionary)]
+     ["[0]" sequence (.use "[1]#[0]" monoid mix)]
+     ["[0]" list (.use "[1]#[0]" mix)]]
+    [format
+     ["[0]" tar (.only Tar)]]]
    [meta
     [type (.only sharing)]
     ["@" target]
@@ -37,12 +41,12 @@
          ["[0]E" synthesis]]]]]
      [meta
       [packager (.only Packager)]
-      [context (.only Context)]
+      ["[0]" context (.only Context)]
       ["[0]" cli (.only Service)]
       ["[0]" import]
       ["[0]" export]
-      ["[0]" cache
-       ["[1]" archive]]
+      ["[0]" cache (.only)
+       ["[1]/[0]" archive]]
       [archive (.only Archive)
        ["[0]" unit]
        [module
@@ -52,15 +56,17 @@
     ... ["[0]" interpreter]
     ]
    ["[0]" world
-    ["[0]" file]
     ["[0]" console]
     ["[1]/[0]" environment]
+    ["[0]" file (.only)
+     ["[1]/[0]" extension]]
     [time
      ["[0]" instant]]]]])
 
 (def (or_crash! failure_description action)
-  (All (_ a)
-    (-> Text (Async (Try a)) (Async a)))
+  (All (_ of)
+    (-> Text (Async (Try of))
+        (Async of)))
   (do [! async.monad]
     [?output action]
     (when ?output
@@ -85,8 +91,9 @@
       (in output))))
 
 (def (timed process)
-  (All (_ a)
-    (-> (Async (Try a)) (Async (Try a))))
+  (All (_ of)
+    (-> (Async (Try of))
+        (Async (Try of))))
   (do async.monad
     [.let [start (io.run! instant.now)]
      output process
@@ -96,27 +103,31 @@
                              (format "Duration: ")))]]
     (in output)))
 
-(def (package! fs host_dependencies [packager package] archive context)
-  (-> (file.System Async) (Dictionary file.Path Binary) [Packager file.Path] Archive (Maybe unit.ID) (Async (Try Any)))
-  (when (packager host_dependencies archive context)
-    {try.#Success content}
-    (when content
-      {.#Left content}
-      (of fs write package content)
+(def (package! file_context fs host_dependencies [packager package] archive context)
+  (-> Context (file.System Async) (Dictionary file.Path Binary) [Packager file.Path] Archive (Maybe unit.ID)
+      (Async (Try Any)))
+  (let [target_root (the context.#target file_context)
+        package (file.rooted fs target_root package)]
+    (when (packager host_dependencies archive context)
+      {try.#Success content}
+      (when content
+        {.#Left content}
+        (of fs write package content)
+        
+        {.#Right content}
+        (do [! (try.with async.monad)]
+          [_ (of fs make_directory package)
+           _ (monad.each ! (function (_ [name content])
+                             (of fs write (file.rooted fs package name) content))
+                         content)]
+          (in [])))
       
-      {.#Right content}
-      (do [! (try.with async.monad)]
-        [_ (of fs make_directory package)
-         _ (monad.each ! (function (_ [name content])
-                           (of fs write (file.rooted fs package name) content))
-                       content)]
-        (in [])))
-    
-    {try.#Failure error}
-    (of async.monad in {try.#Failure error})))
+      {try.#Failure error}
+      (of async.monad in {try.#Failure error}))))
 
 (def (load_host_dependencies fs host_dependencies)
-  (-> (file.System Async) (List file.Path) (Async (Try (Dictionary file.Path Binary))))
+  (-> (file.System Async) (List file.Path)
+      (Async (Try (Dictionary file.Path Binary))))
   (do [! (try.with async.monad)]
     []
     (loop (again [pending host_dependencies
@@ -132,7 +143,172 @@
           (again tail
                  (dictionary.has head content output)))))))
 
+(def (hybrid_fs cache host)
+  (-> (file.System Async) (file.System Async)
+      (file.System Async))
+  (`` (implementation
+       (def separator
+         (of host separator))
+       (,, (with_template [<name>]
+             [(def (<name> path)
+                (do async.monad
+                  [?/0 (of cache <name> path)
+                   ?/1 (of host <name> path)]
+                  (in (or ?/0 ?/1))))]
+
+             [file?]
+             [directory?]
+             ))
+       (,, (with_template [<name>]
+             [(def <name>
+                (of cache <name>))]
+
+             [make_directory]
+             [directory_files]
+             [sub_directories]
+             
+             [file_size]
+             [last_modified]
+             [can_execute?]
+             [delete]
+             ))
+       (def (read path)
+         (do async.monad
+           [it (of cache read path)]
+           (when it
+             {try.#Failure _}
+             (of host read path)
+             
+             _
+             (in it))))
+       (,, (with_template [<name>]
+             [(def <name>
+                (of cache <name>))]
+             
+             [modify]
+             [write]
+             [append]
+             [move]
+             ))
+       )))
+
+(def cache_mode
+  tar.Mode
+  (all tar.and
+       tar.execute_by_other
+       tar.write_by_other
+       tar.read_by_other
+
+       tar.execute_by_group
+       tar.write_by_group
+       tar.read_by_group
+
+       tar.execute_by_owner
+       tar.write_by_owner
+       tar.read_by_owner
+
+       tar.save_text
+       tar.set_group_id_on_execution
+       tar.set_user_id_on_execution
+       ))
+
+(def (cache_tar context fs)
+  (-> Context (file.System Async)
+      (Async (Try Tar)))
+  (loop (again [root (cache.path fs context)])
+    (do [! (try.with async.monad)]
+      [files (of fs directory_files root)
+       subs (of fs sub_directories root)
+       files (monad.each ! (function (_ path)
+                             (do !
+                               [content (of fs read path)
+                                [path content] (async#in (do try.monad
+                                                           [path (tar.path path)
+                                                            content (tar.content content)]
+                                                           (in [path content])))]
+                               (in {tar.#Normal [path instant.epoch ..cache_mode tar.no_ownership content]})))
+                         files)
+       subs (monad.each ! again subs)]
+      (in (list#mix sequence#composite
+                    (sequence.of_list files)
+                    subs)))))
+
+(def (cache_path fs context)
+  (-> (file.System Async) Context
+      file.Path)
+  (%.format (the context.#target context)
+            (of fs separator)
+            (the context.#host context)
+            file/extension.tape_archive))
+
+(def (cached_file_path fs full_path)
+  (-> (file.System Async) file.Path
+      [file.Path file.Path])
+  (<| maybe.trusted
+      (do maybe.monad
+        [.let [/ (of fs separator)]
+         @ (text.last_index / full_path)
+         [directory file] (text.split_at @ full_path)]
+        (in [directory (text.replaced_once / "" file)]))))
+
 (with_expansions [<parameters> (these anchor expression artifact)]
+  (def (load_cache! host_fs cache_fs context)
+    (-> (file.System Async) (file.System Async) Context
+        (Async (Try Any)))
+    (do [! async.monad]
+      [tar (of host_fs read (cache_path host_fs context))]
+      (when tar
+        {try.#Failure _}
+        (in {try.#Success []})
+
+        {try.#Success tar}
+        (do [! (try.with !)]
+          [tar (async#in (of tar.codec decoded tar))
+           _ (sequence#mix (function (_ entry then)
+                             (when entry
+                               {tar.#Normal [path instant mode ownership content]}
+                               (do !
+                                 [_ then
+                                  .let [path (tar.from_path path)
+                                        directory (maybe.else path (file.parent cache_fs path))]
+                                  _ (is (Async (Try Any))
+                                        (file.make_directories async.monad cache_fs directory))]
+                                 (of cache_fs write path (tar.data content)))
+
+                               _
+                               then))
+                           (in [])
+                           tar)]
+          (in [])))))
+
+  (def (cache! original_fs context platform)
+    (All (_ <parameters>)
+      (-> (file.System Async) Context (Platform <parameters>)
+          (Async (Try Any))))
+    (do (try.with async.monad)
+      [cache (cache_tar context (the platform.#file_system platform))]
+      (of original_fs write
+          (cache_path original_fs context)
+          (of tar.codec encoded cache))))
+
+  (def (with_caching it)
+    (All (_ <parameters>)
+      (-> (Platform <parameters>)
+          [(file.System Async) (Platform <parameters>)]))
+    (let [cache_fs (file.mock (of (the platform.#file_system it) separator))
+          it (revised platform.#file_system (hybrid_fs cache_fs) it)]
+      [cache_fs it]))
+
+  (def (enable_output! original_fs context)
+    (-> (file.System Async) Context
+        (Async (Try Any)))
+    (let [target_root (the context.#target context)]
+      (do async.monad
+        [? (of original_fs directory? target_root)]
+        (if ?
+          (in {try.#Success []})
+          (of original_fs make_directory target_root)))))
+  
   (def .public (compiler lux_compiler file_context
                          expander host_analysis platform translation_bundle host_declaration_bundle program global extender
                          service
@@ -156,8 +332,12 @@
         {cli.#Compilation compilation}
         (<| (or_crash! "Compilation failed:")
             ..timed
-            (do (try.with async.monad)
-              [import (import.import (the platform.#file_system platform) (the cli.#libraries compilation))
+            (do [! (try.with !)]
+              [.let [original_fs (the platform.#file_system platform)
+                     [cache_fs platform] (with_caching platform)]
+               _ (enable_output! original_fs file_context)
+               _ (load_cache! original_fs cache_fs file_context)
+               import (import.import (the platform.#file_system platform) (the cli.#libraries compilation))
                .let [all_extensions [(analysisE.bundle host_analysis)
                                      synthesisE.bundle
                                      translation_bundle
@@ -178,40 +358,48 @@
                                                                                      (the cli.#sources compilation)
                                                                                      (the cli.#configuration compilation)
                                                                                      all_extensions))))
-               [archive state] (sharing [<parameters>]
-                                 (is (Platform <parameters>)
-                                     platform)
-                                 (is (Async (Try [Archive (declaration.State <parameters>)]))
-                                     (as_expected (platform.compile program
-                                                                    global
-                                                                    lux_compiler
-                                                                    phase_wrapper
-                                                                    import
-                                                                    file_context
-                                                                    extender
-                                                                    expander
-                                                                    platform
-                                                                    compilation
-                                                                    [archive state]
-                                                                    all_extensions))))
-               _ (cache.cache! (the platform.#file_system platform) (the cli.#configuration compilation) file_context archive)
-               host_dependencies (..load_host_dependencies (the platform.#file_system platform)
-                                                           (the cli.#host_dependencies compilation))
-
-               _ (..package! (for @.old (file.async file.default)
-                                  @.jvm (file.async file.default)
-                                  ... TODO: Handle this in a safer manner.
-                                  ... This would crash if the compiler was run on a browser.
-                                  @.js (maybe.trusted file.default))
-                             host_dependencies
-                             packager,package
-                             archive
-                             (try.maybe ($/program.context archive)))]
-              (in (debug.log! "Compilation complete!"))))
+               archive,state (do async.monad
+                               [archive,state (sharing [<parameters>]
+                                                (is (Platform <parameters>)
+                                                    platform)
+                                                (is (Async (Try [Archive (declaration.State <parameters>)]))
+                                                    (as_expected (platform.compile program
+                                                                                   global
+                                                                                   lux_compiler
+                                                                                   phase_wrapper
+                                                                                   import
+                                                                                   file_context
+                                                                                   extender
+                                                                                   expander
+                                                                                   platform
+                                                                                   compilation
+                                                                                   [archive state]
+                                                                                   all_extensions))))]
+                               (in {try.#Success archive,state}))]
+              (when archive,state
+                {try.#Success [archive state]}
+                (do !
+                  [_ (cache/archive.cache! (the platform.#file_system platform) (the cli.#configuration compilation) file_context archive)
+                   _ (cache! original_fs file_context platform)
+                   host_dependencies (..load_host_dependencies (the platform.#file_system platform)
+                                                               (the cli.#host_dependencies compilation))
+
+                   _ (..package! file_context
+                                 original_fs
+                                 host_dependencies
+                                 packager,package
+                                 archive
+                                 (try.maybe ($/program.context archive)))]
+                  (in (debug.log! "Compilation complete!")))
+
+                {try.#Failure error}
+                (do !
+                  [_ (cache! original_fs file_context platform)]
+                  (async#in {try.#Failure error})))))
 
         {cli.#Export export}
         (<| (or_crash! "Export failed:")
-            (do (try.with async.monad)
+            (do (try.with !)
               [_ (export.export (the platform.#file_system platform)
                    export)]
               (in (debug.log! "Export complete!"))))
@@ -220,9 +408,10 @@
         ... TODO: Fix the interpreter...
         (undefined)
         ... (<| (or_crash! "Interpretation failed:")
-        ...     (do [! async.monad]
+        ...     (do !
         ...       [console (|> console.default
         ...                    async.future
         ...                    (of ! each (|>> try.trusted console.async)))]
         ...       (interpreter.run! (try.with async.monad) console platform interpretation translation_bundle)))
-        ))))
+        )))
+  )