path: root/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux

(.module:
  [lux #*
   [control
    ["p" parser ("#/." monad)]
    [monad (#+ do)]]
   [data
    [number (#+ hex)]
    [text
     format]
    [collection
     ["." list ("#/." monad)]]]
   ["." function]
   [macro
    ["." code]
    ["s" syntax (#+ syntax:)]]]
  ["." ///
   ["//." //
    [analysis (#+ Variant)]
    ["." synthesis]
    [//
     ["." name]
     [//
      [host
       ["_" scheme (#+ Expression Computation Var)]]]]]])

(do-template [<name> <base>]
  [(type: #export <name>
     (<base> Var Expression Expression))]

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

(def: prefix Text "LuxRuntime")

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

(def: #export variant-tag "lux-variant")

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

(def: (variant' tag last? value)
  (-> Expression Expression Expression Computation)
  (<| (_.cons/2 (_.symbol ..variant-tag))
      (_.cons/2 tag)
      (_.cons/2 last?)
      value))

(def: #export (variant [lefts right? value])
  (-> (Variant Expression) Computation)
  (variant' (_.int (.int lefts)) (flag right?) value))

(def: #export none
  Computation
  (variant [0 #0 ..unit]))

(def: #export some
  (-> Expression Computation)
  (|>> [0 #1] ..variant))

(def: #export left
  (-> Expression Computation)
  (|>> [0 #0] ..variant))

(def: #export right
  (-> Expression Computation)
  (|>> [0 #1] ..variant))

(def: declaration
  (s.Syntax [Text (List Text)])
  (p.either (p.and s.local-identifier (p/wrap (list)))
            (s.form (p.and s.local-identifier (p.some s.local-identifier)))))

(syntax: (runtime: {[name args] declaration}
           definition)
  (let [implementation (code.local-identifier (format "@@" name))
        runtime (format prefix "__" (name.normalize name))
        @runtime (` (_.var (~ (code.text runtime))))
        argsC+ (list/map code.local-identifier args)
        argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`))
                          args)
        declaration (` ((~ (code.local-identifier name))
                        (~+ argsC+)))
        type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression)))
                    _.Computation))]
    (wrap (list (` (def: (~' #export) (~ declaration)
                     (~ type)
                     (~ (case argsC+
                          #.Nil
                          @runtime

                          _
                          (` (_.apply/* (~ @runtime) (list (~+ argsC+))))))))
                (` (def: (~ implementation)
                     _.Computation
                     (~ (case argsC+
                          #.Nil
                          (` (_.define (~ @runtime) [(list) #.None] (~ definition)))

                          _
                          (` (let [(~+ (|> (list.zip2 argsC+ argsLC+)
                                           (list/map (function (_ [left right])
                                                       (list left right)))
                                           list/join))]
                               (_.define (~ @runtime) [(list (~+ argsLC+)) #.None]
                                         (~ definition))))))))))))

(runtime: (slice offset length list)
  (<| (_.if (_.null?/1 list)
        list)
      (_.if (|> offset (_.>/2 (_.int +0)))
        (slice (|> offset (_.-/2 (_.int +1)))
               length
               (_.cdr/1 list)))
      (_.if (|> length (_.>/2 (_.int +0)))
        (_.cons/2 (_.car/1 list)
                  (slice offset
                         (|> length (_.-/2 (_.int +1)))
                         (_.cdr/1 list))))
      _.nil))

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

(runtime: (lux//try op)
  (with-vars [error]
    (_.with-exception-handler
      (_.lambda [(list error) #.None]
                (..left error))
      (_.lambda [(list) #.None]
                (..right (_.apply/* op (list ..unit)))))))

(runtime: (lux//program-args program-args)
  (with-vars [@loop @input @output]
    (_.letrec (list [@loop (_.lambda [(list @input @output) #.None]
                                     (_.if (_.eqv?/2 _.nil @input)
                                       @output
                                       (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))])
              (_.apply/2 @loop (_.reverse/1 program-args) ..none))))

(def: runtime//lux
  Computation
  (_.begin (list @@lux//try
                 @@lux//program-args)))

(def: minimum-index-length
  (-> Expression Computation)
  (|>> (_.+/2 (_.int +1))))

(def: product-element
  (-> Expression Expression Computation)
  (function.flip _.vector-ref/2))

(def: (product-tail product)
  (-> Expression Computation)
  (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1)))))

(def: (updated-index min-length product)
  (-> Expression Expression Computation)
  (|> min-length (_.-/2 (_.length/1 product))))

(runtime: (product//left product index)
  (let [@index_min_length (_.var "index_min_length")]
    (_.begin
     (list (_.define @index_min_length [(list) #.None]
                     (minimum-index-length index))
           (_.if (|> product _.length/1 (_.>/2 @index_min_length))
             ## No need for recursion
             (product-element index product)
             ## Needs recursion
             (product//left (product-tail product)
                            (updated-index @index_min_length product)))))))

(runtime: (product//right product index)
  (let [@index_min_length (_.var "index_min_length")
        @product_length (_.var "product_length")
        @slice (_.var "slice")
        last-element? (|> @product_length (_.=/2 @index_min_length))
        needs-recursion? (|> @product_length (_.</2 @index_min_length))]
    (_.begin
     (list
      (_.define @index_min_length [(list) #.None] (minimum-index-length index))
      (_.define @product_length [(list) #.None] (_.length/1 product))
      (<| (_.if last-element?
            (product-element index product))
          (_.if needs-recursion?
            (product//right (product-tail product)
                            (updated-index @index_min_length product)))
          ## Must slice
          (_.begin
           (list (_.define @slice [(list) #.None]
                           (_.make-vector/1 (|> @product_length (_.-/2 index))))
                 (_.vector-copy!/5 @slice (_.int +0) product index @product_length)
                 @slice)))))))

(runtime: (sum//get sum last? wanted-tag)
  (with-vars [variant-tag sum-tag sum-flag sum-value]
    (let [no-match _.nil
          is-last? (|> sum-flag (_.eqv?/2 (_.string "")))
          test-recursion (_.if is-last?
                           ## Must recurse.
                           (sum//get sum-value
                                     (|> wanted-tag (_.-/2 sum-tag))
                                     last?)
                           no-match)]
      (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None]
                               (_.apply/* (_.global "apply") (list (_.global "values") sum))]))
          (_.if (|> wanted-tag (_.=/2 sum-tag))
            (_.if (|> sum-flag (_.eqv?/2 last?))
              sum-value
              test-recursion))
          (_.if (|> wanted-tag (_.>/2 sum-tag))
            test-recursion)
          (_.if (_.and (list (|> last? (_.eqv?/2 (_.string "")))
                             (|> wanted-tag (_.</2 sum-tag))))
            (variant' (|> sum-tag (_.-/2 wanted-tag)) sum-flag sum-value))
          no-match))))

(def: runtime//adt
  Computation
  (_.begin (list @@product//left
                 @@product//right
                 @@sum//get)))

(runtime: (bit//logical-right-shift shift input)
  (_.if (_.=/2 (_.int +0) shift)
    input
    (|> input
        (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift))
        (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF"))))))

(def: runtime//bit
  Computation
  (_.begin (list @@bit//logical-right-shift)))

(runtime: (frac//decode input)
  (with-vars [@output]
    (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)])
      (_.if (_.and (list (_.not/1 (_.=/2 @output @output))
                         (_.not/1 (_.eqv?/2 (_.string "+nan.0") input))))
        ..none
        (..some @output)))))

(def: runtime//frac
  Computation
  (_.begin
   (list @@frac//decode)))

(def: (check-index-out-of-bounds array idx body)
  (-> Expression Expression Expression Computation)
  (_.if (|> idx (_.<=/2 (_.length/1 array)))
    body
    (_.raise/1 (_.string "Array index out of bounds!"))))

(runtime: (array//get array idx)
  (with-vars [@temp]
    (<| (check-index-out-of-bounds array idx)
        (_.let (list [@temp (_.vector-ref/2 array idx)])
          (_.if (|> @temp (_.eqv?/2 _.nil))
            ..none
            (..some @temp))))))

(runtime: (array//put array idx value)
  (<| (check-index-out-of-bounds array idx)
      (_.begin
       (list (_.vector-set!/3 array idx value)
             array))))

(def: runtime//array
  Computation
  (_.begin
   (list @@array//get
         @@array//put)))

(runtime: (box//write value box)
  (_.begin
   (list
    (_.vector-set!/3 box (_.int +0) value)
    ..unit)))

(def: runtime//box
  Computation
  (_.begin (list @@box//write)))

(runtime: (io//current-time _)
  (|> (_.apply/* (_.global "current-second") (list))
      (_.*/2 (_.int +1_000))
      _.exact/1))

(def: runtime//io
  (_.begin (list @@io//current-time)))

(def: runtime
  Computation
  (_.begin (list @@slice
                 runtime//lux
                 runtime//bit
                 runtime//adt
                 runtime//frac
                 runtime//array
                 runtime//box
                 runtime//io
                 )))

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