path: root/stdlib/source/lux/tool/compiler/phase/generation/lua/runtime.lux

(.module:
  [lux (#- inc)
   [abstract
    [monad (#+ do)]]
   [control
    ["." function]
    ["p" parser
     ["s" code]]]
   [data
    [number (#+ hex)
     ["." i64]]
    ["." text
     format]
    [collection
     ["." list ("#@." functor)]]]
   ["." macro
    ["." code]
    [syntax (#+ syntax:)]]
   [host
    ["_" lua (#+ Expression Location Var Computation Literal Statement)]]]
  ["." ///
   ["//." //
    [//
     ["/////." name]
     ["." synthesis]]]]
  )

(template [<name> <base>]
  [(type: #export <name>
     (<base> Var (Expression Any) Statement))]

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

(def: prefix Text "LuxRuntime")

(def: #export unit (_.string synthesis.unit))

(def: (flag value)
  (-> Bit Literal)
  (if value
    (_.string "")
    _.nil))

(def: #export variant-tag-field "_lux_tag")
(def: #export variant-flag-field "_lux_flag")
(def: #export variant-value-field "_lux_value")

(def: (variant' tag last? value)
  (-> (Expression Any) (Expression Any) (Expression Any) Literal)
  (_.table (list [..variant-tag-field tag]
                 [..variant-flag-field last?]
                 [..variant-value-field value])))

(def: #export (variant tag last? value)
  (-> Nat Bit (Expression Any) Literal)
  (variant' (_.int (.int tag))
            (flag last?)
            value))

(def: #export none
  Literal
  (..variant 0 #0 unit))

(def: #export some
  (-> (Expression Any) Literal)
  (..variant 1 #1))

(def: #export left
  (-> (Expression Any) Literal)
  (..variant 0 #0))

(def: #export right
  (-> (Expression Any) Literal)
  (..variant 1 #1))

(def: runtime-name
  (-> Text Var)
  (|>> /////name.normalize
       (format ..prefix "_")
       _.var))

(def: (feature name definition)
  (-> Var (-> Var Statement) Statement)
  (definition name))

(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))}
                   body)
  (wrap (list (` (let [(~+ (|> vars
                               (list@map (function (_ var)
                                           (list (code.local-identifier var)
                                                 (` (_.var (~ (code.text (/////name.normalize var))))))))
                               list.concat))]
                   (~ body))))))

(syntax: (runtime: {declaration (p.or s.local-identifier
                                      (s.form (p.and s.local-identifier
                                                     (p.some s.local-identifier))))}
           code)
  (case declaration
    (#.Left name)
    (macro.with-gensyms [g!_]
      (let [nameC (code.local-identifier name)
            code-nameC (code.local-identifier (format "@" name))
            runtime-nameC (` (runtime-name (~ (code.text name))))]
        (wrap (list (` (def: #export (~ nameC) Var (~ runtime-nameC)))
                    (` (def: (~ code-nameC)
                         Statement
                         (..feature (~ runtime-nameC)
                                    (function ((~ g!_) (~ nameC))
                                      (_.set (~ nameC) (~ code))))))))))
    
    (#.Right [name inputs])
    (macro.with-gensyms [g!_]
      (let [nameC (code.local-identifier name)
            code-nameC (code.local-identifier (format "@" name))
            runtime-nameC (` (runtime-name (~ (code.text name))))
            inputsC (list@map code.local-identifier inputs)
            inputs-typesC (list@map (function.constant (` (_.Expression Any)))
                                    inputs)]
        (wrap (list (` (def: #export ((~ nameC) (~+ inputsC))
                         (-> (~+ inputs-typesC) (Computation Any))
                         (_.apply/* (list (~+ inputsC)) (~ runtime-nameC))))
                    (` (def: (~ code-nameC)
                         Statement
                         (..feature (~ runtime-nameC)
                                    (function ((~ g!_) (~ g!_))
                                      (..with-vars [(~+ inputsC)]
                                        (_.function (~ g!_) (list (~+ inputsC))
                                          (~ code)))))))))))))

(def: (nth index table)
  (-> (Expression Any) (Expression Any) (Location Any))
  (_.nth (_.+ (_.int +1) index) table))

(def: last-index (|>> _.length (_.- (_.int +1))))

## No need to turn tuple//left and tuple//right into loops, as Lua
## does tail-call optimization.
## https://www.lua.org/pil/6.3.html
(runtime: (tuple//left lefts tuple)
  (with-vars [last-right]
    ($_ _.then
        (_.let (list last-right) (..last-index tuple))
        (_.if (_.> lefts last-right)
          ## No need for recursion
          (_.return (..nth lefts tuple))
          ## Needs recursion
          (_.return (tuple//left (_.- last-right lefts)
                                 (..nth last-right tuple)))))))

(runtime: (array//sub from to array)
  (with-vars [temp idx]
    ($_ _.then
        (_.let (list temp) (_.array (list)))
        (_.for-step idx from (_.- (_.int +1) to) (_.int +1)
                    (|> (_.var "table.insert")
                        (_.apply/* (list temp (..nth idx array)))
                        _.statement))
        (_.return temp))))

(runtime: (tuple//right lefts tuple)
  (with-vars [last-right right-index]
    ($_ _.then
        (_.let (list last-right) (..last-index tuple))
        (_.let (list right-index) (_.+ (_.int +1) lefts))
        (_.cond (list [(_.= right-index last-right)
                       (_.return (..nth right-index tuple))]
                      [(_.> right-index last-right)
                       ## Needs recursion.
                       (_.return (tuple//right (_.- last-right lefts)
                                               (..nth last-right tuple)))])
                (_.return (array//sub right-index (_.length tuple) tuple)))
        )))

(runtime: (sum//get sum wantsLast wantedTag)
  (let [no-match! (_.return _.nil)
        sum-tag (_.the ..variant-tag-field sum)
        sum-flag (_.the ..variant-flag-field sum)
        sum-value (_.the ..variant-value-field sum)
        is-last? (_.= (_.string "") sum-flag)
        test-recursion! (_.if is-last?
                          ## Must recurse.
                          (_.return (sum//get sum-value wantsLast (_.- sum-tag wantedTag)))
                          no-match!)]
    (_.cond (list [(_.= sum-tag wantedTag)
                   (_.if (_.= wantsLast sum-flag)
                     (_.return sum-value)
                     test-recursion!)]

                  [(_.> sum-tag wantedTag)
                   test-recursion!]

                  [(_.and (_.< sum-tag wantedTag)
                          (_.= (_.string "") wantsLast))
                   (_.return (variant' (_.- wantedTag sum-tag) sum-flag sum-value))])

            no-match!)))

(runtime: (array//copy array)
  (with-vars [temp idx]
    ($_ _.then
        (_.let (list temp) (_.array (list)))
        (<| (_.for-step idx (_.int +1) (_.length array) (_.int +1))
            (_.statement (|> (_.var "table.insert") (_.apply/* (list temp (_.nth idx array))))))
        (_.return temp))))

(runtime: (array//concat left right)
  (with-vars [temp idx]
    (let [copy! (function (_ input output)
                  (<| (_.for-step idx (_.int +1) (_.the "n" input) (_.int +1))
                      (_.statement (|> (_.var "table.insert") (_.apply/* (list output (_.nth idx input)))))))]
      ($_ _.then
          (_.let (list temp) (_.array (list)))
          (copy! left temp)
          (copy! right temp)
          (_.return temp)))))

(def: runtime//adt
  Statement
  ($_ _.then
      @tuple//left
      @array//sub
      @tuple//right
      @sum//get
      @array//copy
      @array//concat))

(runtime: (lux//try risky)
  (with-vars [success value]
    ($_ _.then
        (_.let (list success value) (|> risky (_.apply/* (list ..unit))
                                        _.return (_.closure (list))
                                        list _.apply/* (|> (_.var "pcall"))))
        (_.if success
          (_.return (..right value))
          (_.return (..left value))))))

(runtime: (lux//program-args raw)
  (with-vars [tail head idx]
    ($_ _.then
        (_.let (list tail) ..none)
        (<| (_.for-step idx (_.length raw) (_.int +1) (_.int -1))
            (_.set (list tail) (..some (_.array (list (_.nth idx raw)
                                                      tail)))))
        (_.return tail))))

(def: runtime//lux
  Statement
  ($_ _.then
      @lux//try
      @lux//program-args))

(runtime: (i64//logic-right-shift param subject)
  (let [mask (|> (_.int +1)
                 (_.bit-shl (_.- param (_.int +64)))
                 (_.- (_.int +1)))]
    (_.return (|> subject
                  (_.bit-shr param)
                  (_.bit-and mask)))))

(def: runtime//i64
  Statement
  ($_ _.then
      @i64//logic-right-shift
      ))

(runtime: (text//index subject param start)
  (with-vars [idx]
    ($_ _.then
        (_.let (list idx) (_.apply/* (list subject param start (_.bool #1))
                                     (_.var "string.find")))
        (_.if (_.= _.nil idx)
          (_.return ..none)
          (_.return (..some idx))))))

(runtime: (text//clip text from to)
  (with-vars [size]
    ($_ _.then
        (_.let (list size) (_.apply/* (list text) (_.var "string.len")))
        (_.if (_.or (_.> size from)
                    (_.> size to))
          (_.return ..none)
          (_.return (..some (_.apply/* (list text from to) (_.var "string.sub")))))
        )))

(runtime: (text//char idx text)
  (with-vars [char]
    ($_ _.then
        (_.let (list char) (_.apply/* (list text idx) (_.var "string.byte")))
        (_.if (_.= _.nil char)
          (_.return ..none)
          (_.return (..some char))))))

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

(runtime: (array//new size)
  (with-vars [output idx]
    ($_ _.then
        (_.let (list output) (_.array (list)))
        (_.for-step idx (_.int +1) size (_.int +1)
                    (_.statement (_.apply/* (list output ..unit) (_.var "table.insert"))))
        (_.return output))))

(runtime: (array//get array idx)
  (with-vars [temp]
    ($_ _.then
        (_.let (list temp) (..nth idx array))
        (_.if (_.or (_.= _.nil temp)
                    (_.= ..unit temp))
          (_.return ..none)
          (_.return (..some temp))))))

(runtime: (array//put array idx value)
  ($_ _.then
      (_.set (list (..nth idx array)) value)
      (_.return array)))

(def: runtime//array
  Statement
  ($_ _.then
      @array//new
      @array//get
      @array//put
      ))

(runtime: (box//write value box)
  ($_ _.then
      (_.set (list (_.nth (_.int +1) box)) value)
      (_.return ..unit)))

(def: runtime//box
  Statement
  @box//write)

(def: runtime
  Statement
  ($_ _.then
      runtime//adt
      runtime//lux
      runtime//i64
      runtime//text
      runtime//array
      runtime//box
      ))

(def: #export artifact ..prefix)

(def: #export generate
  (Operation Any)
  (///.with-buffer
    (do ////.monad
      [_ (///.save! true ["" ..prefix]
                    ..runtime)]
      (///.save-buffer! ..artifact))))