path: root/lux-js/source/program.lux

(.module:
  [lux #*
   [cli (#+ program:)]
   ["." io (#+ IO io)]
   [control
    [monad (#+ do)]
    ["." exception (#+ exception:)]]
   [data
    ["." maybe]
    ["." error (#+ Error)]
    [number
     ["." i64]]
    ["." text ("#/." hash)
     format]
    [collection
     ["." array (#+ Array)]
     ["." list ("#/." functor)]]]
   [macro
    ["." template]]
   [world
    ["." file]]
   ["." host (#+ import: interface: do-to object)
    ["_" js]]
   [tool
    [compiler
     ["." name]
     [phase
      [macro (#+ Expander)]
      ["." generation
       ["." js
        ["." runtime]
        ["." extension]]]]
     [default
      ["." platform (#+ Platform)]]]]]
  [program
   ["/" compositor
    ["/." cli]]])

(import: #long java/lang/String)

(import: #long java/lang/Object
  (toString [] java/lang/String))

(import: #long java/lang/Long
  (intValue [] java/lang/Integer))

(import: #long java/lang/Integer
  (longValue [] long))

(import: #long java/lang/Number
  (intValue [] java/lang/Integer)
  (longValue [] long)
  (doubleValue [] double))

(import: #long java/util/Arrays
  (#static [t] copyOfRange [(Array t) int int] (Array t)))

(import: #long javax/script/ScriptEngine
  (eval [java/lang/String] #try #? java/lang/Object))

(import: #long javax/script/ScriptEngineFactory
  (getScriptEngine [] javax/script/ScriptEngine))

(import: #long jdk/nashorn/api/scripting/NashornScriptEngineFactory
  (new []))

(import: #long jdk/nashorn/api/scripting/JSObject
  (isArray [] boolean)
  (isFunction [] boolean)
  (getSlot [int] #? java/lang/Object)
  (getMember [java/lang/String] #? java/lang/Object)
  (hasMember [java/lang/String] boolean)
  (call [#? java/lang/Object (Array java/lang/Object)] #try java/lang/Object))

(import: #long jdk/nashorn/api/scripting/AbstractJSObject)

(import: #long jdk/nashorn/api/scripting/ScriptObjectMirror
  (size [] int)
  (toString [] java/lang/String))

(import: #long jdk/nashorn/internal/runtime/Undefined)

(do-template [<name>]
  [(interface: <name>
     (getValue [] java/lang/Object))

   (`` (import: (~~ (template.identifier ["program/" <name>]))
         (getValue [] java/lang/Object)))]

  [IntValue]
  [StructureValue]
  )

(exception: (unknown-member {member Text}
                            {object java/lang/Object})
  (exception.report
   ["Member" member]
   ["Object" (java/lang/Object::toString object)]))

(def: jvm-int
  (-> (I64 Any) java/lang/Integer)
  (|>> (:coerce java/lang/Long) java/lang/Long::intValue))

(def: (js-int value)
  (-> Int jdk/nashorn/api/scripting/JSObject)
  (object [] jdk/nashorn/api/scripting/AbstractJSObject [program/IntValue]
    []
    ## Methods
    (program/IntValue
     (getValue) java/lang/Object
     (:coerce java/lang/Object value))
    ## (jdk/nashorn/api/scripting/AbstractJSObject
    ##  (getDefaultValue {hint (java/lang/Class java/lang/Object)}) java/lang/Object
    ##  "<<IntValue>>")
    (jdk/nashorn/api/scripting/AbstractJSObject
     (getMember {member java/lang/String}) java/lang/Object
     (case member
       (^ (static runtime.i64-high-field))
       (|> value .nat runtime.high jvm-int)

       (^ (static runtime.i64-low-field))
       (|> value .nat runtime.low jvm-int)

       _
       (error! (exception.construct unknown-member [member (:coerce java/lang/Object value)]))))
    ))

(def: (inspect object)
  (-> java/lang/Object Text)
  (<| (case (host.check java/lang/Boolean object)
        (#.Some value)
        (%b value)
        #.None)
      (case (host.check java/lang/String object)
        (#.Some value)
        (%t value)
        #.None)
      (case (host.check java/lang/Long object)
        (#.Some value)
        (%i (.int value))
        #.None)
      (case (host.check java/lang/Number object)
        (#.Some value)
        (%f (java/lang/Number::doubleValue value))
        #.None)
      (case (host.check (Array java/lang/Object) object)
        (#.Some value)
        (let [value (:coerce (Array java/lang/Object) value)]
          (case (array.read 0 value)
            (^multi (#.Some tag)
                    [(host.check java/lang/Integer tag)
                     (#.Some tag)]
                    [[(array.read 1 value)
                      (array.read 2 value)]
                     [last?
                      (#.Some choice)]])
            (let [last? (case last?
                          (#.Some _) #1
                          #.None #0)]
              (|> (format (%n (.nat (java/lang/Integer::longValue tag)))
                          " " (%b last?)
                          " " (inspect choice))
                  (text.enclose ["(" ")"])))

            _
            (|> value
                array.to-list
                (list/map inspect)
                (text.join-with " ")
                (text.enclose ["[" "]"]))))
        #.None)
      (java/lang/Object::toString object)))

(def: (::toString js-object)
  (-> Any jdk/nashorn/api/scripting/JSObject)
  (object [] jdk/nashorn/api/scripting/AbstractJSObject []
    []
    (jdk/nashorn/api/scripting/AbstractJSObject
     (isFunction) boolean
     #1)
    (jdk/nashorn/api/scripting/AbstractJSObject
     (call {this java/lang/Object} {args (Array java/lang/Object)}) java/lang/Object
     (inspect (:coerce java/lang/Object js-object)))
    ))

(def: (::slice js-object value)
  (-> (-> java/lang/Object jdk/nashorn/api/scripting/JSObject) (Array java/lang/Object) jdk/nashorn/api/scripting/JSObject)
  (object [] jdk/nashorn/api/scripting/AbstractJSObject []
    []
    (jdk/nashorn/api/scripting/AbstractJSObject
     (isFunction) boolean
     #1)
    (jdk/nashorn/api/scripting/AbstractJSObject
     (call {this java/lang/Object} {args (Array java/lang/Object)}) java/lang/Object
     (|> (java/util/Arrays::copyOfRange value
                                        (|> args (array.read 0) maybe.assume (:coerce Int))
                                        (.int (array.size value)))
         js-object
         (:coerce java/lang/Object)))
    ))

(def: (js-structure value)
  (-> (Array java/lang/Object) jdk/nashorn/api/scripting/JSObject)
  (let [js-object (: (-> java/lang/Object jdk/nashorn/api/scripting/JSObject)
                     (function (_ sub-value)
                       (<| (case (host.check (Array java/lang/Object) sub-value)
                             (#.Some sub-value)
                             (|> sub-value (:coerce (Array java/lang/Object)) js-structure)
                             #.None)
                           (case (host.check java/lang/Long sub-value)
                             (#.Some sub-value)
                             (|> sub-value (:coerce Int) js-int)
                             #.None)
                           ## else
                           (:coerce jdk/nashorn/api/scripting/JSObject sub-value))))]
    (object [] jdk/nashorn/api/scripting/AbstractJSObject [program/StructureValue]
      []
      ## Methods
      (program/StructureValue
       (getValue) java/lang/Object
       (:coerce (Array java/lang/Object) value))
      ## (jdk/nashorn/api/scripting/AbstractJSObject
      ##  (getDefaultValue {hint (java/lang/Class java/lang/Object)}) java/lang/Object
      ##  "<<StructureValue>>")
      (jdk/nashorn/api/scripting/AbstractJSObject
       (isArray) boolean
       #1)
      (jdk/nashorn/api/scripting/AbstractJSObject
       (getMember {member java/lang/String}) java/lang/Object
       (case member
         "toString"
         (:coerce java/lang/Object
                  (::toString value))
         
         "length"
         (jvm-int (array.size value))
         
         "slice"
         (:coerce java/lang/Object
                  (::slice js-object value))

         (^ (static runtime.variant-tag-field))
         (|> value (array.read 0) maybe.assume)
         
         (^ (static runtime.variant-flag-field))
         (case (array.read 1 value)
           (#.Some set!)
           set!

           _
           (host.null))
         
         (^ (static runtime.variant-value-field))
         (|> value (array.read 2) maybe.assume js-object (:coerce java/lang/Object))
         
         _
         (error! (exception.construct unknown-member [(:coerce Text member) (:coerce java/lang/Object value)])))
       )
      (jdk/nashorn/api/scripting/AbstractJSObject
       (getSlot {idx int}) java/lang/Object
       (|> value
           (array.read (|> idx java/lang/Integer::longValue (:coerce Nat)))
           maybe.assume
           js-object
           (:coerce java/lang/Object)))
      )))

(exception: null-has-no-lux-representation)
(exception: undefined-has-no-lux-representation)

(exception: (unknown-kind-of-js-object {object java/lang/Object})
  (exception.report
   ["Object" (java/lang/Object::toString object)]))

(exception: (cannot-apply-a-non-function {object java/lang/Object})
  (exception.report
   ["Object" (java/lang/Object::toString object)]))

(def: (check-int js-object)
  (-> jdk/nashorn/api/scripting/ScriptObjectMirror
      (Maybe Int))
  (case [(jdk/nashorn/api/scripting/JSObject::getMember [runtime.i64-high-field] js-object)
         (jdk/nashorn/api/scripting/JSObject::getMember [runtime.i64-low-field] js-object)]
    (^multi [(#.Some high) (#.Some low)]
            [[(host.check java/lang/Number high)
              (host.check java/lang/Number low)]
             [(#.Some high) (#.Some low)]]
            [[(java/lang/Number::longValue high)
              (java/lang/Number::longValue low)]
             [high low]])
    (#.Some (.int (n/+ (|> high .nat (i64.left-shift 32))
                       (if (i/< +0 (.int low))
                         (|> low .nat (i64.left-shift 32) (i64.logic-right-shift 32))
                         (.nat low)))))

    _
    #.None))

(def: (check-variant lux-object js-object)
  (-> (-> java/lang/Object (Error Any))
      jdk/nashorn/api/scripting/ScriptObjectMirror
      (Maybe Any))
  (case [(jdk/nashorn/api/scripting/JSObject::getMember [runtime.variant-tag-field] js-object)
         (jdk/nashorn/api/scripting/JSObject::getMember [runtime.variant-flag-field] js-object)
         (jdk/nashorn/api/scripting/JSObject::getMember [runtime.variant-value-field] js-object)]
    (^multi [(#.Some tag) ?flag (#.Some value)]
            [(host.check java/lang/Number tag)
             (#.Some tag)]
            [(lux-object value)
             (#.Some value)])
    (#.Some [(java/lang/Number::intValue tag)
             (maybe.default (host.null) ?flag)
             value])

    _
    #.None))

(def: (check-array lux-object js-object)
  (-> (-> java/lang/Object (Error Any))
      jdk/nashorn/api/scripting/ScriptObjectMirror
      (Maybe (Array java/lang/Object)))
  (if (jdk/nashorn/api/scripting/JSObject::isArray js-object)
    (let [init-num-keys (.nat (jdk/nashorn/api/scripting/ScriptObjectMirror::size js-object))]
      (loop [num-keys init-num-keys
             idx 0
             output (: (Array java/lang/Object)
                       (array.new init-num-keys))]
        (if (n/< num-keys idx)
          (case (jdk/nashorn/api/scripting/JSObject::getMember (%n idx) js-object)
            (#.Some member)
            (case (lux-object member)
              (#error.Success parsed-member)
              (recur num-keys (inc idx) (array.write idx (:coerce java/lang/Object parsed-member) output))

              (#error.Failure error)
              #.None)

            #.None
            (recur num-keys (inc idx) output))
          (#.Some output))))
    #.None))

(def: (lux-object js-object)
  (-> java/lang/Object (Error Any))
  (`` (<| (if (host.null? js-object)
            (exception.throw null-has-no-lux-representation []))
          (case (host.check jdk/nashorn/internal/runtime/Undefined js-object)
            (#.Some _)
            (exception.throw undefined-has-no-lux-representation [])
            #.None)
          (~~ (do-template [<class>]
                [(case (host.check <class> js-object)
                   (#.Some js-object)
                   (exception.return js-object)
                   #.None)]

                [java/lang/Boolean] [java/lang/String]))
          (~~ (do-template [<class> <method>]
                [(case (host.check <class> js-object)
                   (#.Some js-object)
                   (exception.return (<method> js-object))
                   #.None)]

                [java/lang/Number java/lang/Number::doubleValue]
                [StructureValue StructureValue::getValue]
                [IntValue IntValue::getValue]))
          (case (host.check jdk/nashorn/api/scripting/ScriptObjectMirror js-object)
            (#.Some js-object)
            (case (check-int js-object)
              (#.Some value)
              (exception.return value)

              #.None
              (case (check-variant lux-object js-object)
                (#.Some value)
                (exception.return value)

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

                  #.None
                  (if (jdk/nashorn/api/scripting/JSObject::isFunction js-object)
                    (exception.return js-object)
                    (exception.throw unknown-kind-of-js-object (:coerce java/lang/Object js-object))))))
            #.None)
          ## else
          (exception.throw unknown-kind-of-js-object (:coerce java/lang/Object js-object))
          )))

(def: (ensure-macro macro)
  (-> Macro (Maybe jdk/nashorn/api/scripting/JSObject))
  (let [macro (:coerce java/lang/Object macro)]
    (do maybe.monad
      [macro (host.check jdk/nashorn/api/scripting/JSObject macro)]
      (if (jdk/nashorn/api/scripting/JSObject::isFunction macro)
        (#.Some macro)
        #.None))))

(def: (call-macro inputs lux macro)
  (-> (List Code) Lux jdk/nashorn/api/scripting/JSObject (Error (Error [Lux (List Code)])))
  (let [to-js (: (-> Any java/lang/Object)
                 (|>> (:coerce (Array java/lang/Object)) js-structure (:coerce java/lang/Object)))]
    (<| (:coerce (Error (Error [Lux (List Code)])))
        (jdk/nashorn/api/scripting/JSObject::call #.None
                                                  (|> (array.new 2)
                                                      (: (Array java/lang/Object))
                                                      (array.write 0 (to-js inputs))
                                                      (array.write 1 (to-js lux)))
                                                  macro))))

(def: (expander macro inputs lux)
  Expander
  (case (ensure-macro macro)
    (#.Some macro)
    (case (call-macro inputs lux macro)
      (#error.Success output)
      (|> output
          (:coerce java/lang/Object)
          lux-object
          (:coerce (Error (Error [Lux (List Code)]))))

      (#error.Failure error)
      (#error.Failure error))
    
    #.None
    (exception.throw cannot-apply-a-non-function (:coerce java/lang/Object macro))))

(def: separator "$")

(def: (evaluate! interpreter alias input)
  (-> javax/script/ScriptEngine Text _.Expression (Error Any))
  (do error.monad
    [?output (javax/script/ScriptEngine::eval (_.code input) interpreter)
     output (case ?output
              (#.Some output)
              (wrap output)

              #.None
              (exception.throw null-has-no-lux-representation []))
     lux-output (..lux-object output)]
    (wrap lux-output)))

(def: (execute! interpreter alias input)
  (-> javax/script/ScriptEngine Text _.Statement (Error Any))
  (do error.monad
    [?output (javax/script/ScriptEngine::eval (_.code input) interpreter)]
    (wrap [])))

(def: (define! interpreter [module name] input)
  (-> javax/script/ScriptEngine Name _.Expression (Error [Text Any]))
  (let [global (format (text.replace-all .module-separator ..separator module)
                       ..separator (name.normalize name)
                       "___" (%n (text/hash name)))
        @global (_.var global)]
    (do error.monad
      [_ (execute! interpreter global (_.define @global input))
       value (evaluate! interpreter global @global)]
      (wrap [global value]))))

(type: Host
  (generation.Host _.Expression _.Statement))

(def: host
  (IO Host)
  (io (let [interpreter (javax/script/ScriptEngineFactory::getScriptEngine
                         (jdk/nashorn/api/scripting/NashornScriptEngineFactory::new))]
        (: Host
           (structure
            (def: (evaluate! alias input)
              (..evaluate! interpreter (name.normalize alias) input))
            (def: execute! (..execute! interpreter))
            (def: define! (..define! interpreter)))))))

(def: platform
  (IO (Platform IO _.Var _.Expression _.Statement))
  (do io.monad
    [host ..host]
    (wrap {#platform.&monad io.monad
           #platform.&file-system file.system
           #platform.host host
           #platform.phase js.generate
           #platform.runtime runtime.generate})))

(program: [{service /cli.service}]
  (/.compiler ..expander ..platform extension.bundle service))