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

(.module:
  [lux #*
   ["." host (#+ import: interface: do-to object)]
   ["." debug]
   [abstract
    [monad (#+ do)]]
   [control
    ["." try (#+ Try)]
    ["." exception (#+ exception:)]
    ["." io (#+ IO io)]
    [parser
     [cli (#+ program:)]]
    [concurrency
     ["." promise (#+ Promise)]]]
   [data
    ["." maybe]
    [number
     ["." i64]
     ["n" nat]
     ["i" int]]
    [text
     ["%" format (#+ format)]
     ["." encoding]]
    [collection
     ["." array (#+ Array)]]]
   [macro
    ["." template]]
   [world
    ["." file]]
   ["@" target
    ["_" js]]
   [tool
    [compiler
     [phase (#+ Operation Phase)]
     [language
      [lux
       [program (#+ Program)]
       [generation (#+ Context Host)]
       [analysis
        [macro (#+ Expander)]]
       [phase
        ["." extension (#+ Extender Handler)
         ["#/." bundle]
         ["." analysis #_
          ["#" js]]
         ["." generation #_
          ["#" js]]]
        [generation
         ["." reference]
         ["." js
          ["." runtime]]]]]]
     [default
      ["." platform (#+ Platform)]]
     [meta
      ["." packager #_
       ["#" script]]]]]]
  [program
   ["/" compositor
    ["/." cli]
    ["/." static]]])

(import: #long java/lang/String)

(import: #long (java/lang/Class a))

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

(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 [[t] int int] [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 [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)

(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" (debug.inspect 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 self) java/lang/Object
     (:coerce java/lang/Object value))
    (jdk/nashorn/api/scripting/AbstractJSObject
     [] (getMember self {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: (::toString js-object)
  (-> Any jdk/nashorn/api/scripting/JSObject)
  (object [] jdk/nashorn/api/scripting/AbstractJSObject []
    []
    (jdk/nashorn/api/scripting/AbstractJSObject
     [] (isFunction self) boolean
     #1)
    (jdk/nashorn/api/scripting/AbstractJSObject
     [] (call self {this java/lang/Object} {args [java/lang/Object]}) java/lang/Object
     (debug.inspect 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 self) boolean
     #1)
    (jdk/nashorn/api/scripting/AbstractJSObject
     [] (call self {this java/lang/Object} {args [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 [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 self) java/lang/Object
       (:coerce (Array java/lang/Object) value))
      (jdk/nashorn/api/scripting/AbstractJSObject
       [] (isArray self) boolean
       #1)
      (jdk/nashorn/api/scripting/AbstractJSObject
       [] (getMember self {member java/lang/String}) java/lang/Object
       (case member
         (^or "toJSON" "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 self {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-host-object {object java/lang/Object})
  (exception.report
   ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
   ["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 (Try 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 (Try Any))
      jdk/nashorn/api/scripting/ScriptObjectMirror
      (Maybe (Array java/lang/Object)))
  (if (jdk/nashorn/api/scripting/JSObject::isArray js-object)
    (let [num-keys (.nat (jdk/nashorn/api/scripting/ScriptObjectMirror::size js-object))]
      (loop [idx 0
             output (: (Array java/lang/Object)
                       (array.new num-keys))]
        (if (n.< num-keys idx)
          (case (jdk/nashorn/api/scripting/JSObject::getMember (%.nat idx) js-object)
            (#.Some member)
            (case (host.check jdk/nashorn/internal/runtime/Undefined member)
              (#.Some _)
              (recur (inc idx) output)

              #.None
              (case (lux-object member)
                (#try.Success parsed-member)
                (recur (inc idx) (array.write idx (:coerce java/lang/Object parsed-member) output))

                (#try.Failure error)
                #.None))

            #.None
            (recur (inc idx) output))
          (#.Some output))))
    #.None))

(def: (lux-object js-object)
  (-> java/lang/Object (Try 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)
          (~~ (template [<class>]
                [(case (host.check <class> js-object)
                   (#.Some js-object)
                   (exception.return js-object)
                   #.None)]

                [java/lang/Boolean] [java/lang/String]))
          (~~ (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-host-object (:coerce java/lang/Object js-object))))))
            #.None)
          ## else
          (exception.throw ..unknown-kind-of-host-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 (Try (Try [Lux (List Code)])))
  (let [to-js (: (-> Any java/lang/Object)
                 (|>> (:coerce (Array java/lang/Object)) js-structure (:coerce java/lang/Object)))]
    (<| (:coerce (Try (Try [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)
      (#try.Success output)
      (|> output
          (:coerce java/lang/Object)
          lux-object
          (:coerce (Try (Try [Lux (List Code)]))))

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

(def: (evaluate! interpreter alias input)
  (-> javax/script/ScriptEngine Text _.Expression (Try Any))
  (do try.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-object output)))

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

(def: (define! interpreter context input)
  (-> javax/script/ScriptEngine Context _.Expression (Try [Text Any _.Statement]))
  (let [global (reference.artifact context)
        @global (_.var global)]
    (do try.monad
      [#let [definition (_.define @global input)]
       _ (execute! interpreter global definition)
       value (evaluate! interpreter global @global)]
      (wrap [global value definition]))))

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

            (def: (ingest context content)
              (|> content encoding.from-utf8 try.assume (:coerce _.Statement)))

            (def: (re-learn context content)
              (..execute! interpreter (reference.artifact context) content))
            
            (def: (re-load context content)
              (do try.monad
                [_ (..execute! interpreter "" content)]
                (..evaluate! interpreter "" (_.var (reference.artifact context))))))))))

(def: platform
  (IO (Platform _.Var _.Expression _.Statement))
  (do io.monad
    [host ..host]
    (wrap {#platform.&file-system (file.async file.system)
           #platform.host host
           #platform.phase js.generate
           #platform.runtime runtime.generate
           #platform.write (|>> _.code encoding.to-utf8)})))

(def: (program namer context program)
  (-> (-> Context Text) (Program _.Expression _.Statement))
  (let [@process (_.var "process")
        raw-inputs (_.? (|> (|> @process _.type-of (_.= (_.string "undefined")) _.not)
                            (_.and (|> @process (_.the "argv"))))
                        (|> @process (_.the "argv"))
                        (_.array (list)))]
    (_.statement (_.apply/2 program
                            (runtime.lux//program-args raw-inputs)
                            _.null))))

(def: extender
  Extender
  ## TODO: Stop relying on coercions ASAP.
  (<| (:coerce Extender)
      (function (@self handler))
      (:coerce Handler)
      (function (@self name phase))
      (:coerce Phase)
      (function (@self archive parameters))
      (:coerce Operation)
      (function (@self state))
      (:coerce Try)
      try.assume
      (:coerce Try)
      (do try.monad
        [handler (try.from-maybe (..ensure-macro (:coerce Macro handler)))
         #let [to-js (: (-> Any java/lang/Object)
                        (|>> (:coerce (Array java/lang/Object)) js-structure (:coerce java/lang/Object)))]]
        (jdk/nashorn/api/scripting/JSObject::call #.None
                                                  (|> (array.new 2)
                                                      (: (Array java/lang/Object))
                                                      (array.write 0 (to-js name))
                                                      (array.write 1 (to-js phase))
                                                      (array.write 2 (to-js archive))
                                                      (array.write 3 (to-js parameters))
                                                      (array.write 4 (to-js state)))
                                                  (:coerce jdk/nashorn/api/scripting/JSObject handler)))))

(def: (declare-success! _)
  (-> Any (Promise Any))
  (promise.future (io.exit +0)))

(program: [{service /cli.service}]
  (exec (do promise.monad
          [_ (/.compiler {#/static.host @.js
                          #/static.host-module-extension ".js"
                          #/static.target (/cli.target service)
                          #/static.artifact-extension ".js"}
                         ..expander
                         analysis.bundle
                         ..platform
                         generation.bundle
                         extension/bundle.empty
                         (..program reference.artifact)
                         ..extender
                         service
                         [(packager.package _.use-strict _.code _.then)
                          (format (/cli.target service) (:: file.system separator) "program.js")])]
          (..declare-success! []))
    (io.io [])))