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

(.using
 [library
  [lux "*"
   [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]" sequence {"+" Sequence}]
     ["[0]" set {"+" Set}]]]
   [math
    [number
     ["n" nat]]]
   [world
    ["[0]" file]]]]
 ["[0]" //
  ["[1][0]" context]
  ["/[1]" //
   [import {"+" Import}]
   ["[0]" context {"+" Context}]
   ["[0]" archive {"+" Output Archive}
    ["[0]" registry {"+" Registry}]
    ["[0]" unit]
    ["[0]" artifact {"+" Artifact}
     ["[0]" category {"+" Category}]]
    ["[0]" module
     ["[0]" descriptor {"+" Descriptor}]
     ["[0]" document {"+" Document}]]]
   ["[0]" cache "_"
    ["[1]/[0]" module]]
   ["/[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 module.ID
                                     error Text])
  (exception.report
   ["Archive" archive]
   ["Module ID" (%.nat module_id)]
   ["Error" error]))

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

(def: (unversioned_lux_archive fs context)
  (All (_ !) (-> (file.System !) Context file.Path))
  (format (..archive fs context)
          (# fs separator)
          //.lux_context))

(def: (versioned_lux_archive fs context)
  (All (_ !) (-> (file.System !) Context file.Path))
  (format (..unversioned_lux_archive fs context)
          (# fs separator)
          (%.nat version.version)))

(def: (module fs context module_id)
  (All (_ !) (-> (file.System !) Context module.ID file.Path))
  (format (..versioned_lux_archive fs context)
          (# fs separator)
          (%.nat module_id)))

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

(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 context module_id)
  (-> (file.System Async) Context module.ID (Async (Try Any)))
  (do [! async.monad]
    [.let [module (..module fs context module_id)]
     module_exists? (# fs directory? module)]
    (if module_exists?
      (in {try.#Success []})
      (do (try.with !)
        [_ (ensure_directory fs (..unversioned_lux_archive fs context))
         _ (ensure_directory fs (..versioned_lux_archive fs context))]
        (|> module
            (# fs make_directory)
            (# ! each (|>> (case> {try.#Success output}
                                  {try.#Success []}

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

(def: .public (write fs context module_id artifact_id content)
  (-> (file.System Async) Context module.ID artifact.ID Binary (Async (Try Any)))
  (# fs write content (..artifact fs context module_id artifact_id)))

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

(def: (general_descriptor fs context)
  (-> (file.System Async) Context file.Path)
  (format (..archive fs context)
          (# fs separator)
          "general_descriptor"))

(def: .public (freeze fs context archive)
  (-> (file.System Async) Context Archive (Async (Try Any)))
  (# fs write (archive.export ///.version archive) (..general_descriptor fs context)))

(def: module_descriptor_file
  "module_descriptor")

(def: (module_descriptor fs context module_id)
  (-> (file.System Async) Context module.ID file.Path)
  (format (..module fs context module_id)
          (# fs separator)
          ..module_descriptor_file))

(def: .public (cache fs context module_id content)
  (-> (file.System Async) Context module.ID Binary (Async (Try Any)))
  (# fs write content (..module_descriptor fs context module_id)))

(def: (read_module_descriptor fs context module_id)
  (-> (file.System Async) Context module.ID (Async (Try Binary)))
  (# fs read (..module_descriptor fs context module_id)))

(def: module_parser
  (Parser (module.Module .Module))
  ($_ <>.and
      <binary>.nat
      descriptor.parser
      (document.parser $.key $.parser)))

(def: parser
  (Parser [(module.Module .Module) Registry])
  ($_ <>.and
      ..module_parser
      registry.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 [descriptor.Module .Module]))
                (monad.each ! (function (_ module)
                                (do !
                                  [entry (archive.find module archive)
                                   content (|> entry
                                               (value@ [archive.#module module.#document])
                                               (document.content $.key))]
                                  (in [module content])))
                            (archive.archived archive)))]
    (in (with@ .#modules modules (fresh_analysis_state host)))))

(def: (cached_artifacts fs context module_id)
  (-> (file.System Async) Context module.ID (Async (Try (Dictionary Text Binary))))
  (let [! (try.with async.monad)]
    (|> (..module fs context 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) module.ID (Sequence [Artifact (Set unit.ID)]) (Dictionary Text Binary) (Document .Module)
        (Try [(Document .Module) Bundles Output])))
  (do [! try.monad]
    [[definitions bundles] (: (Try [Definitions Bundles Output])
                              (loop [input (sequence.list expected)
                                     definitions (: Definitions
                                                    (dictionary.empty text.hash))
                                     bundles ..empty_bundles
                                     output (: Output sequence.empty)]
                                (let [[analysers synthesizers generators directives] bundles]
                                  (case input
                                    {.#Item [[[artifact_id artifact_category mandatory_artifact?] artifact_dependencies] 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
                                              {category.#Anonymous}
                                              (do !
                                                [.let [output (sequence.suffix [artifact_id {.#None} data] output)]
                                                 _ (# host re_learn context {.#None} directive)]
                                                (in [definitions
                                                     [analysers
                                                      synthesizers
                                                      generators
                                                      directives]
                                                     output]))
                                              
                                              {category.#Definition name}
                                              (let [output (sequence.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]))))

                                              {category.#Analyser extension}
                                              (do !
                                                [.let [output (sequence.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]))

                                              {category.#Synthesizer extension}
                                              (do !
                                                [.let [output (sequence.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]))

                                              {category.#Generator extension}
                                              (do !
                                                [.let [output (sequence.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]))

                                              {category.#Directive extension}
                                              (do !
                                                [.let [output (sequence.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]))

                                              {category.#Custom name}
                                              (do !
                                                [.let [output (sequence.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']}
                                      (again input' definitions' bundles' output')

                                      failure
                                      failure)
                                    
                                    {.#End}
                                    {try.#Success [definitions bundles output]}))))
     content (document.content $.key document)
     definitions (monad.each ! (function (_ [def_name def_global])
                                 (case def_global
                                   (^template [<tag>]
                                     [{<tag> payload}
                                      (in [def_name {<tag> payload}])])
                                   ([.#Alias]
                                    [.#Tag]
                                    [.#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.document $.key (with@ .#definitions definitions content))
         bundles])))

(def: (load_definitions fs context module_id host_environment entry)
  (All (_ expression directive)
    (-> (file.System Async) Context module.ID (generation.Host expression directive)
        (archive.Entry .Module)
        (Async (Try [(archive.Entry .Module) Bundles]))))
  (do (try.with async.monad)
    [actual (cached_artifacts fs context module_id)
     .let [expected (registry.artifacts (value@ archive.#registry entry))]
     [document bundles output] (|> (value@ [archive.#module module.#document] entry)
                                   (loaded_document (value@ context.#artifact_extension context) host_environment module_id expected actual)
                                   async#in)]
    (in [(|> entry
             (with@ [archive.#module module.#document] document)
             (with@ archive.#output output))
         bundles])))

(def: (purge! fs context [module_name module_id])
  (-> (file.System Async) Context [descriptor.Module module.ID] (Async (Try Any)))
  (do [! (try.with async.monad)]
    [.let [cache (..module fs context 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: Cache
  [descriptor.Module [module.ID [(module.Module .Module) Registry]]])

(type: Purge
  (Dictionary descriptor.Module module.ID))

(def: initial_purge
  (-> (List [Bit Cache])
      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 Cache])
      (cache/module.Order .Module)
      Purge)
  (list#mix (function (_ [module_name [module_id entry]] purge)
              (let [purged? (: (Predicate descriptor.Module)
                               (dictionary.key? purge))]
                (if (purged? module_name)
                  purge
                  (if (|> entry
                          (value@ [archive.#module module.#descriptor 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: (valid_cache fs context import contexts [module_name module_id])
  (-> (file.System Async) Context Import (List //.Context)
      [descriptor.Module module.ID]
      (Async (Try [Bit Cache])))
  (with_expansions [<cache> [module_name [module_id [module registry]]]]
    (do [! (try.with async.monad)]
      [data (..read_module_descriptor fs context module_id)
       [module registry] (async#in (<binary>.result ..parser data))]
      (if (text#= descriptor.runtime module_name)
        (in [true <cache>])
        (do !
          [input (//context.read fs ..pseudo_module import contexts (value@ context.#host_module_extension context) module_name)]
          (in [(..valid_cache? (value@ module.#descriptor module) input) <cache>]))))))

(def: (pre_loaded_caches fs context import contexts archive)
  (-> (file.System Async) Context Import (List //.Context) Archive
      (Async (Try (List [Bit Cache]))))
  (do [! (try.with async.monad)]
    [... TODO: Stop needing to wrap this expression in an unnecessary "do" expression.
     it (|> archive
            archive.reservations
            (monad.each !
                        (..valid_cache fs context import contexts)))]
    (in it)))

(def: (load_order archive pre_loaded_caches)
  (-> Archive (List [Bit Cache])
      (Try (cache/module.Order .Module)))
  (|> pre_loaded_caches
      (monad.mix try.monad
                 (function (_ [_ [module [module_id [|module| registry]]]] archive)
                   (archive.has module
                                [archive.#module |module|
                                 archive.#output (: Output sequence.empty)
                                 archive.#registry registry]
                                archive))
                 archive)
      (# try.monad each (cache/module.load_order $.key))
      (# try.monad conjoint)))

(def: (loaded_caches host_environment fs context purge load_order)
  (All (_ expression directive)
    (-> (generation.Host expression directive) (file.System Async) Context
        Purge (cache/module.Order .Module)
        (Async (Try (List [[descriptor.Module (archive.Entry .Module)] Bundles])))))
  (do [! (try.with async.monad)]
    [... TODO: Stop needing to wrap this expression in an unnecessary "do" expression.
     it (|> load_order
            (list.only (|>> product.left (dictionary.key? purge) not))
            (monad.each ! (function (_ [module_name [module_id entry]])
                            (do !
                              [[entry bundles] (..load_definitions fs context module_id host_environment entry)]
                              (in [[module_name entry]
                                   bundles])))))]
    (in it)))

(def: (load_every_reserved_module host_environment fs context import contexts archive)
  (All (_ expression directive)
    (-> (generation.Host expression directive) (file.System Async) Context Import (List //.Context) Archive
        (Async (Try [Archive .Lux Bundles]))))
  (do [! (try.with async.monad)]
    [pre_loaded_caches (..pre_loaded_caches fs context import contexts archive)
     load_order (async#in (load_order archive pre_loaded_caches))
     .let [purge (..full_purge pre_loaded_caches load_order)]
     _ (|> purge
           dictionary.entries
           (monad.each ! (..purge! fs context)))
     loaded_caches (..loaded_caches host_environment fs context purge load_order)]
    (async#in
     (do [! try.monad]
       [archive (monad.mix !
                           (function (_ [[module entry] _bundle] archive)
                             (archive.has module entry archive))
                           archive
                           loaded_caches)
        analysis_state (..analysis_state (value@ context.#host context) 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 context import contexts)
  (All (_ expression directive)
    (-> (generation.Host expression directive) (file.System Async) Context Import (List //.Context)
        (Async (Try [Archive .Lux Bundles]))))
  (do async.monad
    [binary (# fs read (..general_descriptor fs context))]
    (case binary
      {try.#Success binary}
      (do (try.with async.monad)
        [archive (async#in (archive.import ///.version binary))]
        (..load_every_reserved_module host_environment fs context import contexts archive))
      
      {try.#Failure error}
      (in {try.#Success [archive.empty
                         (fresh_analysis_state (value@ context.#host context))
                         ..empty_bundles]}))))