diff options
Diffstat (limited to 'stdlib/source/program')
| -rw-r--r-- | stdlib/source/program/compositor.lux | 313 |
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))) - )))) + ))) + ) |