path: root/stdlib/source/library/lux/meta/compiler/language/lux/phase/translation/ruby/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 Synthesis 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
      ["_" ruby (.only Expression LVar 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]
     ["[1][0]" synthesis (.only Synthesis Path)
      [access
       ["[0]" member (.only Member)]]]
     ["//[1]" ///
      [reference
       ["[1][0]" variable (.only Register)]]
      [meta
       [archive (.only Archive)]]]]]]])

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

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

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

(def .public (exec expression archive [this that])
  (Translator [Synthesis Synthesis])
  (do phase.monad
    [this (expression archive this)
     that (expression archive that)]
    (in (|> (_.array (list this that))
            (_.item (_.int +1))))))

(def .public (exec! statement expression archive [this that])
  (Translator! [Synthesis Synthesis])
  (do phase.monad
    [this (expression archive this)
     that (statement expression archive that)]
    (in (all _.then
             (_.statement this)
             that
             ))))

(def .public (let expression archive [valueS register bodyS])
  (Translator [Synthesis Register Synthesis])
  (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 (|> bodyO
            _.return
            [(list (..register register))] (_.lambda {.#None})
            (_.apply_lambda (list valueO))))))

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

(def .public (if expression archive [testS thenS elseS])
  (Translator [Synthesis Synthesis Synthesis])
  (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 Synthesis Synthesis])
  (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])
  (do phase.monad
    [valueO (expression 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 @savepoint (_.local "lux_pm_savepoint"))
(def @cursor (_.local "lux_pm_cursor"))
(def @temp (_.local "lux_pm_temp"))

(def (push! value)
  (-> Expression Statement)
  (_.statement (|> @cursor (_.do "push" (list value) {.#None}))))

(def peek_and_pop
  Expression
  (|> @cursor (_.do "pop" (list) {.#None})))

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

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

(def save!
  Statement
  (.let [cursor (_.array_range (_.int +0) (_.int -1) @cursor)]
    (_.statement (|> @savepoint (_.do "push" (list cursor) {.#None})))))

(def restore!
  Statement
  (_.set (list @cursor) (|> @savepoint (_.do "pop" (list) {.#None}))))

(def fail! _.break)

(def (multi_pop! pops)
  (-> Nat Statement)
  (_.statement (_.do "slice!"
                 (list (_.int (i.* -1 (.int pops)))
                       (_.int (.int pops)))
                 {.#None}
                 @cursor)))

(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 (with_looping in_closure? g!once g!continue? body!)
  (-> Bit LVar LVar Statement Statement)
  (.if in_closure?
    (all _.then
         (_.while (_.bool true)
                  body!))
    (all _.then
         (_.set (list g!once) (_.bool true))
         (_.set (list g!continue?) (_.bool false))
         (<| (_.while (_.bool true))
             (_.if g!once
               (all _.then
                    (_.set (list g!once) (_.bool false))
                    body!)
               (all _.then
                    (_.set (list g!continue?) (_.bool true))
                    _.break)))
         (_.when g!continue?
           _.next))))

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

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

               {.#None}
               (in ..fail!))]
      (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!
                               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 (Translator! Path))
  (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))

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

          (^.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 phase.monad
            [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 phase.monad
              [next! (again nextP')]
              (phase#in (all _.then
                             (..multi_pop! (n.+ 2 extra_pops))
                             next!))))

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

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

(def (pattern_matching in_closure? statement expression archive pathP)
  (-> Bit (Translator! Path))
  (do phase.monad
    [pattern_matching! (pattern_matching' in_closure? statement expression archive pathP)
     g!once (..symbol "once")
     g!continue? (..symbol "continue")]
    (in (all _.then
             (..with_looping in_closure? g!once g!continue?
               pattern_matching!)
             (_.statement (_.raise (_.string when.pattern_matching_error)))))))

(def .public (when! in_closure? statement expression archive [valueS pathP])
  (-> Bit (Translator! [Synthesis 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) (_.array (list stack_init)))
             (_.set (list @savepoint) (_.array (list)))
             pattern_matching!
             ))))

(def .public (when statement expression archive when)
  (-> Phase! (Translator [Synthesis Path]))
  (|> when
      (when! true statement expression archive)
      (of phase.monad each
          (|>> [(list)] (_.lambda {.#None})
               (_.apply_lambda (list))))))