path: root/stdlib/source/program/compositor.lux

... This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
... If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/.

(.require
 [library
  [lux (.except Module)
   ["[0]" debug]
   [abstract
    ["[0]" monad (.only Monad do)]]
   [control
    ["[0]" io (.only IO io)]
    ["[0]" maybe]
    ["[0]" try (.only Try)]
    [concurrency
     ["[0]" async (.only Async) (.use "[1]#[0]" monad)]]]
   [data
    [binary (.only Binary)]
    ["[0]" product]
    ["[0]" text (.only)
     ["%" \\format (.only format)]]
    [collection
     ["[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)]
    ["[0]" compiler
     ["@" target]
     [default
      ["[0]" platform (.only Platform)]]
     [language
      ["$" lux (.only)
       ["[1]/[0]" program (.only Program)]
       ["[0]" syntax]
       ["[0]" translation]
       ["[0]" declaration]
       ["[0]" analysis (.only)
        [macro (.only Expander)]]
       ["[0]" phase (.only)
        [extension (.only Extender)
         ["[0]E" analysis]
         ["[0]E" synthesis]]]]]
     [meta
      [packager (.only Packager)]
      ["[0]" context (.only Context)]
      ["[0]" cli (.only Service)]
      ["[0]" import]
      ["[0]" export]
      ["[0]" cache (.only)
       ["[1]/[0]" archive]]
      [archive (.only Archive)
       ["[0]" unit]
       [module
        [descriptor (.only Module)]]]
      [io
       ["ioW" archive]]]]
    ... ["[0]" interpreter]
    ]
   ["[0]" world
    ["[0]" console]
    ["[1]/[0]" environment]
    ["[0]" file (.only)
     ["[1]/[0]" extension]]
    [time
     ["[0]" instant]]]]])

(def (or_crash! failure_description action)
  (All (_ of)
    (-> Text (Async (Try of))
        (Async of)))
  (do [! async.monad]
    [?output action]
    (when ?output
      {try.#Failure error}
      (let [report (format text.new_line
                           failure_description text.new_line
                           error text.new_line)]
        (do !
          [_ (with_expansions [<else> (in {try.#Success (debug.log! report)})]
               (for @.js (is (Async (Try Any))
                             (when console.default
                               {.#None}
                               <else>

                               {.#Some console}
                               (console.write_line report console)))
                    (is (Async (Try Any))
                        <else>)))]
          (io.run! (of world/environment.default exit +1))))

      {try.#Success output}
      (in output))))

(def (timed process)
  (All (_ of)
    (-> (Async (Try of))
        (Async (Try of))))
  (do async.monad
    [.let [start (io.run! instant.now)]
     output process
     .let [_ (debug.log! (|> (io.run! instant.now)
                             (instant.span start)
                             %.duration
                             (format "Duration: ")))]]
    (in output)))

(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 [])))
      
      {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))))
  (do [! (try.with async.monad)]
    []
    (loop (again [pending host_dependencies
                  output (is (Dictionary file.Path Binary)
                             (dictionary.empty text.hash))])
      (when pending
        {.#End}
        (in output)

        {.#Item head tail}
        (do !
          [content (of fs read head)]
          (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
       ))

(type (Action of)
  (Async (Try of)))

(def monad
  (is (Monad Action)
      (as_expected (try.with async.monad))))

(def (cache_tar_entry fs path)
  (-> (file.System Async) file.Path
      (Action tar.Entry))
  (do async.monad
    [content (of fs read path)]
    (in (do try.monad
          [content content
           path (tar.path path)
           content (tar.content content)]
          (in {tar.#Normal [path instant.epoch ..cache_mode tar.no_ownership content]})))))

(def (cache_tar context fs)
  (-> Context (file.System Async)
      (Action Tar))
  (loop (again [root (cache.path fs context)])
    (do [! ..monad]
      [files (of fs directory_files root)
       subs (of fs sub_directories root)
       files (monad.each ! (cache_tar_entry fs) 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
                         packager,package)
    (All (_ <parameters>)
      (-> (-> Any platform.Custom)
          Context
          Expander
          analysis.Bundle
          (IO (Platform <parameters>))
          (translation.Bundle <parameters>)
          (declaration.Bundle <parameters>)
          (Program expression artifact) (-> Archive Symbol (translation.Operation <parameters> expression))
          Extender
          Service
          [Packager file.Path]
          (Async Any)))
    (do [! async.monad]
      [platform (async.future platform)]
      (when service
        {cli.#Compilation compilation}
        (<| (or_crash! "Compilation failed:")
            ..timed
            (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
                                     host_declaration_bundle]]
               [state archive phase_wrapper] (sharing [<parameters>]
                                               (is (Platform <parameters>)
                                                   platform)
                                               (is (Async (Try [(declaration.State <parameters>)
                                                                Archive
                                                                phase.Wrapper]))
                                                   (as_expected (platform.initialize file_context
                                                                                     (the cli.#module compilation)
                                                                                     expander
                                                                                     platform
                                                                                     program
                                                                                     extender
                                                                                     import
                                                                                     (the cli.#sources compilation)
                                                                                     (the cli.#configuration compilation)
                                                                                     all_extensions))))
               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 !)
              [_ (export.export (the platform.#file_system platform)
                   export)]
              (in (debug.log! "Export complete!"))))
        
        {cli.#Interpretation interpretation}
        ... TODO: Fix the interpreter...
        (undefined)
        ... (<| (or_crash! "Interpretation failed:")
        ...     (do !
        ...       [console (|> console.default
        ...                    async.future
        ...                    (of ! each (|>> try.trusted console.async)))]
        ...       (interpreter.run! (try.with async.monad) console platform interpretation translation_bundle)))
        )))
  )