path: root/stdlib/source/library/lux/meta/compiler/language/lux/phase/extension/declaration/lux.lux

(.require
 [library
  [lux (.except)
   [abstract
    ["[0]" monad (.only do)]]
   [control
    [io (.only IO)]
    ["<>" parser]
    ["[0]" maybe (.use "[1]#[0]" functor)]
    ["[0]" try]
    ["[0]" exception (.only exception)]]
   [data
    ["[0]" binary]
    ["[0]" product]
    ["[0]" text
     ["%" \\format (.only format)]]
    [collection
     ["[0]" dictionary]
     ["[0]" array]
     ["[0]" list (.use "[1]#[0]" functor mix)]
     ["[0]" set (.only Set)]]]
   [math
    [number
     ["n" nat]]]
   ["[0]" meta (.only)
    ["@" target]
    ["[0]" code
     ["<[1]>" \\parser (.only Parser)]]
    [macro
     ["^" pattern]]
    ["[0]" type (.only sharing) (.use "[1]#[0]" equivalence)
     ["[0]" check]]]]]
 ["[0]" /// (.only Extender)
  ["[1][0]" bundle]
  ["[1][0]" analysis]
  ["/[1]" //
   ["/[1]" //
    ["[1][0]" analysis (.only)
     [macro (.only Expander)]
     ["[1]/[0]" evaluation]
     ["[0]A" type]
     ["[0]A" module]
     ["[0]" scope]]
    ["[1][0]" synthesis (.only Synthesis)]
    ["[1][0]" generation]
    ["[1][0]" declaration (.only Import Requirements Phase Operation Handler Bundle)]
    ["[1][0]" program (.only Program)]
    [///
     ["[0]" phase]
     [meta
      ["[0]" archive (.only Archive)
       ["[0]" artifact]
       ["[0]" module]
       ["[0]" unit]]
      ["[0]" cache
       [dependency
        ["[1]/[0]" artifact]]]]]]]])

(def .public (custom [syntax handler])
  (All (_ anchor expression declaration s)
    (-> [(Parser s)
         (-> Text
             (Phase anchor expression declaration)
             Archive
             s
             (Operation anchor expression declaration Requirements))]
        (Handler anchor expression declaration)))
  (function (_ extension_name phase archive inputs)
    (case (<code>.result syntax inputs)
      {try.#Success inputs}
      (handler extension_name phase archive inputs)

      {try.#Failure error}
      (phase.except ///.invalid_syntax [extension_name %.code inputs]))))

(def (context [@module @artifact])
  (-> unit.ID unit.ID)
  ... TODO: Find a better way that doesn't rely on clever tricks.
  [@module (n.- (++ @artifact) 0)])

... TODO: Inline "evaluate!'" into "evaluate!" ASAP
(def (evaluate!' archive generate code//type codeS)
  (All (_ anchor expression declaration)
    (-> Archive
        (/////generation.Phase anchor expression declaration)
        Type
        Synthesis
        (Operation anchor expression declaration [Type expression Any])))
  (/////declaration.lifted_generation
   (do phase.monad
     [module /////generation.module
      id /////generation.next
      codeG (generate archive codeS)
      @module (/////generation.module_id module archive)
      codeV (/////generation.evaluate! (..context [@module id]) [{.#None} codeG])]
     (in [code//type codeG codeV]))))

(def .public (evaluate! archive type codeC)
  (All (_ anchor expression declaration)
    (-> Archive Type Code (Operation anchor expression declaration [Type expression Any])))
  (do phase.monad
    [state (///.lifted phase.state)
     .let [analyse (the [/////declaration.#analysis /////declaration.#phase] state)
           synthesize (the [/////declaration.#synthesis /////declaration.#phase] state)
           generate (the [/////declaration.#generation /////declaration.#phase] state)]
     [_ codeA] (<| /////declaration.lifted_analysis
                   scope.with
                   typeA.fresh
                   (typeA.expecting type)
                   (analyse archive codeC))
     codeS (/////declaration.lifted_synthesis
            (synthesize archive codeA))]
    (evaluate!' archive generate type codeS)))

... TODO: Inline "definition'" into "definition" ASAP
(def (definition' archive generate [module name] code//type codeS)
  (All (_ anchor expression declaration)
    (-> Archive
        (/////generation.Phase anchor expression declaration)
        Symbol
        Type
        Synthesis
        (Operation anchor expression declaration [Type expression Any])))
  (/////declaration.lifted_generation
   (do phase.monad
     [dependencies (cache/artifact.dependencies archive codeS)
      [interim_artifacts codeG] (/////generation.with_interim_artifacts archive
                                  (generate archive codeS))
      .let [@abstraction (case codeS
                           (/////synthesis.function/abstraction [env arity body])
                           (|> interim_artifacts
                               list.last
                               (maybe#each (|>> [arity])))

                           _
                           {.#None})]
      @module (phase.lifted (archive.id module archive))
      @self (/////generation.learn [name @abstraction] false (list#mix set.has dependencies interim_artifacts))
      [target_name value declaration] (/////generation.define! [@module @self] {.#None} [(maybe#each product.right @abstraction) codeG])
      _ (/////generation.save! @self {.#None} declaration)]
     (in [code//type codeG value]))))

(def (definition archive name expected codeC)
  (All (_ anchor expression declaration)
    (-> Archive Symbol (Maybe Type) Code
        (Operation anchor expression declaration [Type expression Any])))
  (do [! phase.monad]
    [state (///.lifted phase.state)
     .let [analyse (the [/////declaration.#analysis /////declaration.#phase] state)
           synthesize (the [/////declaration.#synthesis /////declaration.#phase] state)
           generate (the [/////declaration.#generation /////declaration.#phase] state)]
     [_ code//type codeA] (/////declaration.lifted_analysis
                           (scope.with
                             (typeA.fresh
                              (case expected
                                {.#None}
                                (do !
                                  [[code//type codeA] (typeA.inferring
                                                       (analyse archive codeC))
                                   code//type (typeA.check (check.clean (list) code//type))]
                                  (in [code//type codeA]))

                                {.#Some expected}
                                (do !
                                  [codeA (<| (typeA.expecting expected)
                                             (analyse archive codeC))]
                                  (in [expected codeA]))))))
     codeS (/////declaration.lifted_synthesis
            (synthesize archive codeA))]
    (definition' archive generate name code//type codeS)))

(with_template [<full> <partial> <learn>]
  [... TODO: Inline "<partial>" into "<full>" ASAP
   (def (<partial> archive generate extension codeT codeS)
     (All (_ anchor expression declaration)
       (-> Archive
           (/////generation.Phase anchor expression declaration)
           Text
           Type
           Synthesis
           (Operation anchor expression declaration [expression Any])))
     (do phase.monad
       [current_module (/////declaration.lifted_analysis
                        (///.lifted meta.current_module_name))]
       (/////declaration.lifted_generation
        (do phase.monad
          [dependencies (cache/artifact.dependencies archive codeS)
           [interim_artifacts codeG] (/////generation.with_interim_artifacts archive
                                       (generate archive codeS))
           @module (phase.lifted (archive.id current_module archive))
           @self (<learn> extension (list#mix set.has dependencies interim_artifacts))
           [target_name value declaration] (/////generation.define! [@module @self] {.#None} [{.#None} codeG])
           _ (/////generation.save! @self {.#None} declaration)]
          (in [codeG value])))))

   (def .public (<full> archive extension codeT codeC)
     (All (_ anchor expression declaration)
       (-> Archive Text Type Code
           (Operation anchor expression declaration [expression Any])))
     (do phase.monad
       [state (///.lifted phase.state)
        .let [analyse (the [/////declaration.#analysis /////declaration.#phase] state)
              synthesize (the [/////declaration.#synthesis /////declaration.#phase] state)
              generate (the [/////declaration.#generation /////declaration.#phase] state)]
        [_ codeA] (<| /////declaration.lifted_analysis
                      scope.with
                      typeA.fresh
                      (typeA.expecting codeT)
                      (analyse archive codeC))
        codeS (/////declaration.lifted_synthesis
               (synthesize archive codeA))]
       (<partial> archive generate extension codeT codeS)))]

  [analyser analyser' /////generation.learn_analyser]
  [synthesizer synthesizer' /////generation.learn_synthesizer]
  [generator generator' /////generation.learn_generator]
  [declaration declaration' /////generation.learn_declaration]
  )

... TODO: Get rid of this function ASAP.
(def (refresh expander host_analysis)
  (All (_ anchor expression declaration)
    (-> Expander /////analysis.Bundle (Operation anchor expression declaration Any)))
  (do phase.monad
    [[bundle state] phase.state
     .let [eval (/////analysis/evaluation.evaluator expander
                                                    (the [/////declaration.#synthesis /////declaration.#state] state)
                                                    (the [/////declaration.#generation /////declaration.#state] state)
                                                    (the [/////declaration.#generation /////declaration.#phase] state))
           previous_analysis_extensions (the [/////declaration.#analysis /////declaration.#state ///.#bundle] state)]]
    (phase.with [bundle
                 (revised [/////declaration.#analysis /////declaration.#state]
                          (is (-> /////analysis.State+ /////analysis.State+)
                              (|>> product.right
                                   [(|> previous_analysis_extensions
                                        (dictionary.composite (///analysis.bundle eval host_analysis)))]))
                          state)])))

(def (announce_definition! short type)
  (All (_ anchor expression declaration)
    (-> Text Type (Operation anchor expression declaration Any)))
  (/////declaration.lifted_generation
   (/////generation.log! (format short " : " (%.type type)))))

(def (lux::def expander host_analysis)
  (-> Expander /////analysis.Bundle Handler)
  (function (_ extension_name phase archive inputsC+)
    (case inputsC+
      (list [_ {.#Symbol ["" short_name]}] valueC exported?C)
      (do phase.monad
        [current_module (/////declaration.lifted_analysis
                         (///.lifted meta.current_module_name))
         .let [full_name [current_module short_name]]
         [type valueT value] (..definition archive full_name {.#None} valueC)
         [_ _ exported?] (evaluate! archive Bit exported?C)
         _ (/////declaration.lifted_analysis
            (moduleA.define short_name {.#Definition [(as Bit exported?) type value]}))
         _ (..refresh expander host_analysis)
         _ (..announce_definition! short_name type)]
        (in /////declaration.no_requirements))

      _
      (phase.except ///.invalid_syntax [extension_name %.code inputsC+]))))

(def (announce_labels! labels owner)
  (All (_ anchor expression declaration)
    (-> (List Text) Type (Operation anchor expression declaration (List Any))))
  (/////declaration.lifted_generation
   (monad.each phase.monad
               (function (_ tag)
                 (/////generation.log! (format tag " : Tag of " (%.type owner))))
               labels)))

(def (def_type_tagged expander host_analysis)
  (-> Expander /////analysis.Bundle Handler)
  (..custom
   [(all <>.and <code>.local <code>.any
         (<>.or (<code>.variant (<>.some <code>.text))
                (<code>.tuple (<>.some <code>.text)))
         <code>.any)
    (function (_ extension_name phase archive [short_name valueC labels exported?C])
      (do phase.monad
        [current_module (/////declaration.lifted_analysis
                         (///.lifted meta.current_module_name))
         .let [full_name [current_module short_name]]
         [_ _ exported?] (evaluate! archive Bit exported?C)
         .let [exported? (as Bit exported?)]
         [type valueT value] (..definition archive full_name {.#Some .Type} valueC)
         labels (/////declaration.lifted_analysis
                 (do phase.monad
                   [.let [[record? labels] (case labels
                                             {.#Left tags}
                                             [false tags]
                                             
                                             {.#Right slots}
                                             [true slots])]
                    _ (case labels
                        {.#End}
                        (moduleA.define short_name {.#Definition [exported? type value]})

                        {.#Item labels}
                        (moduleA.define short_name {.#Type [exported? (as .Type value) (if record?
                                                                                         {.#Right labels}
                                                                                         {.#Left labels})]}))
                    _ (moduleA.declare_labels record? labels exported? (as .Type value))]
                   (in labels)))
         _ (..refresh expander host_analysis)
         _ (..announce_definition! short_name type)
         _ (..announce_labels! labels (as Type value))]
        (in /////declaration.no_requirements)))]))

(def imports
  (Parser (List Import))
  (|> (<code>.tuple (<>.and <code>.text <code>.text))
      <>.some
      <code>.tuple))

(def defmodule
  Handler
  (..custom
   [..imports
    (function (_ extension_name phase archive imports)
      (do [! phase.monad]
        [_ (/////declaration.lifted_analysis
            (monad.each ! (function (_ [module alias])
                            (do !
                              [_ (moduleA.import module)]
                              (case alias
                                "" (in [])
                                _ (moduleA.alias alias module))))
                        imports))]
        (in [/////declaration.#imports imports
             /////declaration.#referrals (list)])))]))

(exception .public (cannot_alias_an_alias [local Alias
                                           foreign Alias
                                           target Symbol])
  (exception.report
   (list ["Local alias" (%.symbol local)]
         ["Foreign alias" (%.symbol foreign)]
         ["Target definition" (%.symbol target)])))

(exception .public (cannot_alias_a_label [local Alias
                                          foreign Alias])
  (exception.report
   (list ["Alias" (%.symbol local)]
         ["Label" (%.symbol foreign)])))

(def (define_alias alias original)
  (-> Text Symbol (/////analysis.Operation Any))
  (do phase.monad
    [current_module (///.lifted meta.current_module_name)
     constant (///.lifted (meta.definition original))]
    (case constant
      {.#Alias de_aliased}
      (phase.except ..cannot_alias_an_alias [[current_module alias] original de_aliased])
      
      (^.or {.#Definition _}
            {.#Type _})
      (moduleA.define alias {.#Alias original})

      (^.or {.#Tag _}
            {.#Slot _})
      (phase.except ..cannot_alias_a_label [[current_module alias] original]))))

(def defalias
  Handler
  (..custom
   [(all <>.and <code>.local <code>.symbol)
    (function (_ extension_name phase archive [alias def_name])
      (do phase.monad
        [_ (///.lifted
            (phase.sub [(the [/////declaration.#analysis /////declaration.#state])
                        (has [/////declaration.#analysis /////declaration.#state])]
                       (define_alias alias def_name)))]
        (in /////declaration.no_requirements)))]))

... TODO: Stop requiring these types and the "swapped" function below to make types line-up.
(with_template [<name> <anonymous>]
  [(def <name>
     Type
     (with_expansions [<original> binary.Binary]
       (let [_ <original>]
         {.#Named (symbol <original>)
                  <anonymous>})))]

  [Binary|Python (Primitive "bytearray")]
  [Binary|DEFAULT (type_literal (array.Array (I64 Any)))]
  )

(def (swapped original replacement)
  (-> Type Type Type Type)
  (function (again type)
    (if (type#= original type)
      replacement
      (case type
        {.#Primitive name parameters}
        {.#Primitive name (list#each again parameters)}

        (^.with_template [<tag>]
          [{<tag> left right}
           {<tag> (again left) (again right)}])
        ([.#Sum]
         [.#Product]
         [.#Function]
         [.#Apply])
        
        (^.or {.#Parameter _}
              {.#Var _}
              {.#Ex _})
        type

        (^.with_template [<tag>]
          [{<tag> closure body}
           {<tag> closure (again body)}])
        ([.#UnivQ]
         [.#ExQ])
        
        {.#Named name anonymous}
        {.#Named name (again anonymous)}))))

(with_template [<description> <mame> <def_type> <type> <scope> <definer>]
  [(def (<mame> [anchorT expressionT declarationT] extender)
     (All (_ anchor expression declaration)
       (-> [Type Type Type] Extender
           (Handler anchor expression declaration)))
     (function (handler extension_name phase archive inputsC+)
       (case inputsC+
         (list nameC valueC)
         (do phase.monad
           [target_platform (/////declaration.lifted_analysis
                             (///.lifted meta.target))
            [_ _ name] (evaluate! archive Text nameC)
            [_ handlerV] (<definer> archive (as Text name)
                                    (let [raw_type (type_literal <def_type>)]
                                      (case target_platform
                                        (^.or @.jvm
                                              @.js)
                                        raw_type
                                        
                                        @.python
                                        (swapped binary.Binary Binary|Python raw_type)

                                        _
                                        (swapped binary.Binary Binary|DEFAULT raw_type)))
                                    valueC)
            _ (<| <scope>
                  (///.install extender (as Text name))
                  (sharing [anchor expression declaration]
                    (is (Handler anchor expression declaration)
                        handler)
                    (is <type>
                        (as_expected handlerV))))
            _ (/////declaration.lifted_generation
               (/////generation.log! (format <description> " " (%.text (as Text name)))))]
           (in /////declaration.no_requirements))

         _
         (phase.except ///.invalid_syntax [extension_name %.code inputsC+]))))]

  ["Analysis"
   def_analysis
   /////analysis.Handler /////analysis.Handler
   /////declaration.lifted_analysis
   ..analyser]
  ["Synthesis"
   def_synthesis
   /////synthesis.Handler /////synthesis.Handler
   /////declaration.lifted_synthesis
   ..synthesizer]
  ["Generation"
   def_generation
   (/////generation.Handler anchorT expressionT declarationT) (/////generation.Handler anchor expression declaration)
   /////declaration.lifted_generation
   ..generator]
  ["Declaration"
   def_declaration
   (/////declaration.Handler anchorT expressionT declarationT) (/////declaration.Handler anchor expression declaration)
   (<|)
   ..declaration]
  )

(def (bundle::def expander host_analysis program anchorT,expressionT,declarationT extender)
  (All (_ anchor expression declaration)
    (-> Expander
        /////analysis.Bundle
        (Program expression declaration)
        [Type Type Type]
        Extender
        (Bundle anchor expression declaration)))
  (<| (///bundle.prefix "def")
      (|> ///bundle.empty
          (dictionary.has "module" defmodule)
          (dictionary.has "alias" defalias)
          (dictionary.has "type tagged" (def_type_tagged expander host_analysis))
          (dictionary.has "analysis" (def_analysis anchorT,expressionT,declarationT extender))
          (dictionary.has "synthesis" (def_synthesis anchorT,expressionT,declarationT extender))
          (dictionary.has "generation" (def_generation anchorT,expressionT,declarationT extender))
          (dictionary.has "declaration" (def_declaration anchorT,expressionT,declarationT extender))
          )))

(def .public (bundle expander host_analysis program anchorT,expressionT,declarationT extender)
  (All (_ anchor expression declaration)
    (-> Expander
        /////analysis.Bundle
        (Program expression declaration)
        [Type Type Type]
        Extender
        (Bundle anchor expression declaration)))
  (<| (///bundle.prefix "lux")
      (|> ///bundle.empty
          (dictionary.has "def" (lux::def expander host_analysis))
          (dictionary.composite (..bundle::def expander host_analysis program anchorT,expressionT,declarationT extender)))))