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

(.module:
  [library
   [lux #*
    [program (#+ program:)]
    ["." ffi (#+ import:)]
    ["." debug]
    [abstract
     [monad (#+ do)]]
    [control
     ["." maybe]
     ["." try (#+ Try)]
     ["." exception (#+ exception:)]
     ["." io (#+ IO io)]
     ["." function]
     [concurrency
      ["." async (#+ Async)]]]
    [data
     ["." product]
     [text
      ["%" format (#+ format)]
      [encoding
       ["." utf8]]]
     [collection
      ["." array (#+ Array)]]]
    [macro
     ["." template]]
    [math
     [number
      ["n" nat]
      ["i" int]
      ["." i64]]]
    ["." world #_
     ["." file]
     ["#/." program]]
    ["@" target
     ["_" js]]
    [tool
     [compiler
      ["." phase (#+ Operation Phase)]
      [reference
       [variable (#+ Register)]]
      [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
       [archive (#+ Archive)]
       ["." packager #_
        ["#" script]]]]]]]
  [program
   ["/" compositor
    ["#." cli]
    ["#." static]]])

(exception: (null_has_no_lux_representation {code (Maybe _.Expression)})
  (case code
    (#.Some code)
    (_.code code)

    #.None
    "???"))

(for {@.old
      (as_is (import: java/lang/String)

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

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

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

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

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

             (import: java/util/Arrays
               ["#::."
                (#static [t] copyOfRange [[t] int int] [t])])

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

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

             (import: org/openjdk/nashorn/api/scripting/NashornScriptEngineFactory
               ["#::."
                (new [])])

             (import: org/openjdk/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: org/openjdk/nashorn/api/scripting/AbstractJSObject)

             (import: org/openjdk/nashorn/api/scripting/ScriptObjectMirror
               ["#::."
                (size [] int)
                (toString [] java/lang/String)])

             (import: org/openjdk/nashorn/internal/runtime/Undefined)

             (template [<name>]
               [(ffi.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.inspection object)]))

             (def: jvm_int
               (-> (I64 Any) java/lang/Integer)
               (|>> (:as java/lang/Long) java/lang/Long::intValue))

             (def: (js_int value)
               (-> Int org/openjdk/nashorn/api/scripting/JSObject)
               (ffi.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject [program/IntValue]
                 []
                 ... Methods
                 (program/IntValue
                  [] (getValue self) java/lang/Object
                  (:as java/lang/Object value))
                 (org/openjdk/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)

                    _
                    (panic! (exception.construct ..unknown_member [member (:as java/lang/Object value)]))))
                 ))

             (def: (::toString js_object)
               (-> Any org/openjdk/nashorn/api/scripting/JSObject)
               (ffi.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject []
                 []
                 (org/openjdk/nashorn/api/scripting/AbstractJSObject
                  [] (isFunction self) boolean
                  #1)
                 (org/openjdk/nashorn/api/scripting/AbstractJSObject
                  [] (call self {this java/lang/Object} {args [java/lang/Object]}) java/lang/Object
                  (debug.inspection js_object))
                 ))

             (def: (::slice js_object value)
               (-> (-> java/lang/Object org/openjdk/nashorn/api/scripting/JSObject) (Array java/lang/Object) org/openjdk/nashorn/api/scripting/JSObject)
               (ffi.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject []
                 []
                 (org/openjdk/nashorn/api/scripting/AbstractJSObject
                  [] (isFunction self) boolean
                  #1)
                 (org/openjdk/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.trusted (:as Int))
                                                     (.int (array.size value)))
                      js_object
                      (:as java/lang/Object)))
                 ))

             (def: (js_structure value)
               (-> (Array java/lang/Object) org/openjdk/nashorn/api/scripting/JSObject)
               (let [js_object (: (-> java/lang/Object org/openjdk/nashorn/api/scripting/JSObject)
                                  (function (_ sub_value)
                                    (<| (case (ffi.check [java/lang/Object] sub_value)
                                          (#.Some sub_value)
                                          (|> sub_value (:as (Array java/lang/Object)) js_structure)
                                          #.None)
                                        (case (ffi.check java/lang/Long sub_value)
                                          (#.Some sub_value)
                                          (|> sub_value (:as Int) js_int)
                                          #.None)
                                        ... else
                                        (:as org/openjdk/nashorn/api/scripting/JSObject sub_value))))]
                 (ffi.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject [program/StructureValue]
                   []
                   ... Methods
                   (program/StructureValue
                    [] (getValue self) java/lang/Object
                    (:as (Array java/lang/Object) value))
                   (org/openjdk/nashorn/api/scripting/AbstractJSObject
                    [] (isArray self) boolean
                    #1)
                   (org/openjdk/nashorn/api/scripting/AbstractJSObject
                    [] (getMember self {member java/lang/String}) java/lang/Object
                    (case member
                      (^or "toJSON" "toString")
                      (:as java/lang/Object
                           (::toString value))
                      
                      "length"
                      (jvm_int (array.size value))
                      
                      "slice"
                      (:as java/lang/Object
                           (::slice js_object value))

                      (^ (static runtime.variant_tag_field))
                      (|> value (array.read! 0) maybe.trusted)
                      
                      (^ (static runtime.variant_flag_field))
                      (case (array.read! 1 value)
                        (#.Some set!)
                        set!

                        _
                        (ffi.null))
                      
                      (^ (static runtime.variant_value_field))
                      (|> value (array.read! 2) maybe.trusted js_object (:as java/lang/Object))
                      
                      _
                      (panic! (exception.construct ..unknown_member [(:as Text member) (:as java/lang/Object value)])))
                    )
                   (org/openjdk/nashorn/api/scripting/AbstractJSObject
                    [] (getSlot self {idx int}) java/lang/Object
                    (|> value
                        (array.read! (|> idx java/lang/Integer::longValue (:as Nat)))
                        maybe.trusted
                        js_object
                        (:as java/lang/Object)))
                   )))

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

             (def: (check_int js_object)
               (-> org/openjdk/nashorn/api/scripting/ScriptObjectMirror
                   (Maybe Int))
               (case [(org/openjdk/nashorn/api/scripting/JSObject::getMember [runtime.i64_high_field] js_object)
                      (org/openjdk/nashorn/api/scripting/JSObject::getMember [runtime.i64_low_field] js_object)]
                 (^multi [(#.Some high) (#.Some low)]
                         {[(ffi.check java/lang/Number high)
                           (ffi.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.right_shift 32))
                                      (.nat low)))))

                 _
                 #.None))

             (def: (check_variant lux_object js_object)
               (-> (-> java/lang/Object (Try Any))
                   org/openjdk/nashorn/api/scripting/ScriptObjectMirror
                   (Maybe Any))
               (case [(org/openjdk/nashorn/api/scripting/JSObject::getMember [runtime.variant_tag_field] js_object)
                      (org/openjdk/nashorn/api/scripting/JSObject::getMember [runtime.variant_flag_field] js_object)
                      (org/openjdk/nashorn/api/scripting/JSObject::getMember [runtime.variant_value_field] js_object)]
                 (^multi [(#.Some tag) ?flag (#.Some value)]
                         {(ffi.check java/lang/Number tag)
                          (#.Some tag)}
                         {(lux_object value)
                          (#.Some value)})
                 (#.Some [(java/lang/Number::intValue tag)
                          (maybe.default (ffi.null) ?flag)
                          value])

                 _
                 #.None))

             (def: (check_array lux_object js_object)
               (-> (-> java/lang/Object (Try Any))
                   org/openjdk/nashorn/api/scripting/ScriptObjectMirror
                   (Maybe (Array java/lang/Object)))
               (if (org/openjdk/nashorn/api/scripting/JSObject::isArray js_object)
                 (let [num_keys (.nat (org/openjdk/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 (org/openjdk/nashorn/api/scripting/JSObject::getMember (%.nat idx) js_object)
                         (#.Some member)
                         (case (ffi.check org/openjdk/nashorn/internal/runtime/Undefined member)
                           (#.Some _)
                           (recur (++ idx) output)

                           #.None
                           (case (lux_object member)
                             (#try.Success parsed_member)
                             (recur (++ idx) (array.write! idx (:as java/lang/Object parsed_member) output))

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

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

             (def: (lux_object js_object)
               (-> java/lang/Object (Try Any))
               (`` (<| (if (ffi.null? js_object)
                         (exception.throw ..null_has_no_lux_representation [#.None]))
                       (case (ffi.check org/openjdk/nashorn/internal/runtime/Undefined js_object)
                         (#.Some _)
                         (exception.throw ..undefined_has_no_lux_representation [])
                         #.None)
                       (~~ (template [<class>]
                             [(case (ffi.check <class> js_object)
                                (#.Some js_object)
                                (exception.return js_object)
                                #.None)]

                             [java/lang/Boolean] [java/lang/String]))
                       (~~ (template [<class> <method>]
                             [(case (ffi.check <class> js_object)
                                (#.Some js_object)
                                (exception.return (<method> js_object))
                                #.None)]

                             [java/lang/Number java/lang/Number::doubleValue]
                             [program/StructureValue program/StructureValue::getValue]
                             [program/IntValue program/IntValue::getValue]))
                       (case (ffi.check org/openjdk/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 (org/openjdk/nashorn/api/scripting/JSObject::isFunction js_object)
                                 (exception.return js_object)
                                 ... (exception.throw ..unknown_kind_of_host_object (:as java/lang/Object js_object))
                                 (exception.return js_object)))))
                         #.None)
                       ... else
                       (exception.throw ..unknown_kind_of_host_object (:as java/lang/Object js_object))
                       )))

             (def: (ensure_function function)
               (-> Any (Maybe org/openjdk/nashorn/api/scripting/JSObject))
               (do maybe.monad
                 [function (|> function
                               (:as java/lang/Object)
                               (ffi.check org/openjdk/nashorn/api/scripting/JSObject))]
                 (if (org/openjdk/nashorn/api/scripting/JSObject::isFunction function)
                   (#.Some function)
                   #.None)))
             )

      @.js
      (as_is)})

(for {@.old
      (as_is (def: (call_macro inputs lux macro)
               (-> (List Code) Lux org/openjdk/nashorn/api/scripting/JSObject (Try (Try [Lux (List Code)])))
               (let [to_js (: (-> Any java/lang/Object)
                              (|>> (:as (Array java/lang/Object)) js_structure (:as java/lang/Object)))]
                 (<| (:as (Try (Try [Lux (List Code)])))
                     (org/openjdk/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))))

             (exception: (cannot_apply_a_non_function {object java/lang/Object})
               (exception.report
                ["Object" (java/lang/Object::toString object)]))

             (def: (expander macro inputs lux)
               Expander
               (case (..ensure_function macro)
                 (#.Some macro)
                 (case (call_macro inputs lux macro)
                   (#try.Success output)
                   (|> output
                       (:as java/lang/Object)
                       lux_object
                       (:as (Try (Try [Lux (List Code)]))))

                   (#try.Failure error)
                   (#try.Failure error))
                 
                 #.None
                 (exception.throw ..cannot_apply_a_non_function (:as java/lang/Object macro))))
             )

      @.js
      (def: (expander macro inputs lux)
        Expander
        (#try.Success ((:as Macro' macro) inputs lux)))
      })

(for {@.old
      (as_is (def: (evaluate! interpreter alias input)
               (-> javax/script/ScriptEngine Context _.Expression (Try Any))
               (do try.monad
                 [?output (javax/script/ScriptEngine::eval (_.code input) interpreter)]
                 (case ?output
                   (#.Some output)
                   (..lux_object output)

                   #.None
                   (exception.throw ..null_has_no_lux_representation [(#.Some input)]))))

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

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

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

                         (def: (ingest context content)
                           (|> content (\ utf8.codec decode) try.trusted (:as _.Statement)))

                         (def: (re_learn context custom content)
                           (..execute! interpreter content))
                         
                         (def: (re_load context custom content)
                           (do try.monad
                             [_ (..execute! interpreter content)]
                             (..evaluate! interpreter context (_.var (reference.artifact context))))))))))
             )

      @.js
      (as_is (def: (eval code)
               (-> Text (Try (Maybe Any)))
               ... Note: I have to call "eval" this way
               ... in order to avoid a quirk of calling eval in Node
               ... when the code is running under "use strict";.
               (try (let [return ("js apply" (function.identity ("js constant" "eval")) code)]
                      (if ("js object null?" return)
                        #.None
                        (#.Some return)))))
             
             (def: (evaluate! alias input)
               (-> Context _.Expression (Try Any))
               (do try.monad
                 [?output (..eval (_.code input))]
                 (case ?output
                   (#.Some output)
                   (wrap output)

                   #.None
                   (exception.throw ..null_has_no_lux_representation [(#.Some input)]))))

             (def: (execute! input)
               (-> _.Statement (Try Any))
               (do try.monad
                 [?output (..eval (_.code input))]
                 (wrap [])))

             (def: (define! context custom input)
               (-> Context (Maybe Text) _.Expression (Try [Text Any _.Statement]))
               (let [global (maybe.default (reference.artifact context)
                                           custom)
                     @global (_.var global)]
                 (do try.monad
                   [#let [definition (_.define @global input)]
                    _ (..execute! definition)
                    value (..evaluate! context @global)]
                   (wrap [global value definition]))))

             (def: host
               (IO (Host _.Expression _.Statement))
               (io (: (Host _.Expression _.Statement)
                      (implementation
                       (def: evaluate! ..evaluate!)
                       (def: execute! ..execute!)
                       (def: define! ..define!)

                       (def: (ingest context content)
                         (|> content (\ utf8.codec decode) try.trusted (:as _.Statement)))

                       (def: (re_learn context custom content)
                         (..execute! content))
                       
                       (def: (re_load context custom content)
                         (do try.monad
                           [_ (..execute! content)]
                           (..evaluate! context (_.var (reference.artifact context)))))))))
             )})

(def: (phase_wrapper archive)
  (-> Archive (runtime.Operation platform.Phase_Wrapper))
  (do phase.monad
    []
    (wrap (:as platform.Phase_Wrapper
               (for {... The implementation for @.old is technically incorrect.
                     ... However, the JS compiler runs fast enough on Node to be fully hosted there.
                     ... And running the JS compiler on the JVM (on top of Nashorn) is impractically slow.
                     ... This means that in practice, only the @.js implementation matters.
                     ... And since no cross-language boundary needs to be handled, it's a correct implementation.
                     @.old (|>>)
                     @.js (|>>)})))))

(def: platform
  (IO (Platform [Register Text] _.Expression _.Statement))
  (do io.monad
    [host ..host]
    (wrap {#platform.&file_system (for {@.old (file.async file.default)
                                        @.jvm (file.async file.default)
                                        @.js file.default})
           #platform.host host
           #platform.phase js.generate
           #platform.runtime runtime.generate
           #platform.phase_wrapper ..phase_wrapper
           #platform.write (|>> _.code (\ utf8.codec encode))})))

(def: (program context program)
  (Program _.Expression _.Statement)
  (let [@process (_.var "process")
        on_node_js? (|> @process
                        _.type_of
                        (_.= (_.string "undefined"))
                        _.not
                        (_.and (_.the "argv" @process)))
        node_js_inputs (|> @process
                           (_.the "argv")
                           (_.do "slice" (list (_.int +2))))
        no_inputs (_.array (list))]
    (_.statement (_.apply/1 (_.apply/1 program (runtime.lux//program_args (_.? on_node_js?
                                                                               node_js_inputs
                                                                               no_inputs)))
                            (_.string "")))))

(for {@.old
      (def: (extender phase_wrapper)
        (-> platform.Phase_Wrapper Extender)
        ... TODO: Stop relying on coercions ASAP.
        (<| (:as Extender)
            (function (@self handler))
            (:as Handler)
            (function (@self name phase))
            (:as Phase)
            (function (@self archive parameters))
            (:as Operation)
            (function (@self state))
            (:as Try)
            try.trusted
            (:as Try)
            (do try.monad
              [handler (try.of_maybe (..ensure_function handler))
               #let [to_js (: (-> Any java/lang/Object)
                              (|>> (:as (Array java/lang/Object)) js_structure (:as java/lang/Object)))]
               output (org/openjdk/nashorn/api/scripting/JSObject::call #.None
                                                                        (|> (array.new 5)
                                                                            (: (Array java/lang/Object))
                                                                            (array.write! 0 name)
                                                                            (array.write! 1 (:as java/lang/Object (extender phase)))
                                                                            (array.write! 2 (to_js archive))
                                                                            (array.write! 3 (to_js parameters))
                                                                            (array.write! 4 (to_js state)))
                                                                        handler)]
              (lux_object (:as java/lang/Object output)))))

      @.js
      (def: (extender phase_wrapper handler)
        (-> platform.Phase_Wrapper Extender)
        (:expected handler))})

(def: (declare_success! _)
  (-> Any (Async Any))
  (async.future (\ world/program.default exit +0)))

(def: (scope body)
  (-> _.Statement _.Statement)
  (_.statement (_.apply/* (_.closure (list) body)
                          (list))))

(program: [service /cli.service]
  (let [extension ".js"]
    (exec (do async.monad
            [_ (/.compiler {#/static.host @.js
                            #/static.host_module_extension extension
                            #/static.target (/cli.target service)
                            #/static.artifact_extension extension}
                           ..expander
                           analysis.bundle
                           ..platform
                           generation.bundle
                           (function.constant extension/bundle.empty)
                           ..program
                           [(& Register Text) _.Expression _.Statement]
                           ..extender
                           service
                           [(packager.package _.use_strict _.code _.then ..scope)
                            (format (/cli.target service)
                                    (\ file.default separator)
                                    "program"
                                    extension)])]
            (..declare_success! []))
      (io.io []))))