path: root/stdlib/source/library/lux/tool/compiler/meta/io/archive.lux

(.module:
  [library
   [lux {"-" [Module]}
    [target {"+" [Target]}]
    [abstract
     [predicate {"+" [Predicate]}]
     ["[0]" monad {"+" [do]}]]
    [control
     [pipe {"+" [case>]}]
     ["[0]" try {"+" [Try]}]
     ["[0]" exception {"+" [exception:]}]
     [concurrency
      ["[0]" async {"+" [Async]} ("[1]\[0]" monad)]]
     ["<>" parser
      ["<[0]>" binary {"+" [Parser]}]]]
    [data
     [binary {"+" [Binary]}]
     ["[0]" product]
     ["[0]" text ("[1]\[0]" equivalence)
      ["%" format {"+" [format]}]]
     [collection
      ["[0]" list ("[1]\[0]" functor mix)]
      ["[0]" dictionary {"+" [Dictionary]}]
      ["[0]" row {"+" [Row]}]
      ["[0]" set]]]
    [math
     [number
      ["n" nat]]]
    [world
     ["[0]" file]]]]
  [program
   [compositor
    [import {"+" [Import]}]
    ["[0]" static {"+" [Static]}]]]
  ["[0]" // {"+" [Context]}
   ["[1][0]" context]
   ["/[1]" //
    ["[0]" archive {"+" [Output Archive]}
     ["[0]" artifact {"+" [Artifact]}]
     ["[0]" descriptor {"+" [Module Descriptor]}]
     ["[0]" document {"+" [Document]}]]
    [cache
     ["[0]" dependency]]
    ["/[1]" // {"+" [Input]}
     [language
      ["$" lux
       ["[0]" version]
       ["[0]" analysis]
       ["[0]" synthesis]
       ["[0]" generation]
       ["[0]" directive]
       ["[1]/[0]" program]]]]]])

(exception: .public (cannot_prepare [archive file.Path
                                     module_id archive.ID
                                     error Text])
  (exception.report
   ["Archive" archive]
   ["Module ID" (%.nat module_id)]
   ["Error" error]))

(def: (archive fs static)
  (All (_ !) (-> (file.System !) Static file.Path))
  (format (value@ #static.target static)
          (\ fs separator)
          (value@ #static.host static)))

(def: (unversioned_lux_archive fs static)
  (All (_ !) (-> (file.System !) Static file.Path))
  (format (..archive fs static)
          (\ fs separator)
          //.lux_context))

(def: (versioned_lux_archive fs static)
  (All (_ !) (-> (file.System !) Static file.Path))
  (format (..unversioned_lux_archive fs static)
          (\ fs separator)
          (%.nat version.version)))

(def: (module fs static module_id)
  (All (_ !) (-> (file.System !) Static archive.ID file.Path))
  (format (..versioned_lux_archive fs static)
          (\ fs separator)
          (%.nat module_id)))

(def: .public (artifact fs static module_id artifact_id)
  (All (_ !) (-> (file.System !) Static archive.ID artifact.ID file.Path))
  (format (..module fs static module_id)
          (\ fs separator)
          (%.nat artifact_id)
          (value@ #static.artifact_extension static)))

(def: (ensure_directory fs path)
  (-> (file.System Async) file.Path (Async (Try Any)))
  (do async.monad
    [? (\ fs directory? path)]
    (if ?
      (in {#try.Success []})
      (\ fs make_directory path))))

(def: .public (prepare fs static module_id)
  (-> (file.System Async) Static archive.ID (Async (Try Any)))
  (do [! async.monad]
    [.let [module (..module fs static module_id)]
     module_exists? (\ fs directory? module)]
    (if module_exists?
      (in {#try.Success []})
      (do (try.with !)
        [_ (ensure_directory fs (..unversioned_lux_archive fs static))
         _ (ensure_directory fs (..versioned_lux_archive fs static))]
        (|> module
            (\ fs make_directory)
            (\ ! each (|>> (case> {#try.Success output}
                                  {#try.Success []}

                                  {#try.Failure error}
                                  (exception.except ..cannot_prepare [(..archive fs static)
                                                                      module_id
                                                                      error])))))))))

(def: .public (write fs static module_id artifact_id content)
  (-> (file.System Async) Static archive.ID artifact.ID Binary (Async (Try Any)))
  (\ fs write content (..artifact fs static module_id artifact_id)))

(def: .public (enable fs static)
  (-> (file.System Async) Static (Async (Try Any)))
  (do (try.with async.monad)
    [_ (..ensure_directory fs (value@ #static.target static))]
    (..ensure_directory fs (..archive fs static))))

(def: (general_descriptor fs static)
  (-> (file.System Async) Static file.Path)
  (format (..archive fs static)
          (\ fs separator)
          "general_descriptor"))

(def: .public (freeze fs static archive)
  (-> (file.System Async) Static Archive (Async (Try Any)))
  (\ fs write (archive.export ///.version archive) (..general_descriptor fs static)))

(def: module_descriptor_file
  "module_descriptor")

(def: (module_descriptor fs static module_id)
  (-> (file.System Async) Static archive.ID file.Path)
  (format (..module fs static module_id)
          (\ fs separator)
          ..module_descriptor_file))

(def: .public (cache fs static module_id content)
  (-> (file.System Async) Static archive.ID Binary (Async (Try Any)))
  (\ fs write content (..module_descriptor fs static module_id)))

(def: (read_module_descriptor fs static module_id)
  (-> (file.System Async) Static archive.ID (Async (Try Binary)))
  (\ fs read (..module_descriptor fs static module_id)))

(def: parser
  (Parser [Descriptor (Document .Module)])
  (<>.and descriptor.parser
          (document.parser $.parser)))

(def: (fresh_analysis_state host)
  (-> Target .Lux)
  (analysis.state (analysis.info version.version host)))

(def: (analysis_state host archive)
  (-> Target Archive (Try .Lux))
  (do [! try.monad]
    [modules (: (Try (List [Module .Module]))
                (monad.each ! (function (_ module)
                                (do !
                                  [[descriptor document output] (archive.find module archive)
                                   content (document.read $.key document)]
                                  (in [module content])))
                            (archive.archived archive)))]
    (in (with@ #.modules modules (fresh_analysis_state host)))))

(def: (cached_artifacts fs static module_id)
  (-> (file.System Async) Static archive.ID (Async (Try (Dictionary Text Binary))))
  (let [! (try.with async.monad)]
    (|> (..module fs static module_id)
        (\ fs directory_files)
        (\ ! each (|>> (list\each (function (_ file)
                                    [(file.name fs file) file]))
                       (list.only (|>> product.left (text\= ..module_descriptor_file) not))
                       (monad.each ! (function (_ [name path])
                                       (|> path
                                           (\ fs read)
                                           (\ ! each (|>> [name])))))
                       (\ ! each (dictionary.of_list text.hash))))
        (\ ! conjoint))))

(type: Definitions (Dictionary Text Any))
(type: Analysers (Dictionary Text analysis.Handler))
(type: Synthesizers (Dictionary Text synthesis.Handler))
(type: Generators (Dictionary Text generation.Handler))
(type: Directives (Dictionary Text directive.Handler))

(type: Bundles
  [Analysers
   Synthesizers
   Generators
   Directives])

(def: empty_bundles
  Bundles
  [(dictionary.empty text.hash)
   (dictionary.empty text.hash)
   (dictionary.empty text.hash)
   (dictionary.empty text.hash)])

(def: (loaded_document extension host module_id expected actual document)
  (All (_ expression directive)
    (-> Text (generation.Host expression directive) archive.ID (Row Artifact) (Dictionary Text Binary) (Document .Module)
        (Try [(Document .Module) Bundles Output])))
  (do [! try.monad]
    [[definitions bundles] (: (Try [Definitions Bundles Output])
                              (loop [input (row.list expected)
                                     definitions (: Definitions
                                                    (dictionary.empty text.hash))
                                     bundles ..empty_bundles
                                     output (: Output row.empty)]
                                (let [[analysers synthesizers generators directives] bundles]
                                  (case input
                                    {#.Item [[artifact_id artifact_category] input']}
                                    (case (do !
                                            [data (try.of_maybe (dictionary.value (format (%.nat artifact_id) extension) actual))
                                             .let [context [module_id artifact_id]
                                                   directive (\ host ingest context data)]]
                                            (case artifact_category
                                              #artifact.Anonymous
                                              (do !
                                                [.let [output (row.suffix [artifact_id #.None data] output)]
                                                 _ (\ host re_learn context #.None directive)]
                                                (in [definitions
                                                     [analysers
                                                      synthesizers
                                                      generators
                                                      directives]
                                                     output]))
                                              
                                              {#artifact.Definition name}
                                              (let [output (row.suffix [artifact_id #.None data] output)]
                                                (if (text\= $/program.name name)
                                                  (in [definitions
                                                       [analysers
                                                        synthesizers
                                                        generators
                                                        directives]
                                                       output])
                                                  (do !
                                                    [value (\ host re_load context #.None directive)]
                                                    (in [(dictionary.has name value definitions)
                                                         [analysers
                                                          synthesizers
                                                          generators
                                                          directives]
                                                         output]))))

                                              {#artifact.Analyser extension}
                                              (do !
                                                [.let [output (row.suffix [artifact_id #.None data] output)]
                                                 value (\ host re_load context #.None directive)]
                                                (in [definitions
                                                     [(dictionary.has extension (:as analysis.Handler value) analysers)
                                                      synthesizers
                                                      generators
                                                      directives]
                                                     output]))

                                              {#artifact.Synthesizer extension}
                                              (do !
                                                [.let [output (row.suffix [artifact_id #.None data] output)]
                                                 value (\ host re_load context #.None directive)]
                                                (in [definitions
                                                     [analysers
                                                      (dictionary.has extension (:as synthesis.Handler value) synthesizers)
                                                      generators
                                                      directives]
                                                     output]))

                                              {#artifact.Generator extension}
                                              (do !
                                                [.let [output (row.suffix [artifact_id #.None data] output)]
                                                 value (\ host re_load context #.None directive)]
                                                (in [definitions
                                                     [analysers
                                                      synthesizers
                                                      (dictionary.has extension (:as generation.Handler value) generators)
                                                      directives]
                                                     output]))

                                              {#artifact.Directive extension}
                                              (do !
                                                [.let [output (row.suffix [artifact_id #.None data] output)]
                                                 value (\ host re_load context #.None directive)]
                                                (in [definitions
                                                     [analysers
                                                      synthesizers
                                                      generators
                                                      (dictionary.has extension (:as directive.Handler value) directives)]
                                                     output]))

                                              {#artifact.Custom name}
                                              (do !
                                                [.let [output (row.suffix [artifact_id {#.Some name} data] output)]
                                                 _ (\ host re_learn context {#.Some name} directive)]
                                                (in [definitions
                                                     [analysers
                                                      synthesizers
                                                      generators
                                                      directives]
                                                     output]))))
                                      {#try.Success [definitions' bundles' output']}
                                      (recur input' definitions' bundles' output')

                                      failure
                                      failure)
                                    
                                    #.End
                                    {#try.Success [definitions bundles output]}))))
     content (document.read $.key document)
     definitions (monad.each ! (function (_ [def_name def_global])
                                 (case def_global
                                   (^template [<tag>]
                                     [{<tag> payload}
                                      (in [def_name {<tag> payload}])])
                                   ([#.Alias]
                                    [#.Label]
                                    [#.Slot])
                                   
                                   {#.Definition [exported? type _]}
                                   (|> definitions
                                       (dictionary.value def_name)
                                       try.of_maybe
                                       (\ ! each (|>> [exported? type]
                                                      {#.Definition}
                                                      [def_name])))

                                   {#.Type [exported? _ labels]}
                                   (|> definitions
                                       (dictionary.value def_name)
                                       try.of_maybe
                                       (\ ! each (function (_ def_value)
                                                   [def_name {#.Type [exported? (:as .Type def_value) labels]}])))))
                             (value@ #.definitions content))]
    (in [(document.write $.key (with@ #.definitions definitions content))
         bundles])))

(def: (load_definitions fs static module_id host_environment descriptor document)
  (All (_ expression directive)
    (-> (file.System Async) Static archive.ID (generation.Host expression directive)
        Descriptor (Document .Module)
        (Async (Try [[Descriptor (Document .Module) Output]
                     Bundles]))))
  (do (try.with async.monad)
    [actual (cached_artifacts fs static module_id)
     .let [expected (|> descriptor (value@ #descriptor.registry) artifact.artifacts)]
     [document bundles output] (async\in (loaded_document (value@ #static.artifact_extension static) host_environment module_id expected actual document))]
    (in [[descriptor document output] bundles])))

(def: (purge! fs static [module_name module_id])
  (-> (file.System Async) Static [Module archive.ID] (Async (Try Any)))
  (do [! (try.with async.monad)]
    [.let [cache (..module fs static module_id)]
     _ (|> cache
           (\ fs directory_files)
           (\ ! each (monad.each ! (\ fs delete)))
           (\ ! conjoint))]
    (\ fs delete cache)))

(def: (valid_cache? expected actual)
  (-> Descriptor Input Bit)
  (and (text\= (value@ #descriptor.name expected)
               (value@ #////.module actual))
       (text\= (value@ #descriptor.file expected)
               (value@ #////.file actual))
       (n.= (value@ #descriptor.hash expected)
            (value@ #////.hash actual))))

(type: Purge
  (Dictionary Module archive.ID))

(def: initial_purge
  (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module)]]]])
      Purge)
  (|>> (list.all (function (_ [valid_cache? [module_name [module_id _]]])
                   (if valid_cache?
                     #.None
                     {#.Some [module_name module_id]})))
       (dictionary.of_list text.hash)))

(def: (full_purge caches load_order)
  (-> (List [Bit [Module [archive.ID [Descriptor (Document .Module)]]]])
      dependency.Order
      Purge)
  (list\mix (function (_ [module_name [module_id [descriptor document]]] purge)
              (let [purged? (: (Predicate Module)
                               (dictionary.key? purge))]
                (if (purged? module_name)
                  purge
                  (if (|> descriptor
                          (value@ #descriptor.references)
                          set.list
                          (list.any? purged?))
                    (dictionary.has module_name module_id purge)
                    purge))))
            (..initial_purge caches)
            load_order))

(def: pseudo_module
  Text
  "(Lux Caching System)")

(def: (load_every_reserved_module host_environment fs static import contexts archive)
  (All (_ expression directive)
    (-> (generation.Host expression directive) (file.System Async) Static Import (List Context) Archive
        (Async (Try [Archive .Lux Bundles]))))
  (do [! (try.with async.monad)]
    [pre_loaded_caches (|> archive
                           archive.reservations
                           (monad.each ! (function (_ [module_name module_id])
                                           (do !
                                             [data (..read_module_descriptor fs static module_id)
                                              [descriptor document] (async\in (<binary>.result ..parser data))]
                                             (if (text\= archive.runtime_module module_name)
                                               (in [true
                                                    [module_name [module_id [descriptor document]]]])
                                               (do !
                                                 [input (//context.read fs ..pseudo_module import contexts (value@ #static.host_module_extension static) module_name)]
                                                 (in [(..valid_cache? descriptor input)
                                                      [module_name [module_id [descriptor document]]]])))))))
     load_order (|> pre_loaded_caches
                    (list\each product.right)
                    (monad.mix try.monad
                               (function (_ [module [module_id [descriptor document]]] archive)
                                 (archive.has module [descriptor document (: Output row.empty)] archive))
                               archive)
                    (\ try.monad each (dependency.load_order $.key))
                    (\ try.monad conjoint)
                    async\in)
     .let [purge (..full_purge pre_loaded_caches load_order)]
     _ (|> purge
           dictionary.entries
           (monad.each ! (..purge! fs static)))
     loaded_caches (|> load_order
                       (list.only (|>> product.left (dictionary.key? purge) not))
                       (monad.each ! (function (_ [module_name [module_id [descriptor document _]]])
                                       (do !
                                         [[descriptor,document,output bundles] (..load_definitions fs static module_id host_environment descriptor document)]
                                         (in [[module_name descriptor,document,output]
                                              bundles])))))]
    (async\in
     (do [! try.monad]
       [archive (monad.mix !
                           (function (_ [[module descriptor,document,output] _bundle] archive)
                             (archive.has module descriptor,document,output archive))
                           archive
                           loaded_caches)
        analysis_state (..analysis_state (value@ #static.host static) archive)]
       (in [archive
            analysis_state
            (list\mix (function (_ [_ [+analysers +synthesizers +generators +directives]]
                                   [analysers synthesizers generators directives])
                        [(dictionary.merged +analysers analysers)
                         (dictionary.merged +synthesizers synthesizers)
                         (dictionary.merged +generators generators)
                         (dictionary.merged +directives directives)])
                      ..empty_bundles
                      loaded_caches)])))))

(def: .public (thaw host_environment fs static import contexts)
  (All (_ expression directive)
    (-> (generation.Host expression directive) (file.System Async) Static Import (List Context)
        (Async (Try [Archive .Lux Bundles]))))
  (do async.monad
    [binary (\ fs read (..general_descriptor fs static))]
    (case binary
      {#try.Success binary}
      (do (try.with async.monad)
        [archive (async\in (archive.import ///.version binary))]
        (..load_every_reserved_module host_environment fs static import contexts archive))
      
      {#try.Failure error}
      (in {#try.Success [archive.empty
                         (fresh_analysis_state (value@ #static.host static))
                         ..empty_bundles]}))))