path: root/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/python/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 symbol)
   [abstract
    ["[0]" monad (.only do)]]
   [data
    ["[0]" text (.only)
     ["%" \\format (.only format)]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor mix)]
     ["[0]" set]]]
   [math
    [number
     ["n" nat]
     ["i" int]]]
   [meta
    [macro
     ["^" pattern]]
    [compiler
     [target
      ["_" python (.only Expression SVar Statement)]]]]]]
 ["[0]" //
  ["[1][0]" runtime (.only Operation Phase Translator Phase! Translator!)]
  ["[1][0]" reference]
  ["[1][0]" primitive]
  ["/[1]" //
   ["[1][0]" reference]
   ["/[1]" //
    [synthesis
     ["[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)]
       ["[0]" cache
        [dependency
         ["[1]" artifact]]]]]]]]])

(def .public (symbol prefix)
  (-> Text (Operation SVar))
  (phase#each (|>> %.nat (format prefix) _.var)
              /////translation.next))

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

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

(def .public (let expression archive [[register valueS] bodyS])
  (Translator (synthesis.Let synthesis.Term))
  (do phase.monad
    [valueO (expression archive valueS)
     bodyO (expression archive bodyS)]
    ... TODO: Find some way to do 'let' without paying the price of the closure.
    (in (_.apply (list valueO)
                 (_.lambda (list (..register register))
                           bodyO)))))

(def .public (let! statement expression archive [[register valueS] bodyS])
  (Translator! (synthesis.Let synthesis.Term))
  (do phase.monad
    [valueO (expression archive valueS)
     bodyO (statement expression archive bodyS)]
    (in (all _.then
             (_.set (list (..register register)) valueO)
             bodyO))))

(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 +1)
                (_.tuple (list (_.tuple all_before)
                               after))))))

(def .public (exec! statement expression archive [pre post])
  (Translator! (synthesis.Exec synthesis.Term))
  (do phase.monad
    [pre (expression archive pre)
     post (statement expression archive post)]
    (in (all _.then
             (_.statement pre)
             post))))

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

(def .public (if! statement expression archive [testS thenS elseS])
  (Translator! [synthesis.Term synthesis.Term synthesis.Term])
  (do phase.monad
    [test! (expression archive testS)
     then! (statement expression archive thenS)
     else! (statement expression archive elseS)]
    (in (_.if test!
          then!
          else!))))

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

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

(def (push! value)
  (-> (Expression Any) (Statement Any))
  (_.statement (|> @cursor (_.do "append" (list value)))))

(def peek_and_pop
  (Expression Any)
  (|> @cursor (_.do "pop" (list))))

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

(def peek
  (Expression Any)
  (_.item (_.int -1) @cursor))

(def save!
  (Statement Any)
  (.let [cursor (_.slice_from (_.int +0) @cursor)]
    (_.statement (|> @savepoint (_.do "append" (list cursor))))))

(def restore!
  (Statement Any)
  (_.set (list @cursor) (|> @savepoint (_.do "pop" (list)))))

(def fail_pm! _.break)

(def (multi_pop! pops)
  (-> Nat (Statement Any))
  (_.delete (_.slice_from (_.int (i.* -1 (.int pops))) @cursor)))

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

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

(def (with_looping in_closure? g!once body!)
  (-> Bit SVar (Statement Any) (Statement Any))
  (.if in_closure?
    (_.while (_.bool true)
             body!
             {.#None})
    (all _.then
         (_.set (list g!once) (_.bool true))
         (_.while g!once
                  (all _.then
                       (_.set (list g!once) (_.bool false))
                       body!)
                  {.#Some _.continue}))))

(def (alternation in_closure? g!once pre! post!)
  (-> Bit SVar (Statement Any) (Statement Any) (Statement Any))
  (all _.then
       (..with_looping in_closure? g!once
         (all _.then
              ..save!
              pre!))
       ..restore!
       post!))

(def (primitive_pattern_matching again pathP)
  (-> (-> Path (Operation (Statement Any)))
      (-> Path (Operation (Maybe (Statement Any)))))
  (.when pathP
    {synthesis.#Bit_Fork when thenP elseP}
    (do [! phase.monad]
      [then! (again thenP)
       else! (.when elseP
               {.#Some elseP}
               (again elseP)

               {.#None}
               (in ..fail_pm!))]
      (in {.#Some (.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])
                                  (of ! each
                                      (|>> [(_.= (|> match <format>)
                                                 ..peek)])
                                      (again then)))
                              {.#Item item})]
         (in {.#Some (list#mix (function (_ [when then] else)
                                 (_.if when then else))
                               ..fail_pm!
                               clauses)}))])
    ([synthesis.#I64_Fork (<| //primitive.i64 .int)]
     [synthesis.#F64_Fork (<| //primitive.f64)]
     [synthesis.#Text_Fork (<| //primitive.text)])

    _
    (of phase.monad in {.#None})))

(def (pattern_matching' in_closure? statement expression archive)
  (-> Bit Phase! Phase Archive Path (Operation (Statement Any)))
  (function (again pathP)
    (do [! phase.monad]
      [?output (primitive_pattern_matching again pathP)]
      (.when ?output
        {.#Some output}
        (in output)

        {.#None}
        (.when pathP
          {synthesis.#Then bodyS}
          (statement expression archive bodyS)

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

          {synthesis.#Bind register}
          (phase#in (_.set (list (..register register)) ..peek))

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

             (<simple> idx nextP)
             (|> nextP
                 again
                 (phase#each (_.then (<choice> true idx))))])
          ([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 +0)) ..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 !
            [then! (again thenP)]
            (phase#in (all _.then
                           (_.set (list (..register register)) ..peek_and_pop)
                           then!)))

          (synthesis.!multi_pop nextP)
          (.let [[extra_pops nextP'] (when.count_pops nextP)]
            (do !
              [next! (again nextP')]
              (phase#in (all _.then
                             (..multi_pop! (n.+ 2 extra_pops))
                             next!))))

          (synthesis.path/seq preP postP)
          (do !
            [pre! (again preP)
             post! (again postP)]
            (in (_.then pre! post!)))

          (synthesis.path/alt preP postP)
          (do !
            [pre! (again preP)
             post! (again postP)
             g!once (..symbol "once")]
            (in (..alternation in_closure? g!once pre! post!)))

          _
          (undefined))))))

(def (pattern_matching in_closure? statement expression archive pathP)
  (-> Bit Phase! Phase Archive Path (Operation (Statement Any)))
  (do phase.monad
    [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP)
     g!once (..symbol "once")]
    (in (all _.then
             (..with_looping in_closure? g!once
               pattern_matching!)
             (_.raise (_.Exception/1 (_.string when.pattern_matching_error)))))))

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

(def .public (when! in_closure? statement expression archive [valueS pathP])
  (-> Bit (Translator! [synthesis.Term Path]))
  (do phase.monad
    [stack_init (expression archive valueS)
     pattern_matching! (pattern_matching in_closure? statement expression archive pathP)]
    (in (all _.then
             (_.set (list @cursor) (_.list (list stack_init)))
             (_.set (list @savepoint) (_.list (list)))
             pattern_matching!
             ))))

(def .public (when statement expression archive [valueS pathP])
  (-> Phase! (Translator [synthesis.Term Path]))
  (do phase.monad
    [dependencies (cache.path_dependencies archive pathP)
     [[when_module when_artifact] pattern_matching!] (/////translation.with_new_context
                                                       archive
                                                       dependencies
                                                       (when! true statement expression archive [valueS pathP]))
     .let [@when (_.var (///reference.artifact [when_module when_artifact]))
           @dependencies+ (..dependencies (synthesis.path/seq (synthesis.path/then valueS)
                                                              pathP))
           declaration (_.def @when @dependencies+
                         pattern_matching!)]
     _ (/////translation.execute! declaration)
     _ (/////translation.save! when_artifact {.#None} declaration)]
    (in (_.apply @dependencies+ @when))))