path: root/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/lua/when.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 when exec let if)
   [abstract
    ["[0]" monad (.only do)]]
   [data
    ["[0]" text (.only)
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor mix)]
     ["[0]" set]]]
   [meta
    [macro
     ["^" pattern]]
    [compiler
     [target
      ["_" lua (.only Expression Var Statement)]]]]]]
 ["[0]" //
  ["[1][0]" runtime (.only Operation Phase Phase! Translator Translator!)]
  ["[1][0]" reference]
  ["[1][0]" primitive]
  ["/[1]" //
   ["[1][0]" reference]
   ["/[1]" //
    ["[1][0]" synthesis
     ["[1]/[0]" when]]
    ["/[1]" //
     ["[0]" phase (.use "[1]#[0]" monad)]
     ["[1][0]" translation]
     ["[0]" synthesis (.only Path)
      [access
       ["[0]" member (.only Member)]]]
     ["//[1]" ///
      [reference
       ["[1][0]" variable (.only Register)]]
      [meta
       [archive (.only Archive)]]]]]]])

(def .public register
  (-> Register
      Var)
  (|>> (///reference.local //reference.system) as_expected))

(def .public capture
  (-> Register
      Var)
  (|>> (///reference.foreign //reference.system) as_expected))

(def .public (exec next archive it)
  (Translator (synthesis.Exec synthesis.Term))
  (do [! phase.monad]
    [.let [[tail after] (synthesis.flat_exec (the synthesis.#after it))]
     all_before (monad.each ! (next archive)
                            (list.partial (the synthesis.#before it) tail))
     after (next archive after)]
    (in (_.item (_.int +2)
                (_.array (list (_.array all_before)
                               after))))))

(def .public (exec! statement next archive [this that])
  (Translator! (synthesis.Exec synthesis.Term))
  (do [! phase.monad]
    [this (next archive this)
     that (statement next archive that)
     $dummy (of ! each _.var (/////translation.symbol "_exec"))]
    (in (all _.then
             (_.set (list $dummy) this)
             that))))

(def .public (let next archive it)
  (Translator (synthesis.Let synthesis.Term))
  (do [! phase.monad]
    [.let [[tail body] (synthesis.flat_let (the synthesis.#expression it))
           context (the synthesis.#context it)]
     bindings (monad.each ! (function (_ [binding value])
                              (phase#each (_.local/1 (..register binding))
                                          (next archive value)))
                          (list.partial context
                                        tail))
     body (next archive body)]
    ... TODO: Find some way to do 'let' without paying the price of the closure.
    (in (<| (_.apply (list))
            (_.closure (list))
            (list#mix _.then
                      (_.return body)
                      (list.reversed bindings))))))

(def .public (let! statement next archive [[register valueS] bodyS])
  (Translator! (synthesis.Let synthesis.Term))
  (do phase.monad
    [valueO (next archive valueS)
     bodyO (statement next archive bodyS)]
    (in (all _.then
             (_.local/1 (..register register) valueO)
             bodyO))))

(def .public (get next archive [pathP valueS])
  (Translator [(List Member) synthesis.Term])
  (do phase.monad
    [valueO (next archive valueS)]
    (in (list#mix (function (_ side source)
                    (.let [method (.if (the member.#right? side)
                                    (//runtime.tuple//right (_.int (.int (the member.#lefts side))))
                                    (//runtime.tuple//left (_.int (.int (the member.#lefts side)))))]
                      (method source)))
                  valueO
                  pathP))))

(def .public (if next archive [testS thenS elseS])
  (Translator [synthesis.Term synthesis.Term synthesis.Term])
  (do phase.monad
    [testO (next archive testS)
     thenO (next archive thenS)
     elseO (next archive elseS)]
    (in (|> (_.if testO
              (_.return thenO)
              (_.return elseO))
            (_.closure (list))
            (_.apply (list))))))

(def .public (if! statement next archive [testS thenS elseS])
  (Translator! [synthesis.Term synthesis.Term synthesis.Term])
  (do phase.monad
    [testO (next archive testS)
     thenO (statement next archive thenS)
     elseO (statement next archive elseS)]
    (in (_.if testO
          thenO
          elseO))))

(def @savepoint (_.var "lux_pm_savepoint"))
(def @cursor (_.var "lux_pm_cursor"))
(def @temp (_.var "lux_pm_temp"))

(def (push! value)
  (-> Expression
      Statement)
  (_.statement (|> (_.var "table.insert") (_.apply (list @cursor value)))))

(def peek_and_pop
  Expression
  (|> (_.var "table.remove") (_.apply (list @cursor))))

(def pop!
  Statement
  (_.statement ..peek_and_pop))

(def peek
  Expression
  (_.item (_.length @cursor) @cursor))

(def save!
  Statement
  (_.statement (|> (_.var "table.insert")
                   (_.apply (list @savepoint
                                  (_.apply (list @cursor
                                                 (_.int +1)
                                                 (_.length @cursor)
                                                 (_.int +1)
                                                 (_.table (list)))
                                           (_.var "table.move")))))))

(def restore!
  Statement
  (_.set (list @cursor) (|> (_.var "table.remove") (_.apply (list @savepoint)))))

(def fail! _.break)

(with_template [<name> <flag>]
  [(def (<name> simple? idx)
     (-> Bit Nat
         Statement)
     (all _.then
          (_.set (list @temp) (//runtime.sum//get ..peek <flag>
                                                  (|> idx .int _.int)))
          (.if simple?
            (_.when (_.= _.nil @temp)
              fail!)
            (_.if (_.= _.nil @temp)
              fail!
              (..push! @temp)))))]

  [left_choice  _.nil]
  [right_choice //runtime.unit]
  )

(def (alternation pre! post!)
  (-> Statement Statement
      Statement)
  (all _.then
       (_.while (_.boolean true)
                (all _.then
                     ..save!
                     pre!))
       (all _.then
            ..restore!
            post!)))

(def (pattern_matching' statement next archive)
  (-> Phase! Phase Archive Path
      (Operation Statement))
  (function (again pathP)
    (.when pathP
      {synthesis.#Then bodyS}
      (statement next archive bodyS)

      {synthesis.#Pop}
      (phase#in ..pop!)

      {synthesis.#Bind register}
      (phase#in (_.local/1 (..register register) ..peek))

      {synthesis.#Bit_Fork when thenP elseP}
      (do [! phase.monad]
        [then! (again thenP)
         else! (.when elseP
                 {.#Some elseP}
                 (again elseP)

                 {.#None}
                 (in ..fail!))]
        (in (.if when
              (_.if ..peek
                then!
                else!)
              (_.if ..peek
                else!
                then!))))

      (^.with_template [<tag> <format>]
        [{<tag> item}
         (do [! phase.monad]
           [clauses (monad.each ! (function (_ [match then])
                                    (do !
                                      [then! (again then)]
                                      (in [(_.= (|> match <format>)
                                                ..peek)
                                           then!])))
                                {.#Item item})]
           (in (list#mix (function (_ [when then!] else!)
                           (_.if when then! else!))
                         ..fail!
                         clauses)))])
      ([synthesis.#I64_Fork (<| _.int .int)]
       [synthesis.#F64_Fork _.float]
       [synthesis.#Text_Fork _.string])

      (^.with_template [<complex> <simple> <choice>]
        [(<complex> idx)
         (phase#in (<choice> false idx))

         (<simple> idx nextP)
         (phase#each (_.then (<choice> true idx)) (again nextP))])
      ([synthesis.side/left  synthesis.simple_left_side  ..left_choice]
       [synthesis.side/right synthesis.simple_right_side ..right_choice])

      (synthesis.member/left 0)
      (phase#in (|> ..peek (_.item (_.int +1)) ..push!))
      
      (^.with_template [<pm> <getter>]
        [(<pm> lefts)
         (phase#in (|> ..peek (<getter> (_.int (.int lefts))) ..push!))])
      ([synthesis.member/left  //runtime.tuple//left]
       [synthesis.member/right //runtime.tuple//right])

      (synthesis.!bind_top register thenP)
      (do phase.monad
        [then! (again thenP)]
        (phase#in (all _.then
                       (_.local/1 (..register register) ..peek_and_pop)
                       then!)))

      (^.with_template [<tag> <combinator>]
        [(<tag> preP postP)
         (do phase.monad
           [pre! (again preP)
            post! (again postP)]
           (in (<combinator> pre! post!)))])
      ([synthesis.path/seq _.then]
       [synthesis.path/alt ..alternation]))))

(def (pattern_matching statement next archive pathP)
  (-> Phase! Phase Archive Path
      (Operation Statement))
  (do phase.monad
    [pattern_matching! (pattern_matching' statement next archive pathP)]
    (in (all _.then
             (_.while (_.boolean true)
                      pattern_matching!)
             (_.statement (|> (_.var "error") (_.apply (list (_.string ////synthesis/when.pattern_matching_error)))))))))

(def .public dependencies
  (-> Path
      (List Var))
  (|>> ////synthesis/when.storage
       (the ////synthesis/when.#dependencies)
       set.list
       (list#each (function (_ variable)
                    (.when variable
                      {///////variable.#Local register}
                      (..register register)
                      
                      {///////variable.#Foreign register}
                      (..capture register))))))

(def .public (when! statement next archive [valueS pathP])
  (Translator! [synthesis.Term Path])
  (do phase.monad
    [stack_init (next archive valueS)
     pattern_matching! (pattern_matching statement next archive pathP)]
    (in (all _.then
             (_.local (list @temp))
             (_.local/1 @cursor (_.array (list stack_init)))
             (_.local/1 @savepoint (_.array (list)))
             pattern_matching!))))

(def .public (when statement next archive [valueS pathP])
  (-> Phase!
      (Translator [synthesis.Term Path]))
  (|> [valueS pathP]
      (..when! statement next archive)
      (of phase.monad each
          (|>> (_.closure (list))
               (_.apply (list))))))