path: root/new-luxc/source/luxc/lang/translation/js.lux

(.module:
  lux
  (lux (control ["ex" exception #+ exception:]
                pipe)
       (data [bit]
             [maybe]
             ["e" error #+ Error]
             [text "text/" Eq<Text>]
             text/format
             (coll [array]))
       [macro]
       [io #+ Process]
       [host #+ class: object]
       (world [file #+ File]))
  (luxc [lang]
        [".C" io]))

(type: #export JS Text)

(type: #export Expression JS)

(type: #export Statement JS)

(host.import java/lang/Object
  (toString [] String))

(host.import java/lang/String
  (getBytes [String] #try (Array byte)))

(host.import java/lang/Number
  (doubleValue [] double))

(host.import java/lang/Integer
  (longValue [] Long))

(host.import java/lang/Long
  (intValue [] Integer))

(host.import java/lang/AbstractStringBuilder
  (append [String] AbstractStringBuilder))

(host.import java/lang/StringBuilder
  (new [])
  (toString [] String))

(host.import javax/script/ScriptEngine
  (eval [String] #try #? Object))

(host.import javax/script/ScriptEngineFactory
  (getScriptEngine [] ScriptEngine))

(host.import jdk/nashorn/api/scripting/NashornScriptEngineFactory
  (new []))

(host.import jdk/nashorn/api/scripting/NashornScriptEngine)

(host.import jdk/nashorn/api/scripting/JSObject
  (isArray [] boolean)
  (isFunction [] boolean)
  (getMember [String] #? Object)
  (hasMember [String] boolean))

(host.import jdk/nashorn/api/scripting/AbstractJSObject)

(host.import jdk/nashorn/api/scripting/ScriptObjectMirror)

(host.import jdk/nashorn/internal/runtime/Undefined)

(host.import java/util/Arrays
  (#static [t] copyOfRange [(Array t) int int] (Array t)))

(type: #export Host
  {## #artifacts Artifacts
   ## #context [Text Nat]

   #interpreter ScriptEngine
   #module-buffer (Maybe StringBuilder)
   #program-buffer StringBuilder
   })

(def: #export (init _)
  (-> Top Host)
  {#interpreter (ScriptEngineFactory::getScriptEngine [] (NashornScriptEngineFactory::new []))
   #module-buffer #.None
   #program-buffer (StringBuilder::new [])})

(def: #export module-js-name Text "module.js")

(def: #export (init-module-buffer _)
  (-> Top (Meta Unit))
  (function [compiler]
    (#e.Success [(update@ #.host
                          (|>> (:! Host)
                               (set@ #module-buffer (#.Some (StringBuilder::new [])))
                               (:! Void))
                          compiler)
                 []])))

(exception: #export No-Active-Module-Buffer)
(exception: #export Cannot-Execute)
(exception: #export Cannot-Evaluate)

(def: #export module-buffer
  (Meta StringBuilder)
  (function [compiler]
    (case (|> compiler (get@ #.host) (:! Host) (get@ #module-buffer))
      #.None
      ((lang.fail (No-Active-Module-Buffer "")) compiler)
      
      (#.Some module-buffer)
      (#e.Success [compiler module-buffer]))))

(def: #export program-buffer
  (Meta StringBuilder)
  (function [compiler]
    (#e.Success [compiler (|> compiler (get@ #.host) (:! Host) (get@ #program-buffer))])))

(def: (execute code)
  (-> Expression (Meta Unit))
  (function [compiler]
    (case (|> compiler
              (get@ #.host)
              (:! Host)
              (get@ #interpreter)
              (ScriptEngine::eval [code]))
      (#e.Error error)
      ((lang.fail (Cannot-Execute error)) compiler)
      
      (#e.Success _)
      (#e.Success [compiler []]))))

(def: (::toString js-object)
  (-> Top JSObject)
  (object [] AbstractJSObject []
    []
    (AbstractJSObject (isFunction) boolean
                      true)
    (AbstractJSObject (call [args (Array Object)]) Object
                      (Object::toString [] (:! Object js-object)))
    ))

(def: (::slice js-object value)
  (-> (-> Object JSObject) (Array Object) JSObject)
  (object [] AbstractJSObject []
    []
    (AbstractJSObject (isFunction) boolean
                      true)
    (AbstractJSObject (call [args (Array Object)]) Object
                      (:! Object
                          (js-object (Arrays::copyOfRange [value
                                                           (|> args (array.read +0) maybe.assume (:! Int))
                                                           (nat-to-int (array.size value))]))))
    ))

(exception: #export Unknown-Member)

(def: int-high-field Text "H")
(def: int-low-field Text "L")

(def: jvm-int
  (-> Nat Integer)
  (|>> (:! Long) (Long::intValue [])))

(def: low-mask
  Nat
  (|> +1 (bit.shift-left +32) n/dec))

(def: high (-> Nat Nat) (bit.shift-right +32))
(def: low (-> Nat Nat) (bit.and low-mask))

(class: #final LuxInt AbstractJSObject []
  ## Fields
  (#public value Long)
  ## Methods
  (#public [] (new [value Long]) []
           (exec (:= ::value value)
             []))
  (AbstractJSObject [] (getMember [member String]) Object
                    (cond (text/= int-high-field member)
                          (|> ::value int-to-nat high jvm-int)
                          
                          (text/= int-low-field member)
                          (|> ::value int-to-nat low jvm-int)
                          
                          ## else
                          (error! (Unknown-Member (format "     member = " member "\n"
                                                          "object(int) = " (%i ::value) "\n"))))))

(host.import luxc/lang/translation/js/LuxInt
  (value Long)
  (new [Long]))

(class: #final LuxArray AbstractJSObject []
  ## Fields
  (#public structure (Array Object))
  ## Methods
  (#public [] (new [structure (Array Object)]) []
           (exec (:= ::structure structure)
             []))
  (AbstractJSObject [] (isArray) boolean
                    true)
  (AbstractJSObject [] (getMember [member String]) Object
                    (cond (text/= "toString" member)
                          (:! Object
                              (::toString ::structure))
                          
                          (text/= "length" member)
                          (jvm-int (array.size ::structure))
                          
                          (text/= "slice" member)
                          (let [js-object (: (-> Object JSObject)
                                             (|>> (cond> [(host.instance? (Array Object))]
                                                         [(:! (Array Object)) [] ::new!]

                                                         [(host.instance? Long)]
                                                         [(:! Long) [] LuxInt::new]

                                                         ## else
                                                         [(:! JSObject)])))]
                            (:! Object
                                (::slice js-object ::structure)))
                          
                          ## else
                          (error! (Unknown-Member (format "           member = " (:! Text member) "\n"
                                                          "object(structure) = " (Object::toString [] (:! Object ::structure)) "\n")))))
  (AbstractJSObject [] (getSlot [idx int]) Object
                    (|> ::structure
                        (array.read (|> idx (Integer::longValue []) (:! Nat)))
                        maybe.assume
                        (cond> [(host.instance? (Array Object))]
                               [(:! (Array Object)) [] ::new!]

                               [(host.instance? Long)]
                               [(:! Long) [] LuxInt::new]

                               ## else
                               [(:! JSObject)])))
  )

(host.import luxc/lang/translation/js/LuxArray
  (structure (Array Object))
  (new [(Array Object)]))

## (def: (wrap-lux-object object)
##   (-> Top JSObject)
##   (if (host.instance? JSObject object)
##     (lux-obj object)
##     obj))

(def: (int js-object)
  (-> JSObject (Maybe Int))
  (case [(JSObject::getMember [int-high-field] js-object)
         (JSObject::getMember [int-low-field] js-object)]
    (^multi [(#.Some high) (#.Some low)]
            (and (host.instance? Number high)
                 (host.instance? Number low))
            [[(Number::longValue [] high) (Number::longValue [] low)]
             [high low]])
    (#.Some (nat-to-int (n/+ (-> high (:! Int) int-to-nat (bit.shift-left +32))
                             (-> low (:! Int) int-to-nat))))

    _
    #.None))

(def: (extend-array by input)
  (All [a] (-> Nat (Array a) (Array a)))
  (let [size (array.size input)]
    (|> (array.new (n/+ by size))
        (array.copy size +0 input +0))))

(def: (array js-object)
  (-> ScriptObjectMirror (Maybe (Array Object)))
  (if (JSObject::isArray [] js-object)
    (#.Some (loop [num-keys (ScriptObjectMirror::size js-object)
                   idx +0
                   output (: (Array Object)
                             (array.new num-keys))]
              (if (n/< num-keys idx)
                (let [idx-key (|> idx nat-to-int %i)]
                  (case (JSObject::getMember idx-key js-object)
                    (#.Some member)
                    (recur num-keys
                           (n/inc idx)
                           (array.write idx output member))
                    
                    #.None
                    (recur (n/inc num-keys)
                           (n/inc idx)
                           (extend-array +1 output))))
                output)))
    #.None))

(exception: #export Unknown-Kind-Of-JS-Object)
(exception: #export Null-Has-No-Lux-Representation)

(def: (lux-object js-object)
  (-> Object (Error Top))
  (cond (host.null? js-object)
        (ex.throw Null-Has-No-Lux-Representation "")
        
        (host.instance? java.lang.Integer js-object)
        (ex.return (Integer::longValue [] js-object))

        (or (host.instance? java.lang.Boolean js-object)
            (host.instance? java.lang.String js-object))
        (ex.return js-object)

        (host.instance? java.lang.Number js-object)
        (ex.return (Number::doubleValue [] (:! java.lang.Number js-object)))

        (host.instance? LuxArray js-object)
        (ex.return (LuxArray::structure [] (:! LuxArray js-object)))

        (host.instance? LuxInt js-object)
        (ex.return (LuxInt::value [] (:! LuxInt js-object)))

        (host.instance? JSObject js-object)
        (let [js-object (:! JSObject js-object)]
          (case (int js-object)
            (#.Some value)
            (ex.return value)

            #.None
            (case (array lux-object js-object)
              (#.Some value)
              (ex.return value)

              #.None
              ## (JSObject::isFunction [] js-object)
              ## js-object

              ## else
              (ex.throw Unknown-Kind-Of-JS-Object (Object::toString [] (:! Object js-object))))))
        
        ## else
        (ex.throw Unknown-Kind-Of-JS-Object (Object::toString [] (:! Object js-object)))))

(def: #export (eval code)
  (-> Expression (Meta Top))
  (function [compiler]
    (case (|> compiler
              (:! Host)
              (get@ #interpreter)
              (ScriptEngine::eval [code]))
      (#e.Error error)
      ((lang.fail (Cannot-Evaluate error)) compiler)
      
      (#e.Success output)
      (#e.Success [compiler (case output
                              #.None
                              []

                              (#.Some output)
                              (js-to-lux output))]))))

(def: #export unit Text "\u0000")

(def: (module-name module)
  (-> Text Text)
  (-> module
      (text.replace-all "/" "$")
      (text.replace-all "-" "_")))

(def: (definition-name [module name])
  (-> Ident Text)
  (format (module-name module) "$" (&host/def-name name)))

(def: #export (save-definition name code)
  (-> Ident Expression (Meta Unit))
  (do macro.Monad<Meta>
    [#let [js-definition (format "var " (definition-name name) " = " code ";\n")]
     module-buffer module-buffer
     #let [_ (StringBuilder::append [js-definition] module-buffer)]]
    (execute js-definition)))

(def: #export (save-module! target)
  (-> File (Meta (Process Unit)))
  (do macro.Monad<Meta>
    [module macro.current-module-name
     module-buffer module-buffer
     program-buffer program-buffer
     #let [_ (StringBuilder::append [(format module-buffer "\n")] program-buffer)]]
    (wrap (ioC.write target
                     (format module "/" module-js-name)
                     (|> module-buffer
                         (StringBuilder::toString [])
                         (String::getBytes ["UTF-8"])
                         e.assume)))))