(.module:
  lux
  (lux (control ["p" parser "p/" Monad<Parser>]
                [monad #+ do])
       (data [bit]
             [number #+ hex]
             text/format
             (coll [list "list/" Monad<List>]))
       [macro]
       (macro [code]
              ["s" syntax #+ syntax:])
       [io #+ Process])
  [//]
  (luxc [lang]
        (lang (host ["_" scheme #+ SVar Expression @@]))))

(def: prefix Text "LuxRuntime")

(def: #export unit Expression (_.string //.unit))

(def: (flag value)
  (-> Bool Expression)
  (if value
    (_.string "")
    _.nil))

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

(def: #export (variant tag last? value)
  (-> Nat Bool Expression Expression)
  (variant' (_.int (:! Int tag)) (flag last?) value))

(def: #export none
  Expression
  (variant +0 false unit))

(def: #export some
  (-> Expression Expression)
  (variant +1 true))

(def: #export left
  (-> Expression Expression)
  (variant +0 false))

(def: #export right
  (-> Expression Expression)
  (variant +1 true))

(type: Runtime Expression)

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

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

                          _
                          (` (_.apply (~ @runtime) (list (~+ argsC+))))))))
                (` (def: (~ implementation)
                     _.Expression
                     (~ (case argsC+
                          #.Nil
                          (` (_.define (~ $runtime) (~ definition)))

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

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

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

(def: as-integer
  (-> Expression Expression)
  (_.apply1 (_.global "exact")))

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

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

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

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

(def: product-element
  (-> Expression Expression Expression)
  _.vector-ref)

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

(def: (updated-index min-length product)
  (-> Expression Expression Expression)
  (|> min-length (_.- (_.length product))))

(runtime: (product//left product index)
  (let [$index_min_length (_.var "index_min_length")]
    (_.begin
     (list (_.define $index_min_length (list)
                     (minimum-index-length (@@ index)))
           (_.if (|> (_.length (@@ product)) (_.> (@@ $index_min_length)))
             ## No need for recursion
             (product-element (@@ product) (@@ index))
             ## 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")]
    (_.begin
     (list
      (_.define $index_min_length (list) (minimum-index-length (@@ index)))
      (_.define $product_length (list) (_.length (@@ product)))
      (<| (_.if ## Last element.
              (|> (@@ $product_length) (_.= (@@ $index_min_length)))
            (product-element (@@ product) (@@ index)))
          (_.if ## Needs recursion
              (|> (@@ $product_length) (_.< (@@ $index_min_length)))
            (product//right (product-tail (@@ product))
                            (updated-index (@@ $index_min_length) (@@ product))))
          ## Must slice
          (_.begin
           (list (_.define $slice (list)
                           (_.make-vector (|> (@@ $product_length)
                                              (_.- (@@ index)))))
                 (_.vector-copy! (@@ $slice) (_.int 0)
                                 (@@ product) (@@ index) (@@ $product_length))
                 (@@ $slice))))))))

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

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

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

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

(def: int-high (bit//shift-right (_.int 32)))
(def: int-low (_.bit-and (_.int (hex "FFFFFFFF"))))

(runtime: (nat//< param subject)
  (with-vars [pH sH]
    (_.let (list [pH (int-high (@@ param))]
                 [sH (int-high (@@ subject))])
      (_.or (list (_.< (@@ pH) (@@ sH))
                  (_.and (list (_.= (@@ pH) (@@ sH))
                               (_.< (int-low (@@ param)) (int-low (@@ subject))))))))))

(runtime: (nat/// param subject)
  (_.if (_.< (_.int 0) (@@ param))
    (_.if (nat//< (@@ param) (@@ subject))
      (_.int 0)
      (_.int 1))
    (with-vars [quotient]
      (_.let (list [quotient (|> (@@ subject)
                                 (bit//shift-right (_.int 1))
                                 (_.quotient (@@ param))
                                 (_.arithmetic-shift (_.int 1)))])
        (let [remainder (_.- (_.* (@@ param) (@@ quotient))
                             (@@ subject))]
          (_.if (_.not (nat//< (@@ param) remainder))
            (_.+ (_.int 1) (@@ quotient))
            (@@ quotient)))))))

(runtime: (nat//% param subject)
  (let [flat (|> (@@ subject)
                 (nat/// (@@ param))
                 (_.* (@@ param)))]
    (|> (@@ subject) (_.- flat))))

(def: runtime//nat
  Runtime
  (_.begin
   (list @@nat//<
         @@nat///
         @@nat//%)))

(runtime: (frac//to-deg input)
  (with-vars [two32 shifted]
    (_.let* (list [two32 (|> (_.float 2.0) (_.expt (_.float 32.0)))]
                  [shifted (|> (@@ input) (_.mod (_.float 1.0)) (_.* (@@ two32)))])
            (let [low (|> (@@ shifted) (_.mod (_.float 1.0)) (_.* (@@ two32)) as-integer)
                  high (|> (@@ shifted) as-integer)]
              (|> high
                  (_.arithmetic-shift (_.int 32))
                  (_.+ low))))))

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

(def: runtime//frac
  Runtime
  (_.begin
   (list @@frac//to-deg
         @@frac//decode)))

## (def: runtime//text
##   Runtime
##   (_.begin (list @@text//index
##                  @@text//clip
##                  @@text//char)))

(def: (check-index-out-of-bounds array idx body)
  (-> Expression Expression Expression Expression)
  (_.if (|> idx (_.<= (_.length array)))
    body
    (_.raise (_.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 (@@ array) (@@ idx))])
          (_.if (|> (@@ temp) (_.eqv? _.nil))
            ..none
            (..some (@@ temp)))))))

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

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

(runtime: (atom//compare-and-swap atom old new)
  (with-vars [temp]
    (_.let (list [temp (_.vector-ref (@@ atom) (_.int 0))])
      (_.if (_.eq? (@@ old) (@@ temp))
        (_.begin
         (list (_.vector-set! (@@ atom) (_.int 0) (@@ new))
               (_.bool true)))
        (_.bool false)))))

(def: runtime//atom
  Runtime
  @@atom//compare-and-swap)

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

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

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

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

(def: process//incoming
  SVar
  (_.var (lang.normalize-name "process//incoming")))

(runtime: (process//loop _)
  (_.when (_.not (_.null? (@@ process//incoming)))
          (with-vars [queue process]
            (_.let (list [queue (@@ process//incoming)])
              (_.begin (list (_.set! process//incoming (_.list (list)))
                             (_.apply (_.global "map")
                                      (list (_.lambda (_.poly (list process))
                                                 (_.apply (@@ process) (list ..unit)))
                                            (@@ queue)))
                             (process//loop ..unit)))))))

(runtime: (process//future procedure)
  (_.begin (list (_.set! process//incoming (_.cons (@@ procedure) (@@ process//incoming)))
                 ..unit)))

(runtime: (process//schedule milli-seconds procedure)
  (with-vars [start process now _ignored]
    (_.let (list [start (io//current-time ..unit)])
      (_.letrec (list [process (_.lambda _ignored
                                    (_.let (list [now (io//current-time ..unit)])
                                      (_.if (|> (@@ now) (_.- (@@ start)) (_.>= (@@ milli-seconds)))
                                        (_.apply (@@ procedure) (list ..unit))
                                        (process//future (@@ process)))))])
                (process//future (@@ process))))))

(def: runtime//process
  Runtime
  (_.begin (list (_.define process//incoming (list) (_.list (list)))
                 @@process//loop
                 @@process//future
                 @@process//schedule)))

(def: runtime
  Runtime
  (_.begin (list @@list-slice
                 runtime//lux
                 runtime//bit
                 runtime//adt
                 runtime//nat
                 runtime//frac
                 ## runtime//text
                 runtime//array
                 runtime//atom
                 runtime//box
                 runtime//io
                 runtime//process
                 )))

(def: #export artifact Text (format prefix //.file-extension))

(def: #export translate
  (Meta (Process Top))
  (do macro.Monad<Meta>
    [_ //.init-module-buffer
     _ (//.save runtime)]
    (//.save-module! artifact)))