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

(.module:
  [lux #*
   [program (#+ program:)]
   ["." host (#+ import:)]
   ["." debug]
   [abstract
    [monad (#+ do)]]
   [control
    ["." try (#+ Try)]
    ["." exception (#+ exception:)]
    ["." io (#+ IO io)]
    ["." function]
    [concurrency
     ["." promise (#+ Promise)]]]
   [data
    ["." product]
    ["." maybe]
    [text
     ["%" format (#+ format)]
     ["." encoding]]
    [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
      ["." 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>]
               [(host.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 org/openjdk/nashorn/api/scripting/JSObject)
               (host.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject [program/IntValue]
                 []
                 ## Methods
                 (program/IntValue
                  [] (getValue self) java/lang/Object
                  (:coerce 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 (:coerce java/lang/Object value)]))))
                 ))

             (def: (::toString js_object)
               (-> Any org/openjdk/nashorn/api/scripting/JSObject)
               (host.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.inspect 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)
               (host.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 (:coerce Int))
                                                     (.int (array.size value)))
                      js_object
                      (:coerce 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 (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 org/openjdk/nashorn/api/scripting/JSObject sub_value))))]
                 (host.object [] org/openjdk/nashorn/api/scripting/AbstractJSObject [program/StructureValue]
                   []
                   ## Methods
                   (program/StructureValue
                    [] (getValue self) java/lang/Object
                    (:coerce (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")
                      (: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)])))
                    )
                   (org/openjdk/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: 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)]
                         [[(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))
                   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)]
                         [(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))
                   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 (host.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 (: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 [#.None]))
                       (case (host.check org/openjdk/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]
                             [program/StructureValue program/StructureValue::getValue]
                             [program/IntValue program/IntValue::getValue]))
                       (case (host.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 (:coerce java/lang/Object js_object))
                                 (exception.return js_object)))))
                         #.None)
                       ## else
                       (exception.throw ..unknown_kind_of_host_object (:coerce java/lang/Object js_object))
                       )))

             (def: (ensure_function function)
               (-> Any (Maybe org/openjdk/nashorn/api/scripting/JSObject))
               (do maybe.monad
                 [function (|> function
                               (:coerce java/lang/Object)
                               (host.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)
                              (|>> (:coerce (Array java/lang/Object)) js_structure (:coerce java/lang/Object)))]
                 (<| (:coerce (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
                       (: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))))
             )

      @.js
      (def: (expander macro inputs lux)
        Expander
        (#try.Success ((:coerce 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 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 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)
                        (structure
                         (def: evaluate! (..evaluate! interpreter))
                         (def: execute! (..execute! interpreter))
                         (def: define! (..define! interpreter))

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

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

      @.js
      (as_is (def: (eval code)
               (-> Text (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";.
               (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 (host.try (..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 (host.try (..eval (_.code input)))]
                 (wrap [])))

             (def: (define! context input)
               (-> Context _.Expression (Try [Text Any _.Statement]))
               (let [global (reference.artifact context)
                     @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)
                      (structure
                       (def: evaluate! ..evaluate!)
                       (def: execute! ..execute!)
                       (def: define! ..define!)

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

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

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

(def: (program context program)
  (-> (Program _.Expression _.Statement))
  (let [@process (_.var "process")
        on_node_js? (|> (|> @process _.type_of (_.= (_.string "undefined")) _.not)
                        (_.and (|> @process (_.the "argv"))))
        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
        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_function handler))
               #let [to_js (: (-> Any java/lang/Object)
                              (|>> (:coerce (Array java/lang/Object)) js_structure (:coerce 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 (to_js phase))
                                                                            (array.write! 2 (to_js archive))
                                                                            (array.write! 3 (to_js parameters))
                                                                            (array.write! 4 (to_js state)))
                                                                        handler)]
              (lux_object (:coerce java/lang/Object output)))))

      @.js
      (def: (extender handler)
        Extender
        (:assume handler))})

(def: (declare_success! _)
  (-> Any (Promise Any))
  (promise.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 promise.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
                           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 []))))