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

(.module:
  [library
   [lux #*
    [program (#+ program:)]
    ["." ffi (#+ import:)]
    ["." debug]
    [abstract
     [monad (#+ do)]]
    [control
     ["." try (#+ Try)]
     ["." exception (#+ exception:)]
     ["." io (#+ IO io)]
     ["." function]
     [concurrency
      ["." async (#+ Async)]]]
    [data
     ["." product]
     ["." maybe]
     [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)

                    _
                    (error! (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.assume (: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.assume)
                      
                      (^ (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.assume js_object (:as java/lang/Object))
                      
                      _
                      (error! (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.assume
                        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 (inc idx) output)

                           #.None
                           (case (lux_object member)
                             (#try.Success parsed_member)
                             (recur (inc idx) (array.write! idx (:as 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 (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.assumed (: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.assumed (: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.assumed
            (: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)
        (:assume 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 []))))