path: root/stdlib/source/library/lux/tool/compiler/language/lux/phase/generation/ruby/runtime.lux

(.require
 [library
  [lux (.except i64 left right)
   [abstract
    ["[0]" monad (.only do)]]
   [control
    ["<>" parser]
    ["[0]" function]]
   [data
    ["[0]" product]
    ["[0]" text (.use "[1]#[0]" hash)
     ["%" \\format (.only format)]
     [encoding
      ["[0]" utf8]]]
    [collection
     ["[0]" list (.use "[1]#[0]" functor mix)]
     ["[0]" sequence]]]
   ["[0]" macro (.only)
    [syntax (.only syntax)]]
   [math
    [number (.only hex)
     ["[0]" i64]
     ["[0]" int (.use "[1]#[0]" interval)]]]
   ["[0]" meta (.only)
    ["[0]" code (.only)
     ["<[1]>" \\parser]]]
   ["@" target (.only)
    ["_" ruby (.only Expression LVar Computation Literal Statement)]]]]
 ["[0]" ///
  ["[1][0]" reference]
  ["//[1]" ///
   ["[1][0]" synthesis (.only Synthesis)]
   ["[1][0]" generation]
   ["//[1]" /// (.only)
    ["[1][0]" phase]
    [reference
     [variable (.only Register)]]
    [meta
     [archive (.only Output Archive)
      ["[0]" unit]
      ["[0]" registry (.only Registry)]]]]]])

(with_template [<name> <base>]
  [(type .public <name>
     (<base> Register Expression Statement))]

  [Operation /////generation.Operation]
  [Phase /////generation.Phase]
  [Handler /////generation.Handler]
  [Bundle /////generation.Bundle]
  )

(type .public (Generator i)
  (-> Phase Archive i (Operation Expression)))

(type .public Phase!
  (-> Phase Archive Synthesis (Operation Statement)))

(type .public (Generator! i)
  (-> Phase! Phase Archive i (Operation Statement)))

(def .public unit
  (_.string /////synthesis.unit))

(def (flag value)
  (-> Bit Literal)
  (if value
    ..unit
    _.nil))

(def .public with_vars
  (syntax (_ [vars (<code>.tuple (<>.some <code>.local))
              body <code>.any])
    (do [! meta.monad]
      [ids (monad.all ! (list.repeated (list.size vars) meta.seed))]
      (in (list (` (let [(,* (|> vars
                                 (list.zipped_2 ids)
                                 (list#each (function (_ [id var])
                                              (list (code.local var)
                                                    (` (_.local (, (code.text (format "v" (%.nat id)))))))))
                                 list.together))]
                     (, body))))))))

(def module_id
  0)

(def $Numeric
  _.CVar
  (_.manual "Numeric"))

(def mruby?
  _.Expression
  (_.and (|> $Numeric
             (_.do "method_defined?" (list (_.string "remainder")) {.#None})
             _.not)
         (|> $Numeric
             (_.do "method_defined?" (list (_.string "remainder_of_divide")) {.#None}))))

(def normal_ruby?
  _.Expression
  (_.not ..mruby?)
  ... (|> (_.local "Object")
  ...     (_.do "const_defined?" (list (_.string "Encoding")) {.#None}))
  )

(def runtime
  (syntax (_ [declaration (<>.or <code>.local
                                 (<code>.form (<>.and <code>.local
                                                      (<>.some <code>.local))))
              conditional_implementations (<>.some (<code>.tuple (<>.and <code>.any <code>.any)))
              default_implementation <code>.any])
    (do meta.monad
      [runtime_id meta.seed]
      (macro.with_symbols [g!_]
        (case declaration
          {.#Left name}
          (macro.with_symbols [g!_]
            (let [runtime (code.local (///reference.artifact [..module_id runtime_id]))
                  runtime_name (` (_.constant (, (code.text (%.code runtime)))))
                  g!name (code.local name)]
              (in (list (` (def .public (, g!name) _.CVar (, runtime_name)))
                        (` (def (, (code.local (format "@" name)))
                             Statement
                             (, (list#mix (function (_ [when then] else)
                                            (` (_.if (, when)
                                                 (_.set (list (, runtime_name)) (, then))
                                                 (, else))))
                                          (` (_.set (list (, runtime_name)) (, default_implementation)))
                                          conditional_implementations))))))))
          
          {.#Right [name inputs]}
          (macro.with_symbols [g!_]
            (let [runtime (code.local (///reference.artifact [..module_id runtime_id]))
                  runtime_name (` (_.local (, (code.text (%.code runtime)))))
                  g!name (code.local name)
                  inputsC (list#each code.local inputs)
                  inputs_typesC (list#each (function.constant (` _.Expression))
                                           inputs)]
              (in (list (` (def .public ((, g!name) (,* inputsC))
                             (-> (,* inputs_typesC) Computation)
                             (_.apply (list (,* inputsC)) {.#None}
                                      (, runtime_name))))
                        
                        (` (def (, (code.local (format "@" name)))
                             Statement
                             (..with_vars [(,* inputsC)]
                               (, (list#mix (function (_ [when then] else)
                                              (` (_.if (, when)
                                                   (_.function (, runtime_name) (list (,* inputsC))
                                                     (, then))
                                                   (, else))))
                                            (` (_.function (, runtime_name) (list (,* inputsC))
                                                 (, default_implementation)))
                                            conditional_implementations))))))))))))))

(def tuple_size
  (_.the "length"))

(def last_index
  (|>> ..tuple_size (_.- (_.int +1))))

(with_expansions [<recur> (these (all _.then
                                      (_.set (list lefts) (_.- last_index_right lefts))
                                      (_.set (list tuple) (_.item last_index_right tuple))))]
  (runtime
   (tuple//left lefts tuple)
   (with_vars [last_index_right]
     (<| (_.while (_.bool true))
         (all _.then
              (_.set (list last_index_right) (..last_index tuple))
              (_.if (_.> lefts last_index_right)
                ... No need for recursion
                (_.return (_.item lefts tuple))
                ... Needs recursion
                <recur>)))))

  (runtime
   (tuple//right lefts tuple)
   (with_vars [last_index_right right_index]
     (<| (_.while (_.bool true))
         (all _.then
              (_.set (list last_index_right) (..last_index tuple))
              (_.set (list right_index) (_.+ (_.int +1) lefts))
              (<| (_.if (_.= last_index_right right_index)
                    (_.return (_.item right_index tuple)))
                  (_.if (_.> last_index_right right_index)
                    ... Needs recursion.
                    <recur>)
                  (_.return (_.array_range right_index (..tuple_size tuple) tuple)))
              )))))

(def .public variant_tag_field "_lux_tag")
(def .public variant_flag_field "_lux_flag")
(def .public variant_value_field "_lux_value")

(runtime
 (sum//make tag last? value)
 (_.return (_.hash (list [(_.string ..variant_tag_field) tag]
                         [(_.string ..variant_flag_field) last?]
                         [(_.string ..variant_value_field) value]))))

(def .public (variant tag last? value)
  (-> Nat Bit Expression Computation)
  (sum//make (_.int (.int tag)) (..flag last?) value))

(def .public left
  (-> Expression Computation)
  (..variant 0 #0))

(def .public right
  (-> Expression Computation)
  (..variant 0 #1))

(def .public none
  Computation
  (..left ..unit))

(def .public some
  (-> Expression Computation)
  ..right)

(runtime
 (sum//get sum expected::right? expected::lefts)
 (let [mismatch! (_.return _.nil)
       actual::lefts (_.item (_.string ..variant_tag_field) sum)
       actual::right? (_.item (_.string ..variant_flag_field) sum)
       actual::value (_.item (_.string ..variant_value_field) sum)
       recur! (all _.then
                   (_.set (list expected::lefts) (|> expected::lefts
                                                     (_.- actual::lefts)
                                                     (_.- (_.int +1))))
                   (_.set (list sum) actual::value))]
   (<| (_.while (_.bool true))
       (_.if (_.= expected::lefts actual::lefts)
         (_.if (_.= expected::right? actual::right?)
           (_.return actual::value)
           mismatch!))
       (_.if (_.< expected::lefts actual::lefts)
         (_.if (_.= ..unit actual::right?)
           recur!
           mismatch!))
       (_.if (_.= ..unit expected::right?)
         (_.return (sum//make (|> actual::lefts
                                  (_.- expected::lefts)
                                  (_.- (_.int +1)))
                              actual::right?
                              actual::value)))
       mismatch!)))

(def runtime//adt
  Statement
  (all _.then
       @tuple//left
       @tuple//right
       @sum//make
       @sum//get
       ))

(runtime
 (lux//try risky)
 (with_vars [error value]
   (_.begin (all _.then
                 (_.set (list value) (_.apply_lambda (list ..unit) risky))
                 (_.return (..right value)))
            (list [(list) error
                   (_.return (..left (_.the "message" error)))]))))

(runtime
 (lux//program_args raw)
 (with_vars [tail head]
   (all _.then
        (_.set (list tail) ..none)
        (<| (_.for_in head raw)
            (_.set (list tail) (..some (_.array (list head tail)))))
        (_.return tail))))

(def runtime//lux
  Statement
  (all _.then
       @lux//try
       @lux//program_args
       ))

(def i64::+limit (_.manual "+0x7FFFFFFFFFFFFFFF"))
(def i64::-limit (_.manual "-0x8000000000000000"))
(def i64::+cap (_.manual "+0x8000000000000000"))
(def i64::-cap (_.manual "-0x8000000000000001"))

(runtime
 i64::+iteration (_.manual "(+1<<64)"))
(runtime
 i64::-iteration (_.manual "(-1<<64)"))

(runtime
 (i64::i64 input)
 [..mruby? (_.return input)]
 (with_vars [temp]
   (`` (<| (,, (with_template [<scenario> <iteration> <cap> <entrance>]
                 [(_.if (|> input <scenario>)
                    (all _.then
                         (_.set (list temp) (_.% <iteration> input))
                         (_.return (_.? (|> temp <scenario>)
                                        (|> temp (_.- <cap>) (_.+ <entrance>))
                                        temp))))]

                 [(_.> ..i64::+limit) ..i64::+iteration ..i64::+cap ..i64::-limit]
                 [(_.< ..i64::-limit) ..i64::-iteration ..i64::-cap ..i64::+limit]
                 ))
           (_.return input)))))

(def i32::low
  (|>> (_.bit_and (_.manual "+0xFFFFFFFF"))))

(def i32::high
  (|>> (_.bit_shr (_.int +32))
       ..i32::low))

(def i32::positive?
  (|>> (_.bit_and (_.manual "+0x80000000"))
       (_.= (_.int +0))))

(def i32::up
  (_.bit_shl (_.int +32)))

(def i64
  (template (_ @high @low)
    [(|> (_.? (i32::positive? @high)
              @high
              (|> (_.manual "+0xFFFFFFFF")
                  (_.- @high)
                  _.bit_not))
         i32::up
         (_.bit_or @low))]))

(def as_nat
  (_.% ..i64::+iteration))

(with_template [<runtime> <host>]
  [(runtime
    (<runtime> left right)
    [..normal_ruby? (_.return (..i64::i64 (<host> (..as_nat left) (..as_nat right))))]
    (with_vars [high low]
      (all _.then
           (_.set (list high) (<host> (i32::high left) (..i32::high right)))
           (_.set (list low) (<host> (i32::low left) (..i32::low right)))
           (_.return (..i64 high low)))))]

  [i64::and _.bit_and]
  [i64::or _.bit_or]
  [i64::xor _.bit_xor]
  )

(def (cap_shift! shift)
  (-> LVar Statement)
  (_.set (list shift) (|> shift (_.bit_and (_.int +63)))))

(def (handle_no_shift! shift input)
  (-> LVar LVar (-> Statement Statement))
  (_.if (|> shift (_.= (_.int +0)))
    (_.return input)))

(def small_shift?
  (-> LVar Expression)
  (|>> (_.< (_.int +32))))

(runtime
 (i64::left_shifted shift input)
 [..normal_ruby? (_.return (|> input
                               (_.bit_shl (_.% (_.int +64) shift))
                               ..i64::i64))]
 (with_vars [high low]
   (all _.then
        (..cap_shift! shift)
        (<| (..handle_no_shift! shift input)
            (_.if (..small_shift? shift)
              (all _.then
                   (_.set (list high) (_.bit_or (|> input i32::high (_.bit_shl shift))
                                                (|> input i32::low (_.bit_shr (_.- shift (_.int +32))))))
                   (_.set (list low) (|> input i32::low (_.bit_shl shift)))
                   (_.return (..i64 (i32::low high)
                                    (i32::low low)))))
            (all _.then
                 (_.set (list high) (|> input i32::low (_.bit_shl (_.- (_.int +32) shift))))
                 (_.return (..i64 (i32::low high)
                                  (_.int +0)))))
        )))

(runtime
 (i64::right_shifted shift input)
 [..normal_ruby? (all _.then
                      (_.set (list shift) (_.% (_.int +64) shift))
                      (_.return (_.? (_.= (_.int +0) shift)
                                     input
                                     (|> input
                                         ..as_nat
                                         (_.bit_shr shift)))))]
 (with_vars [high low]
   (all _.then
        (..cap_shift! shift)
        (<| (..handle_no_shift! shift input)
            (_.if (..small_shift? shift)
              (all _.then
                   (_.set (list high) (|> input i32::high (_.bit_shr shift)))
                   (_.set (list low) (|> input i32::low (_.bit_shr shift)
                                         (_.bit_or (|> input i32::high (_.bit_shl (_.- shift (_.int +32)))))))
                   (_.return (..i64 high low))))
            (_.return (_.? (|> shift (_.= (_.int +32)))
                           (i32::high input)
                           (|> input i32::high (_.bit_shr (_.- (_.int +32) shift)))))))))

(runtime
 (i64::/ parameter subject)
 (_.return (_.? (_.and (_.= (_.int -1) parameter)
                       (_.= (_.int int#bottom) subject))
                subject
                (let [extra (_.do "remainder" (list parameter) {.#None} subject)]
                  (|> subject
                      (_.- extra)
                      (_./ parameter))))))

(runtime
 (i64::+ parameter subject)
 [..normal_ruby? (_.return (i64::i64 (_.+ parameter subject)))]
 (with_vars [high low]
   (all _.then
        (_.set (list low) (_.+ (i32::low subject)
                               (i32::low parameter)))
        (_.set (list high) (|> (i32::high low)
                               (_.+ (i32::high subject))
                               (_.+ (i32::high parameter))
                               i32::low))

        (_.return (..i64 high (i32::low low)))
        )))

(def i64::min
  (_.manual "-0x8000000000000000"))

(def (i64::opposite value)
  (_.? (_.= i64::min value)
       i64::min
       (i64::+ (_.int +1) (_.bit_not value))))

(runtime
 (i64::- parameter subject)
 [..normal_ruby? (_.return (i64::i64 (_.- parameter subject)))]
 (_.return (i64::+ (i64::opposite parameter) subject)))

(def i16::high
  (_.bit_shr (_.int +16)))

(def i16::low
  (_.bit_and (_.manual "+0xFFFF")))

(def i16::up
  (_.bit_shl (_.int +16)))

(runtime
 (i64::* parameter subject)
 [..normal_ruby? (_.return (i64::i64 (_.* parameter subject)))]
 (let [hh (|>> i32::high i16::high)
       hl (|>> i32::high i16::low)
       lh (|>> i32::low i16::high)
       ll (|>> i32::low i16::low)]
   (with_vars [l48 l32 l16 l00
               r48 r32 r16 r00
               x48 x32 x16 x00
               high low]
     (all _.then
          (_.set (list l48) (hh subject))
          (_.set (list l32) (hl subject))
          (_.set (list l16) (lh subject))
          (_.set (list l00) (ll subject))

          (_.set (list r48) (hh parameter))
          (_.set (list r32) (hl parameter))
          (_.set (list r16) (lh parameter))
          (_.set (list r00) (ll parameter))

          (_.set (list x00) (_.* l00 r00))
          (_.set (list x16) (i16::high x00))
          (_.set (list x00) (i16::low x00))
          
          (_.set (list x16) (|> x16 (_.+ (_.* l16 r00))))
          (_.set (list x32) (i16::high x16)) (_.set (list x16) (i16::low x16))
          (_.set (list x16) (|> x16 (_.+ (_.* l00 r16))))
          (_.set (list x32) (|> x32 (_.+ (i16::high x16)))) (_.set (list x16) (i16::low x16))

          (_.set (list x32) (|> x32 (_.+ (_.* l32 r00))))
          (_.set (list x48) (i16::high x32)) (_.set (list x32) (i16::low x32))
          (_.set (list x32) (|> x32 (_.+ (_.* l16 r16))))
          (_.set (list x48) (|> x48 (_.+ (i16::high x32)))) (_.set (list x32) (i16::low x32))
          (_.set (list x32) (|> x32 (_.+ (_.* l00 r32))))
          (_.set (list x48) (|> x48 (_.+ (i16::high x32)))) (_.set (list x32) (i16::low x32))
          
          (_.set (list x48) (|> x48
                                (_.+ (_.* l48 r00))
                                (_.+ (_.* l32 r16))
                                (_.+ (_.* l16 r32))
                                (_.+ (_.* l00 r48))
                                i16::low))

          (_.set (list high) (_.bit_or (i16::up x48) x32))
          (_.set (list low) (_.bit_or (i16::up x16) x00))
          (_.return (..i64 high low))
          )))
 )

(runtime
 (i64::char subject)
 [..mruby? (_.return (_.do "chr" (list) {.#None} subject))]
 (_.return (_.do "chr" (list (_.string "UTF-8")) {.#None} subject)))

(def runtime//i64
  Statement
  (all _.then
       @i64::+iteration
       @i64::-iteration
       @i64::i64
       @i64::left_shifted
       @i64::right_shifted
       @i64::and
       @i64::or
       @i64::xor
       @i64::+
       @i64::-
       @i64::*
       @i64::/
       @i64::char
       ))

(runtime
 (f64//decode inputG)
 (with_vars [@input @temp]
   (all _.then
        (_.set (list @input) inputG)
        (_.set (list @temp) (_.do "to_f" (list) {.#None} @input))
        (_.if (all _.or
                   (_.not (_.= (_.float +0.0) @temp))
                   (_.= (_.string "0") @input)
                   (_.= (_.string ".0") @input)
                   (_.= (_.string "0.0") @input))
          (_.return (..some @temp))
          (_.return ..none)))))

(def runtime//f64
  Statement
  (all _.then
       @f64//decode
       ))

(runtime
 (text//index subject param start)
 (with_vars [idx]
   (all _.then
        (_.set (list idx) (|> subject (_.do "index" (list param start) {.#None})))
        (_.if (_.= _.nil idx)
          (_.return ..none)
          (_.return (..some idx))))))

(def (within? top value)
  (-> Expression Expression Computation)
  (_.and (|> value (_.>= (_.int +0)))
         (|> value (_.< top))))

(runtime
 (text//clip offset length text)
 (_.if (_.= (_.int +0) length)
   (_.return (_.string ""))
   (_.return (_.array_range offset (_.+ offset (_.- (_.int +1) length)) text))))

(runtime
 (text//char idx text)
 (_.if (|> idx (within? (_.the "length" text)))
   (_.return (|> text (_.array_range idx idx) (_.do "ord" (list) {.#None})))
   (_.statement (_.raise (_.string "[Lux Error] Cannot get char from text.")))))

(def runtime//text
  Statement
  (all _.then
       @text//index
       @text//clip
       @text//char
       ))

(runtime
 (array//write idx value array)
 (all _.then
      (_.set (list (_.item idx array)) value)
      (_.return array)))

(def runtime//array
  Statement
  (all _.then
       @array//write
       ))

(def runtime
  Statement
  (all _.then
       (_.when ..mruby?
               ... We're in DragonRuby territory.
               (_.statement
                (_.do "class_eval" (list) {.#Some [(list (_.local "_"))
                                                   (_.statement
                                                    (_.alias_method/2 (_.string "remainder")
                                                                      (_.string "remainder_of_divide")))]}
                  $Numeric)))
       runtime//adt
       runtime//lux
       runtime//i64
       runtime//f64
       runtime//text
       runtime//array
       ))

(def .public generate
  (Operation [Registry Output])
  (do ///////phase.monad
    [_ (/////generation.execute! ..runtime)
     _ (/////generation.save! ..module_id {.#None} ..runtime)]
    (in [(|> registry.empty
             (registry.resource true unit.none)
             product.right)
         (sequence.sequence [..module_id
                             {.#None}
                             (|> ..runtime
                                 _.code
                                 (at utf8.codec encoded))])])))