path: root/stdlib/source/library/lux/tool/compiler/default/platform.lux

(.module:
  [library
   [lux {"-" Module}
    [type {"+" :sharing}]
    ["@" target]
    ["[0]" debug]
    [abstract
     ["[0]" monad {"+" Monad do}]]
    [control
     ["[0]" function]
     ["[0]" maybe]
     ["[0]" try {"+" Try} ("[1]#[0]" monad)]
     ["[0]" exception {"+" exception:}]
     [concurrency
      ["[0]" async {"+" Async Resolver} ("[1]#[0]" monad)]
      ["[0]" stm {"+" Var STM}]]]
    [data
     ["[0]" binary {"+" Binary}]
     ["[0]" bit]
     ["[0]" product]
     ["[0]" text ("[1]#[0]" equivalence)
      ["%" format {"+" format}]]
     [collection
      ["[0]" dictionary {"+" Dictionary}]
      ["[0]" row {"+" Row} ("[1]#[0]" mix)]
      ["[0]" set {"+" Set}]
      ["[0]" list ("[1]#[0]" monoid functor mix)]]
     [format
      ["_" binary {"+" Writer}]]]
    [world
     ["[0]" file {"+" Path}]]]]
  ["[0]" // "_"
   ["[1][0]" init]
   ["/[1]" //
    ["[1][0]" phase {"+" Phase}]
    [language
     [lux
      [program {"+" Program}]
      ["$" /]
      ["[1][0]" version]
      ["[0]" syntax]
      ["[1][0]" analysis
       [macro {"+" Expander}]]
      ["[1][0]" synthesis]
      ["[1][0]" generation {"+" Buffer}]
      ["[1][0]" directive]
      [phase
       ["[0]" extension {"+" Extender}]
       [analysis
        ["[0]" module]]]]]
    [meta
     ["[0]" archive {"+" Output Archive}
      ["[0]" artifact {"+" Registry}]
      ["[0]" descriptor {"+" Descriptor Module}]
      ["[0]" document {"+" Document}]]
     [io {"+" Context}
      ["[0]" context]
      ["ioW" archive]]]]]
  [program
   [compositor
    [cli {"+" Compilation Library}]
    [import {"+" Import}]
    ["[0]" static {"+" Static}]]])

(with_expansions [<type_vars> (as_is anchor expression directive)
                  <Operation> (as_is ///generation.Operation <type_vars>)]
  (type: .public (Platform <type_vars>)
    (Record
     [#&file_system (file.System Async)
      #host (///generation.Host expression directive)
      #phase (///generation.Phase <type_vars>)
      #runtime (<Operation> [Registry Output])
      #phase_wrapper (-> Archive (<Operation> ///phase.Wrapper))
      #write (-> directive Binary)]))

  ... TODO: Get rid of this
  (type: (Action a)
    (Async (Try a)))

  ... TODO: Get rid of this
  (def: monad
    (:as (Monad Action)
         (try.with async.monad)))

  (with_expansions [<Platform> (as_is (Platform <type_vars>))
                    <State+> (as_is (///directive.State+ <type_vars>))
                    <Bundle> (as_is (///generation.Bundle <type_vars>))]

    (def: writer
      (Writer [Descriptor (Document .Module)])
      (_.and descriptor.writer
             (document.writer $.writer)))

    (def: (cache_module static platform module_id [descriptor document output])
      (All (_ <type_vars>)
        (-> Static <Platform> archive.ID [Descriptor (Document Any) Output]
            (Async (Try Any))))
      (let [system (value@ #&file_system platform)
            write_artifact! (: (-> [artifact.ID (Maybe Text) Binary] (Action Any))
                               (function (_ [artifact_id custom content])
                                 (ioW.write system static module_id artifact_id content)))]
        (do [! ..monad]
          [_ (ioW.prepare system static module_id)
           _ (for [@.python (|> output
                                row.list
                                (list.sub 128)
                                (monad.each ! (monad.each ! write_artifact!))
                                (: (Action (List (List Any)))))]
                  (|> output
                      row.list
                      (monad.each ..monad write_artifact!)
                      (: (Action (List Any)))))
           document (# async.monad in
                       (document.check $.key document))]
          (ioW.cache system static module_id
                     (_.result ..writer [descriptor document])))))

    ... TODO: Inline ASAP
    (def: initialize_buffer!
      (All (_ <type_vars>)
        (///generation.Operation <type_vars> Any))
      (///generation.set_buffer ///generation.empty_buffer))

    ... TODO: Inline ASAP
    (def: (compile_runtime! platform)
      (All (_ <type_vars>)
        (-> <Platform> (///generation.Operation <type_vars> [Registry Output])))
      (do ///phase.monad
        [_ ..initialize_buffer!]
        (value@ #runtime platform)))

    (def: (runtime_descriptor registry)
      (-> Registry Descriptor)
      [descriptor.#hash 0
       descriptor.#name archive.runtime_module
       descriptor.#file ""
       descriptor.#references (set.empty text.hash)
       descriptor.#state {.#Compiled}
       descriptor.#registry registry])
    
    (def: runtime_document
      (Document .Module)
      (document.write $.key (module.empty 0)))

    (def: (process_runtime archive platform)
      (All (_ <type_vars>)
        (-> Archive <Platform>
            (///directive.Operation <type_vars>
                                    [Archive [Descriptor (Document .Module) Output]])))
      (do ///phase.monad
        [[registry payload] (///directive.lifted_generation
                             (..compile_runtime! platform))
         .let [[descriptor document] [(..runtime_descriptor registry) ..runtime_document]]
         archive (///phase.lifted (if (archive.reserved? archive archive.runtime_module)
                                    (archive.has archive.runtime_module [descriptor document payload] archive)
                                    (do try.monad
                                      [[_ archive] (archive.reserve archive.runtime_module archive)]
                                      (archive.has archive.runtime_module [descriptor document payload] archive))))]
        (in [archive [descriptor document payload]])))

    (def: (initialize_state extender
                            [analysers
                             synthesizers
                             generators
                             directives]
                            analysis_state
                            state)
      (All (_ <type_vars>)
        (-> Extender
            [(Dictionary Text ///analysis.Handler)
             (Dictionary Text ///synthesis.Handler)
             (Dictionary Text (///generation.Handler <type_vars>))
             (Dictionary Text (///directive.Handler <type_vars>))]
            .Lux
            <State+>
            (Try <State+>)))
      (|> (:sharing [<type_vars>]
                    <State+>
                    state
                    
                    (///directive.Operation <type_vars> Any)
                    (do ///phase.monad
                      [_ (///directive.lifted_analysis
                          (///analysis.install analysis_state))
                       _ (///directive.lifted_analysis
                          (extension.with extender analysers))
                       _ (///directive.lifted_synthesis
                          (extension.with extender synthesizers))
                       _ (///directive.lifted_generation
                          (extension.with extender (:expected generators)))
                       _ (extension.with extender (:expected directives))]
                      (in [])))
          (///phase.result' state)
          (# try.monad each product.left)))

    (def: (phase_wrapper archive platform state)
      (All (_ <type_vars>)
        (-> Archive <Platform> <State+> (Try [<State+> ///phase.Wrapper])))
      (let [phase_wrapper (value@ #phase_wrapper platform)]
        (|> archive
            phase_wrapper
            ///directive.lifted_generation
            (///phase.result' state))))

    (def: (complete_extensions host_directive_bundle phase_wrapper [analysers synthesizers generators directives])
      (All (_ <type_vars>)
        (-> (-> ///phase.Wrapper (///directive.Bundle <type_vars>))
            ///phase.Wrapper
            [(Dictionary Text ///analysis.Handler)
             (Dictionary Text ///synthesis.Handler)
             (Dictionary Text (///generation.Handler <type_vars>))
             (Dictionary Text (///directive.Handler <type_vars>))]
            [(Dictionary Text ///analysis.Handler)
             (Dictionary Text ///synthesis.Handler)
             (Dictionary Text (///generation.Handler <type_vars>))
             (Dictionary Text (///directive.Handler <type_vars>))]))
      [analysers
       synthesizers
       generators
       (dictionary.merged directives (host_directive_bundle phase_wrapper))])

    (def: .public (initialize static module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender
                              import compilation_sources)
      (All (_ <type_vars>)
        (-> Static
            Module
            Expander
            ///analysis.Bundle
            <Platform>
            <Bundle>
            (-> ///phase.Wrapper (///directive.Bundle <type_vars>))
            (Program expression directive)
            [Type Type Type] (-> ///phase.Wrapper Extender)
            Import (List Context)
            (Async (Try [<State+> Archive ///phase.Wrapper]))))
      (do [! (try.with async.monad)]
        [.let [state (//init.state (value@ static.#host static)
                                   module
                                   expander
                                   host_analysis
                                   (value@ #host platform)
                                   (value@ #phase platform)
                                   generation_bundle)]
         _ (ioW.enable (value@ #&file_system platform) static)
         [archive analysis_state bundles] (ioW.thaw (value@ #host platform) (value@ #&file_system platform) static import compilation_sources)
         .let [with_missing_extensions
               (: (All (_ <type_vars>)
                    (-> <Platform> (Program expression directive) <State+>
                        (Async (Try [///phase.Wrapper <State+>]))))
                  (function (_ platform program state)
                    (async#in
                     (do try.monad
                       [[state phase_wrapper] (..phase_wrapper archive platform state)]
                       (|> state
                           (initialize_state (extender phase_wrapper)
                                             (:expected (..complete_extensions host_directive_bundle phase_wrapper (:expected bundles)))
                                             analysis_state)
                           (try#each (|>> (//init.with_default_directives expander host_analysis program anchorT,expressionT,directiveT (extender phase_wrapper))
                                          [phase_wrapper])))))))]]
        (if (archive.archived? archive archive.runtime_module)
          (do !
            [[phase_wrapper state] (with_missing_extensions platform program state)]
            (in [state archive phase_wrapper]))
          (do !
            [[state [archive payload]] (|> (..process_runtime archive platform)
                                           (///phase.result' state)
                                           async#in)
             _ (..cache_module static platform 0 payload)
             
             [phase_wrapper state] (with_missing_extensions platform program state)]
            (in [state archive phase_wrapper])))))

    (def: compilation_log_separator
      (format text.new_line text.tab))

    (def: (module_compilation_log module)
      (All (_ <type_vars>)
        (-> Module <State+> Text))
      (|>> (value@ [extension.#state
                    ///directive.#generation
                    ///directive.#state
                    extension.#state
                    ///generation.#log])
           (row#mix (function (_ right left)
                      (format left ..compilation_log_separator right))
                    module)))

    (def: with_reset_log
      (All (_ <type_vars>)
        (-> <State+> <State+>))
      (with@ [extension.#state
              ///directive.#generation
              ///directive.#state
              extension.#state
              ///generation.#log]
             row.empty))

    (def: empty
      (Set Module)
      (set.empty text.hash))

    (type: Mapping
      (Dictionary Module (Set Module)))

    (type: Dependence
      (Record
       [#depends_on Mapping
        #depended_by Mapping]))

    (def: independence
      Dependence
      (let [empty (dictionary.empty text.hash)]
        [#depends_on empty
         #depended_by empty]))

    (def: (depend module import dependence)
      (-> Module Module Dependence Dependence)
      (let [transitive_dependency (: (-> (-> Dependence Mapping) Module (Set Module))
                                     (function (_ lens module)
                                       (|> dependence
                                           lens
                                           (dictionary.value module)
                                           (maybe.else ..empty))))
            transitive_depends_on (transitive_dependency (value@ #depends_on) import)
            transitive_depended_by (transitive_dependency (value@ #depended_by) module)
            update_dependence (: (-> [Module (Set Module)] [Module (Set Module)]
                                     (-> Mapping Mapping))
                                 (function (_ [source forward] [target backward])
                                   (function (_ mapping)
                                     (let [with_dependence+transitives
                                           (|> mapping
                                               (dictionary.revised' source ..empty (set.has target))
                                               (dictionary.revised source (set.union forward)))]
                                       (list#mix (function (_ previous)
                                                   (dictionary.revised' previous ..empty (set.has target)))
                                                 with_dependence+transitives
                                                 (set.list backward))))))]
        (|> dependence
            (revised@ #depends_on
                      (update_dependence
                       [module transitive_depends_on]
                       [import transitive_depended_by]))
            (revised@ #depended_by
                      ((function.flipped update_dependence)
                       [module transitive_depends_on]
                       [import transitive_depended_by])))))

    (def: (circular_dependency? module import dependence)
      (-> Module Module Dependence Bit)
      (let [dependence? (: (-> Module (-> Dependence Mapping) Module Bit)
                           (function (_ from relationship to)
                             (let [targets (|> dependence
                                               relationship
                                               (dictionary.value from)
                                               (maybe.else ..empty))]
                               (set.member? targets to))))]
        (or (dependence? import (value@ #depends_on) module)
            (dependence? module (value@ #depended_by) import))))

    (exception: .public (module_cannot_import_itself [module Module])
      (exception.report
       ["Module" (%.text module)]))

    (exception: .public (cannot_import_circular_dependency [importer Module
                                                            importee Module])
      (exception.report
       ["Importer" (%.text importer)]
       ["importee" (%.text importee)]))

    (exception: .public (cannot_import_twice [importer Module
                                              duplicates (Set Module)])
      (exception.report
       ["Importer" (%.text importer)]
       ["Duplicates" (%.list %.text (set.list duplicates))]))

    (def: (verify_dependencies importer importee dependence)
      (-> Module Module Dependence (Try Any))
      (cond (text#= importer importee)
            (exception.except ..module_cannot_import_itself [importer])

            (..circular_dependency? importer importee dependence)
            (exception.except ..cannot_import_circular_dependency [importer importee])

            ... else
            {try.#Success []}))

    (with_expansions [<Context> (as_is [Archive <State+>])
                      <Result> (as_is (Try <Context>))
                      <Return> (as_is (Async <Result>))
                      <Signal> (as_is (Resolver <Result>))
                      <Pending> (as_is [<Return> <Signal>])
                      <Importer> (as_is (-> Module Module <Return>))
                      <Compiler> (as_is (-> Module <Importer> archive.ID <Context> Module <Return>))]
      (def: (parallel initial)
        (All (_ <type_vars>)
          (-> <Context>
              (-> <Compiler> <Importer>)))
        (let [current (stm.var initial)
              pending (:sharing [<type_vars>]
                                <Context>
                                initial
                                
                                (Var (Dictionary Module <Pending>))
                                (:expected (stm.var (dictionary.empty text.hash))))
              dependence (: (Var Dependence)
                            (stm.var ..independence))]
          (function (_ compile)
            (function (import! importer module)
              (do [! async.monad]
                [[return signal] (:sharing [<type_vars>]
                                           <Context>
                                           initial
                                           
                                           (Async [<Return> (Maybe [<Context>
                                                                    archive.ID
                                                                    <Signal>])])
                                           (:expected
                                            (stm.commit!
                                             (do [! stm.monad]
                                               [dependence (if (text#= archive.runtime_module importer)
                                                             (stm.read dependence)
                                                             (do !
                                                               [[_ dependence] (stm.update (..depend importer module) dependence)]
                                                               (in dependence)))]
                                               (case (..verify_dependencies importer module dependence)
                                                 {try.#Failure error}
                                                 (in [(async.resolved {try.#Failure error})
                                                      {.#None}])

                                                 {try.#Success _}
                                                 (do !
                                                   [[archive state] (stm.read current)]
                                                   (if (archive.archived? archive module)
                                                     (in [(async#in {try.#Success [archive state]})
                                                          {.#None}])
                                                     (do !
                                                       [@pending (stm.read pending)]
                                                       (case (dictionary.value module @pending)
                                                         {.#Some [return signal]}
                                                         (in [return
                                                              {.#None}])
                                                         
                                                         {.#None}
                                                         (case (if (archive.reserved? archive module)
                                                                 (do try.monad
                                                                   [module_id (archive.id module archive)]
                                                                   (in [module_id archive]))
                                                                 (archive.reserve module archive))
                                                           {try.#Success [module_id archive]}
                                                           (do !
                                                             [_ (stm.write [archive state] current)
                                                              .let [[return signal] (:sharing [<type_vars>]
                                                                                              <Context>
                                                                                              initial
                                                                                              
                                                                                              <Pending>
                                                                                              (async.async []))]
                                                              _ (stm.update (dictionary.has module [return signal]) pending)]
                                                             (in [return
                                                                  {.#Some [[archive state]
                                                                           module_id
                                                                           signal]}]))
                                                           
                                                           {try.#Failure error}
                                                           (in [(async#in {try.#Failure error})
                                                                {.#None}])))))))))))
                 _ (case signal
                     {.#None}
                     (in [])
                     
                     {.#Some [context module_id resolver]}
                     (do !
                       [result (compile importer import! module_id context module)
                        result (case result
                                 {try.#Failure error}
                                 (in result)

                                 {try.#Success [resulting_archive resulting_state]}
                                 (stm.commit! (do stm.monad
                                                [[_ [merged_archive _]] (stm.update (function (_ [archive state])
                                                                                      [(archive.merged resulting_archive archive)
                                                                                       state])
                                                                                    current)]
                                                (in {try.#Success [merged_archive resulting_state]}))))
                        _ (async.future (resolver result))]
                       (in [])))]
                return)))))

      ... TODO: Find a better way, as this only works for the Lux compiler.
      (def: (updated_state archive state)
        (All (_ <type_vars>)
          (-> Archive <State+> (Try <State+>)))
        (do [! try.monad]
          [modules (monad.each ! (function (_ module)
                                   (do !
                                     [[descriptor document output] (archive.find module archive)
                                      lux_module (document.read $.key document)]
                                     (in [module lux_module])))
                               (archive.archived archive))
           .let [additions (|> modules
                               (list#each product.left)
                               (set.of_list text.hash))]]
          (in (revised@ [extension.#state
                         ///directive.#analysis
                         ///directive.#state
                         extension.#state]
                        (function (_ analysis_state)
                          (|> analysis_state
                              (:as .Lux)
                              (revised@ .#modules (function (_ current)
                                                    (list#composite (list.only (|>> product.left
                                                                                    (set.member? additions)
                                                                                    not)
                                                                               current)
                                                                    modules)))
                              :expected))
                        state))))

      (def: (set_current_module module state)
        (All (_ <type_vars>)
          (-> Module <State+> <State+>))
        (|> (///directive.set_current_module module)
            (///phase.result' state)
            try.trusted
            product.left))

      (def: .public (compile phase_wrapper import static expander platform compilation context)
        (All (_ <type_vars>)
          (-> ///phase.Wrapper Import Static Expander <Platform> Compilation <Context> <Return>))
        (let [[compilation_sources compilation_host_dependencies compilation_libraries compilation_target compilation_module] compilation
              base_compiler (:sharing [<type_vars>]
                                      <Context>
                                      context
                                      
                                      (///.Compiler <State+> .Module Any)
                                      (:expected
                                       ((//init.compiler phase_wrapper expander syntax.prelude (value@ #write platform)) $.key (list))))
              compiler (..parallel
                        context
                        (function (_ importer import! module_id [archive state] module)
                          (do [! (try.with async.monad)]
                            [.let [state (..set_current_module module state)]
                             input (context.read (value@ #&file_system platform)
                                                 importer
                                                 import
                                                 compilation_sources
                                                 (value@ static.#host_module_extension static)
                                                 module)]
                            (loop [[archive state] [archive state]
                                   compilation (base_compiler (:as ///.Input input))
                                   all_dependencies (: (Set Module)
                                                       (set.of_list text.hash (list)))]
                              (do !
                                [.let [new_dependencies (value@ ///.#dependencies compilation)
                                       continue! (:sharing [<type_vars>]
                                                           <Platform>
                                                           platform
                                                           
                                                           (-> <Context> (///.Compilation <State+> .Module Any) (Set Module)
                                                               (Action [Archive <State+>]))
                                                           (:expected recur))
                                       ... TODO: Come up with a less hacky way to prevent duplicate imports.
                                       ... This currently assumes that all imports will be specified once in a single .module: form.
                                       ... This might not be the case in the future.
                                       [all_dependencies duplicates _] (: [(Set Module) (Set Module) Bit]
                                                                          (list#mix (function (_ new [all duplicates seen_prelude?])
                                                                                      (if (set.member? all new)
                                                                                        (if (text#= .prelude_module new)
                                                                                          (if seen_prelude?
                                                                                            [all (set.has new duplicates) seen_prelude?]
                                                                                            [all duplicates true])
                                                                                          [all (set.has new duplicates) seen_prelude?])
                                                                                        [(set.has new all) duplicates seen_prelude?]))
                                                                                    (: [(Set Module) (Set Module) Bit]
                                                                                       [all_dependencies ..empty (set.empty? all_dependencies)])
                                                                                    new_dependencies))]
                                 [archive state] (if (set.empty? duplicates)
                                                   (case new_dependencies
                                                     {.#End}
                                                     (in [archive state])

                                                     {.#Item _}
                                                     (do !
                                                       [archive,document+ (|> new_dependencies
                                                                              (list#each (import! module))
                                                                              (monad.all ..monad))
                                                        .let [archive (|> archive,document+
                                                                          (list#each product.left)
                                                                          (list#mix archive.merged archive))]]
                                                       (in [archive (try.trusted
                                                                     (..updated_state archive state))])))
                                                   (async#in (exception.except ..cannot_import_twice [module duplicates])))]
                                (case ((value@ ///.#process compilation)
                                       ... TODO: The "///directive.set_current_module" below shouldn't be necessary. Remove it ASAP.
                                       ... TODO: The context shouldn't need to be re-set either.
                                       (|> (///directive.set_current_module module)
                                           (///phase.result' state)
                                           try.trusted
                                           product.left)
                                       archive)
                                  {try.#Success [state more|done]}
                                  (case more|done
                                    {.#Left more}
                                    (continue! [archive state] more all_dependencies)

                                    {.#Right [descriptor document output]}
                                    (do !
                                      [.let [_ (debug.log! (..module_compilation_log module state))
                                             descriptor (with@ descriptor.#references all_dependencies descriptor)]
                                       _ (..cache_module static platform module_id [descriptor document output])]
                                      (case (archive.has module [descriptor document output] archive)
                                        {try.#Success archive}
                                        (in [archive
                                             (..with_reset_log state)])
                                        
                                        {try.#Failure error}
                                        (async#in {try.#Failure error}))))

                                  {try.#Failure error}
                                  (do !
                                    [_ (ioW.freeze (value@ #&file_system platform) static archive)]
                                    (async#in {try.#Failure error}))))))))]
          (compiler archive.runtime_module compilation_module)))
      )))