aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/program
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/program')
-rw-r--r--stdlib/source/program/compositor.lux313
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)))
- ))))
+ )))
+ )