path: root/stdlib/source/library/lux/meta/compiler/default/init.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)
   [abstract
    ["[0]" monad (.only do)]]
   [control
    ["[0]" try (.only Try)]
    ["[0]" exception]]
   [data
    [binary (.only Binary)]
    ["[0]" product]
    ["[0]" text (.use "[1]#[0]" hash)
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor)]
     ["[0]" dictionary]
     ["[0]" set]
     ["[0]" sequence (.use "[1]#[0]" functor)]]]
   ["[0]" meta (.only)
    ["[0]" configuration (.only Configuration)]
    ["[0]" version]
    [compiler
     [target (.only Target)]]]
   [world
    ["[0]" file]]]]
 ["[0]" //
  ["/[1]" // (.only Instancer)
   [language
    [lux
     ["[0]" phase]
     ["[1][0]" program (.only Program)]
     ["[1][0]" syntax (.only Aliases)]
     ["[1][0]" synthesis]
     ["[1][0]" declaration (.only Requirements Extender)]
     ["[1][0]" translation]
     ["[1][0]" analysis (.only)
      [macro (.only Expander)]
      ["[0]A" module]]
     [phase
      ["[0]P" analysis]
      ["[0]P" synthesis]
      ["[0]P" declaration]
      ["[0]" extension (.only)
       ["[0]E" analysis]
       [declaration
        ["[0]D" lux]]]]]]
   [meta
    ["[0]" archive (.only Archive)
     [key (.only Key)]
     ["[0]" unit]
     ["[0]" registry (.only Registry)]
     ["[0]" module (.only)
      ["[0]" descriptor]
      ["[0]" document]]]]]])

(def .public (state target module configuration extender expander host translate)
  (All (_ anchor expression declaration)
    (-> Target
        descriptor.Module
        Configuration
        extension.Extender Expander
        (///translation.Host expression declaration)
        (-> extension.Extender Lux (///translation.Phase anchor expression declaration))
        (///declaration.State anchor expression declaration)))
  (let [lux (///analysis.state (///analysis.info version.latest target configuration))]
    [///declaration.#analysis [///declaration.#state lux
                               ///declaration.#phase (analysisP.phase extender expander)]
     ///declaration.#synthesis [///declaration.#state ///synthesis.init
                                ///declaration.#phase (synthesisP.phase extender)]
     ///declaration.#translation [///declaration.#state (///translation.state host module)
                                  ///declaration.#phase (translate extender)]]))

(type Reader
  (-> Source (Either [Source Text] [Source Code])))

(def (reader current_module aliases [location offset source_code])
  (-> descriptor.Module Aliases Source (///analysis.Operation Reader))
  (function (_ state)
    {try.#Success [state (///syntax.parse current_module aliases (text.size source_code))]}))

(def (read source reader)
  (-> Source Reader (///analysis.Operation [Source Code]))
  (function (_ compiler)
    (when (reader source)
      {.#Left [source' error]}
      {try.#Failure error}

      {.#Right [source' output]}
      (let [[location _] output]
        {try.#Success [(|> compiler
                           (has .#source source')
                           (has .#location location))
                       [source' output]]}))))

(type (Operation a)
  (All (_ anchor expression declaration)
    (///declaration.Operation anchor expression declaration a)))

(type (Payload declaration)
  [(///translation.Buffer declaration)
   Registry])

(def (with_analysis_defaults bundle)
  (-> ///analysis.Bundle
      (Operation Any))
  (do [! phase.monad]
    [_ (|> bundle
           dictionary.entries
           (monad.each !
                       (function (_ [name handler])
                         (///declaration.of_analysis
                          (moduleA.override_definition [.prelude name] [true {.#Default [.Analysis handler]}])))))]
    (in [])))

(def (with_synthesis_defaults bundle)
  (-> ///synthesis.Bundle
      (Operation Any))
  (do [! phase.monad]
    [_ (|> bundle
           dictionary.entries
           (monad.each !
                       (function (_ [name handler])
                         (///declaration.of_analysis
                          (moduleA.override_definition [.prelude name] [true {.#Default [.Synthesis handler]}])))))]
    (in [])))

(def (with_translation_defaults bundle)
  (All (_ anchor expression declaration)
    (-> (///translation.Bundle anchor expression declaration)
        (///declaration.Operation anchor expression declaration Any)))
  (do [! phase.monad]
    [_ (|> bundle
           dictionary.entries
           (monad.each !
                       (function (_ [name handler])
                         (///declaration.of_analysis
                          (moduleA.override_definition [.prelude name] [true {.#Default [.Translation handler]}])))))]
    (in [])))

(def (with_declaration_defaults bundle)
  (All (_ anchor expression declaration)
    (-> (///declaration.Bundle anchor expression declaration)
        (///declaration.Operation anchor expression declaration Any)))
  (do [! phase.monad]
    [_ (|> bundle
           dictionary.entries
           (monad.each !
                       (function (_ [name handler])
                         (do !
                           [_ (///declaration.of_analysis
                               (moduleA.override_definition [.prelude name] [true {.#Default [.Declaration handler]}]))]
                           (in [])))))]
    (in [])))

(type .public (Extensions anchor expression declaration)
  [///analysis.Bundle
   ///synthesis.Bundle
   (///translation.Bundle anchor expression declaration)
   (///declaration.Bundle anchor expression declaration)])

(def .public (with_defaults module [analysis_bundle synthesis_bundle translation_bundle host_declaration_bundle])
  (All (_ anchor expression declaration)
    (-> Text (Extensions anchor expression declaration)
        (///declaration.Operation anchor expression declaration Any)))
  (when module
    .prelude
    (do phase.monad
      [_ (with_analysis_defaults analysis_bundle)
       _ (with_synthesis_defaults synthesis_bundle)
       _ (with_translation_defaults translation_bundle)]
      (with_declaration_defaults (dictionary.composite host_declaration_bundle
                                                       luxD.bundle)))

    _
    (with phase.monad
      (in []))))

(def (begin dependencies hash input all_extensions)
  (All (_ anchor expression declaration)
    (-> (List descriptor.Module) Nat ///.Input
        (Extensions anchor expression declaration)
        (///declaration.Operation anchor expression declaration
                                  [Source (Payload declaration)])))
  (do phase.monad
    [.let [module (the ///.#module input)]
     _ (///declaration.set_current_module module)
     _ (///declaration.of_analysis
        (moduleA.create hash module))
     _ (with_defaults module all_extensions)]
    (///declaration.of_analysis
     (do [! phase.monad]
       [_ (monad.each ! moduleA.import dependencies)
        .let [source (///analysis.source (the ///.#module input) (the ///.#code input))]
        _ (///analysis.set_source_code source)]
       (in [source [///translation.empty_buffer
                    registry.empty]])))))

(def (end module)
  (-> descriptor.Module
      (All (_ anchor expression declaration)
        (///declaration.Operation anchor expression declaration [.Module (Payload declaration)])))
  (do phase.monad
    [_ (///declaration.of_analysis
        (moduleA.set_compiled module))
     analysis_module (<| (is (Operation .Module))
                         ///declaration.of_analysis
                         meta.current_module)
     final_buffer (///declaration.of_translation
                   ///translation.buffer)
     final_registry (///declaration.of_translation
                     ///translation.get_registry)]
    (in [analysis_module [final_buffer
                          final_registry]])))

... TODO: Inline ASAP
(def (get_current_payload _)
  (All (_ anchor expression declaration)
    (-> (Extender anchor expression declaration)
        (///declaration.Operation anchor expression declaration
                                  (Payload declaration))))
  (do phase.monad
    [buffer (///declaration.of_translation
             ///translation.buffer)
     registry (///declaration.of_translation
               ///translation.get_registry)]
    (in [buffer registry])))

... TODO: Inline ASAP
(def (process_declaration wrapper archive extender expander pre_payoad code)
  (All (_ anchor expression declaration)
    (-> phase.Wrapper Archive (Extender anchor expression declaration) Expander (Payload declaration) Code
        (///declaration.Operation anchor expression declaration
                                  [Requirements (Payload declaration)])))
  (do phase.monad
    [.let [[pre_buffer pre_registry] pre_payoad]
     _ (///declaration.of_translation
        (///translation.set_buffer pre_buffer))
     _ (///declaration.of_translation
        (///translation.set_registry pre_registry))
     requirements (let [execute! (declarationP.phase wrapper extender expander)]
                    (execute! archive code))
     post_payload (..get_current_payload extender)]
    (in [requirements post_payload])))

(def (iteration' wrapper archive extender expander reader source pre_payload)
  (All (_ anchor expression declaration)
    (-> phase.Wrapper Archive (Extender anchor expression declaration) Expander Reader Source (Payload declaration)
        (///declaration.Operation anchor expression declaration
                                  [Source Requirements (Payload declaration)])))
  (do phase.monad
    [[source code] (///declaration.of_analysis
                    (..read source reader))
     [requirements post_payload] (process_declaration wrapper archive extender expander pre_payload code)]
    (in [source requirements post_payload])))

(def (iteration wrapper archive extender expander module source pre_payload aliases)
  (All (_ anchor expression declaration)
    (-> phase.Wrapper Archive (Extender anchor expression declaration) Expander descriptor.Module Source (Payload declaration) Aliases
        (///declaration.Operation anchor expression declaration
                                  (Maybe [Source Requirements (Payload declaration)]))))
  (do phase.monad
    [reader (///declaration.of_analysis
             (..reader module aliases source))]
    (function (_ state)
      (when (phase.result' state (..iteration' wrapper archive extender expander reader source pre_payload))
        {try.#Success [state source&requirements&buffer]}
        {try.#Success [state {.#Some source&requirements&buffer}]}

        {try.#Failure error}
        (if (exception.match? ///syntax.end_of_file error)
          {try.#Success [state {.#None}]}
          (exception.with ///.cannot_compile module {try.#Failure error}))))))

(def (default_dependencies prelude input)
  (-> descriptor.Module ///.Input (List descriptor.Module))
  (list.partial descriptor.runtime
                (if (text#= prelude (the ///.#module input))
                  (list)
                  (list prelude))))

(def module_aliases
  (-> .Module Aliases)
  (|>> (the .#module_aliases) (dictionary.of_list text.hash)))

(with_expansions [<parameters> (these anchor expression declaration)]
  (def (define_program! archive program global program_module program_definition)
    (All (_ <parameters>)
      (-> Archive
          (Program expression declaration) (-> Archive Symbol (///translation.Operation <parameters> expression))
          descriptor.Module Text
          (///translation.Operation <parameters> Any)))
    (do phase.monad
      [ [@program _] (///translation.definition archive [program_module program_definition])
        @self (///translation.learn [///program.name {.#None}] true (set.has @program (set.empty unit.hash)))

        |program| (global archive [program_module program_definition])
        @module (phase.of_try (archive.id program_module archive))]
      (///translation.save! @self {.#None} (program [@module @self] |program|))))

  (def .public (compiler program global wrapper extender expander prelude write_declaration program_module program_definition
                         extensions)
    (All (_ <parameters>)
      (-> (Program expression declaration) (-> Archive Symbol (///translation.Operation <parameters> expression))
          phase.Wrapper (Extender <parameters>) Expander descriptor.Module (-> declaration Binary)
          descriptor.Module (Maybe Text)
          (Extensions <parameters>)
          (Instancer (///declaration.State <parameters>) .Module)))
    (let [execute! (declarationP.phase wrapper extender expander)]
      (function (_ key parameters input)
        (let [dependencies (default_dependencies prelude input)]
          [///.#dependencies dependencies
           ///.#process (function (_ state archive)
                          (do [! try.monad]
                            [.let [hash (text#hash (the ///.#code input))]
                             [state [source buffer]] (<| (phase.result' state)
                                                         (..begin dependencies hash input extensions))
                             .let [module (the ///.#module input)]]
                            (loop (again [iteration (<| (phase.result' state)
                                                        (..iteration wrapper archive extender expander module source buffer ///syntax.no_aliases))])
                              (do !
                                [[state ?source&requirements&temporary_payload] iteration]
                                (when ?source&requirements&temporary_payload
                                  {.#None}
                                  (do !
                                    [[state [analysis_module [final_buffer final_registry]]]
                                     (<| (phase.result' state)
                                         (do [! phase.monad]
                                           [_ (if (text#= program_module module)
                                                (when program_definition
                                                  {.#Some program_definition}
                                                  (///declaration.of_translation
                                                   (define_program! archive program global program_module program_definition))
                                                  
                                                  {.#None}
                                                  (in []))
                                                (in []))]
                                           (..end module)))
                                     .let [descriptor [descriptor.#hash hash
                                                       descriptor.#name module
                                                       descriptor.#file (the ///.#file input)
                                                       descriptor.#references (set.of_list text.hash dependencies)
                                                       descriptor.#state {.#Compiled}]]]
                                    (in [state
                                         {.#Right [[module.#id (try.else module.runtime (archive.id module archive))
                                                    module.#descriptor descriptor
                                                    module.#document (document.document key analysis_module)]
                                                   (sequence#each (function (_ [artifact_id custom declaration])
                                                                    [artifact_id custom (write_declaration declaration)])
                                                                  final_buffer)
                                                   final_registry]}]))

                                  {.#Some [source requirements temporary_payload]}
                                  (let [[temporary_buffer temporary_registry] temporary_payload]
                                    (in [state
                                         {.#Left [///.#dependencies (|> requirements
                                                                        (the ///declaration.#imports)
                                                                        (list#each product.left))
                                                  ///.#process (function (_ state archive)
                                                                 (again (<| (phase.result' state)
                                                                            (do [! phase.monad]
                                                                              [analysis_module (<| (is (Operation .Module))
                                                                                                   ///declaration.of_analysis
                                                                                                   meta.current_module)
                                                                               _ (///declaration.of_translation
                                                                                  (///translation.set_buffer temporary_buffer))
                                                                               _ (///declaration.of_translation
                                                                                  (///translation.set_registry temporary_registry))
                                                                               _ (|> requirements
                                                                                     (the ///declaration.#referrals)
                                                                                     (monad.each ! (execute! archive)))
                                                                               temporary_payload (..get_current_payload extender)]
                                                                              (..iteration wrapper archive extender expander module source temporary_payload (..module_aliases analysis_module))))))]}]))
                                  )))))]))))
  )