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

(.module:
  lux
  (lux (control ["ex" exception #+ exception:]
                pipe
                [monad #+ do])
       (data [bit]
             [maybe]
             ["e" error #+ Error]
             [text "text/" Eq<Text>]
             text/format
             (coll [array]))
       [macro]
       [io #+ IO Process io]
       [host #+ class: interface: object]
       (world [file #+ File]))
  (luxc [lang]
        (lang [".L" variable #+ Register])
        [".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/Integer
  (longValue [] Long))

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

(host.import java/lang/CharSequence)

(host.import java/lang/Appendable
  (append [CharSequence] Appendable))

(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)

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

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

(type: #export Anchor [Text Register])

(type: #export Host
  {#context [Text Nat]
   #anchor (Maybe Anchor)
   #interpreter ScriptEngine
   #module-buffer (Maybe StringBuilder)
   #program-buffer StringBuilder
   })

(def: #export init
  (IO Host)
  (io {#context ["" +0]
       #anchor #.None
       #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
  (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)

(def: #export (with-sub-context expr)
  (All [a] (-> (Meta a) (Meta [Text a])))
  (function [compiler]
    (let [old (:! Host (get@ #.host compiler))
          [old-name old-sub] (get@ #context old)
          new-name (format old-name "$" (%i (nat-to-int old-sub)))]
      (case (expr (set@ #.host
                        (:! Void (set@ #context [new-name +0] old))
                        compiler))
        (#e.Success [compiler' output])
        (#e.Success [(update@ #.host
                              (|>> (:! Host)
                                   (set@ #context [old-name (n/inc old-sub)])
                                   (:! Void))
                              compiler')
                     [new-name output]])

        (#e.Error error)
        (#e.Error error)))))

(def: #export context
  (Meta Text)
  (function [compiler]
    (#e.Success [compiler
                 (|> (get@ #.host compiler)
                     (:! Host)
                     (get@ #context)
                     (let> [name sub]
                           name))])))

(def: #export (with-anchor anchor expr)
  (All [a] (-> Anchor (Meta a) (Meta a)))
  (function [compiler]
    (let [old (:! Host (get@ #.host compiler))]
      (case (expr (set@ #.host
                        (:! Void (set@ #anchor (#.Some anchor) old))
                        compiler))
        (#e.Success [compiler' output])
        (#e.Success [(update@ #.host
                              (|>> (:! Host)
                                   (set@ #anchor (get@ #anchor old))
                                   (:! Void))
                              compiler')
                     output])

        (#e.Error error)
        (#e.Error error)))))

(exception: #export No-Anchor)

(def: #export anchor
  (Meta Anchor)
  (function [compiler]
    (case (|> compiler (get@ #.host) (:! Host) (get@ #anchor))
      (#.Some anchor)
      (#e.Success [compiler anchor])

      #.None
      ((lang.throw No-Anchor "") compiler))))

(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: #export int-high-field Text "H")
(def: #export int-low-field Text "L")

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

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

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

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

(interface: IntValue
  (getValue [] Long))

(host.import luxc/lang/translation/js/IntValue)

(def: (js-int value)
  (-> Int JSObject)
  (object [] AbstractJSObject [IntValue]
    []
    ## Methods
    (IntValue (getValue) Long
              (:! Long 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")))))))

(interface: StructureValue
  (getValue [] (Array Object)))

(host.import luxc/lang/translation/js/StructureValue)

(def: (js-structure value)
  (-> (Array Object) JSObject)
  (object [] AbstractJSObject [StructureValue]
    []
    ## Methods
    (StructureValue (getValue) (Array Object)
                    (:! (Array Object) value))
    (AbstractJSObject (isArray) boolean
                      true)
    (AbstractJSObject (getMember [member String]) Object
                      (cond (text/= "toString" member)
                            (:! Object
                                (::toString value))
                            
                            (text/= "length" member)
                            (jvm-int (array.size value))
                            
                            (text/= "slice" member)
                            (let [js-object (: (-> Object JSObject)
                                               (|>> (cond> [(host.instance? (Array Object))]
                                                           [(:! (Array Object)) js-structure]

                                                           [(host.instance? Long)]
                                                           [(:! Int) js-int]

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

                                 [(host.instance? Long)]
                                 [(:! Int) js-int]

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

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

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

(def: #export (definition-name [module name])
  (-> Ident Text)
  (format (module-name module) "$" (lang.normalize-name name)))

(def: #export (save-js code)
  (-> JS (Meta Unit))
  (do macro.Monad<Meta>
    [module-buffer module-buffer
     #let [_ (Appendable::append [(:! CharSequence code)]
                                 module-buffer)]]
    (execute code)))

(def: #export (save-definition name code)
  (-> Ident Expression (Meta Unit))
  (save-js (format "var " (definition-name name) " = " code ";\n")))

(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 [module-code (StringBuilder::toString [] module-buffer)
           _ (Appendable::append [(:! CharSequence (format module-code "\n"))]
                                 program-buffer)]]
    (wrap (ioC.write target
                     (format module "/" module-js-name)
                     (|> module-code
                         (String::getBytes ["UTF-8"])
                         e.assume)))))