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

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

(host.import: java/lang/String)

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

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

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

(host.import: net/sandius/rembulan/StateContext)

(host.import: net/sandius/rembulan/impl/StateContexts
  ["#::."
   (#static newDefaultInstance [] net/sandius/rembulan/StateContext)])

(host.import: net/sandius/rembulan/env/RuntimeEnvironment)

(host.import: net/sandius/rembulan/env/RuntimeEnvironments
  ["#::."
   (#static system [] net/sandius/rembulan/env/RuntimeEnvironment)])

(host.import: net/sandius/rembulan/Table
  ["#::."
   (rawget #as get_idx [long] #? java/lang/Object)
   (rawget #as get_key [java/lang/Object] #? java/lang/Object)
   (rawlen [] long)])

(host.import: net/sandius/rembulan/ByteString
  ["#::."
   (decode [] java/lang/String)])

(host.import: net/sandius/rembulan/impl/DefaultTable)

(host.import: net/sandius/rembulan/impl/ImmutableTable)

(host.import: net/sandius/rembulan/impl/ImmutableTable$Builder
  ["#::."
   (new [])
   (build [] net/sandius/rembulan/impl/ImmutableTable)])

(host.import: net/sandius/rembulan/lib/StandardLibrary
  ["#::."
   (#static in [net/sandius/rembulan/env/RuntimeEnvironment] net/sandius/rembulan/lib/StandardLibrary)
   (installInto [net/sandius/rembulan/StateContext] net/sandius/rembulan/Table)])

(host.import: net/sandius/rembulan/Variable
  ["#::."
   (new [java/lang/Object])])

(host.import: net/sandius/rembulan/runtime/LuaFunction)

(host.import: net/sandius/rembulan/load/ChunkLoader
  ["#::."
   (loadTextChunk [net/sandius/rembulan/Variable
                   java/lang/String
                   java/lang/String]
                  net/sandius/rembulan/runtime/LuaFunction)])

(host.import: net/sandius/rembulan/compiler/CompilerChunkLoader
  ["#::."
   (#static of [java/lang/String] net/sandius/rembulan/compiler/CompilerChunkLoader)])

(host.import: net/sandius/rembulan/runtime/SchedulingContext)

(host.import: net/sandius/rembulan/runtime/SchedulingContextFactory)

(host.import: net/sandius/rembulan/exec/DirectCallExecutor
  ["#::."
   (#static newExecutor [] net/sandius/rembulan/exec/DirectCallExecutor)
   (schedulingContextFactory [] net/sandius/rembulan/runtime/SchedulingContextFactory)
   (call [net/sandius/rembulan/StateContext java/lang/Object [java/lang/Object]] #try [java/lang/Object])])

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

(template [<name>]
  [(host.interface: <name>
     (getValue [] java/lang/Object))

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

  [StructureValue]
  )

(def: (lux_structure value)
  (-> (Array java/lang/Object) program/StructureValue)
  (let [re_wrap (function (_ unwrapped)
                  (case (host.check [java/lang/Object] unwrapped)
                    (#.Some sub_value)
                    (|> sub_value (:coerce (Array java/lang/Object)) lux_structure (:coerce java/lang/Object))
                    
                    #.None
                    unwrapped))]
    (host.object [] net/sandius/rembulan/impl/DefaultTable [program/StructureValue]
      []
      ## Methods
      (program/StructureValue
       [] (getValue self) java/lang/Object
       (:coerce (Array java/lang/Object) value))

      (net/sandius/rembulan/impl/DefaultTable
       [] (rawlen self) long
       (|> value array.size (:coerce java/lang/Long)))

      (net/sandius/rembulan/impl/DefaultTable
       [] (rawget self {idx long}) java/lang/Object
       (|> value (array.read (|> idx (:coerce Nat) dec)) maybe.assume re_wrap))

      (net/sandius/rembulan/impl/DefaultTable
       [] (rawget self {field java/lang/Object}) java/lang/Object
       (case (host.check net/sandius/rembulan/ByteString field)
         (#.Some field)
         (case (net/sandius/rembulan/ByteString::decode field)
           (^ (static runtime.variant_tag_field))
           (|> value (array.read 0) maybe.assume)
           
           (^ (static runtime.variant_flag_field))
           (case (array.read 1 value)
             (#.Some _)
             ""

             #.None
             (host.null))
           
           (^ (static runtime.variant_value_field))
           (|> value (array.read 2) maybe.assume re_wrap)

           _
           (error! (exception.construct ..unknown_kind_of_object field)))

         #.None
         (case (host.check java/lang/Long field)
           (#.Some idx)
           (|> value (array.read (|> idx (:coerce Nat) dec)) maybe.assume re_wrap)
           
           #.None
           (error! (exception.construct ..unknown_kind_of_object field)))))
      )))

(type: Translator
  (-> java/lang/Object (Try Any)))

(def: (read_variant read host_object)
  (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any))
  (case [(net/sandius/rembulan/Table::get_key runtime.variant_tag_field host_object)
         (net/sandius/rembulan/Table::get_key runtime.variant_flag_field host_object)
         (net/sandius/rembulan/Table::get_key runtime.variant_value_field host_object)]
    (^multi [(#.Some tag) ?flag (#.Some value)]
            [(read value)
             (#.Some value)])
    (#try.Success [(java/lang/Long::intValue (:coerce java/lang/Long tag))
                   (: Any (case ?flag (#.Some _) "" #.None (host.null)))
                   value])

    _
    (exception.throw ..unknown_kind_of_object host_object)))

(def: (read_tuple read host_object)
  (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any))
  (let [init_num_keys (.nat (net/sandius/rembulan/Table::rawlen host_object))]
    (loop [num_keys init_num_keys
           idx 0
           output (: (Array java/lang/Object)
                     (array.new init_num_keys))]
      (if (n.< num_keys idx)
        (case (net/sandius/rembulan/Table::get_idx (:coerce java/lang/Long (inc idx)) host_object)
          #.None
          (recur num_keys (inc idx) output)

          (#.Some member)
          (case (read member)
            (#try.Success parsed_member)
            (recur num_keys (inc idx) (array.write! idx (:coerce java/lang/Object parsed_member) output))

            (#try.Failure error)
            (#try.Failure error)))
        (#try.Success output)))))

(exception: #export nil_has_no_lux_representation)

(def: (read host_object)
  Translator
  (`` (<| (if (host.null? host_object)
            (exception.throw ..nil_has_no_lux_representation []))
          (~~ (template [<class> <post_processing>]
                [(case (host.check <class> host_object)
                   (#.Some typed_object)
                   (|> typed_object <post_processing>)

                   _)]

                [java/lang/Boolean #try.Success]
                [java/lang/Long #try.Success]
                [java/lang/Double #try.Success]
                [java/lang/String #try.Success]
                [net/sandius/rembulan/runtime/LuaFunction #try.Success]
                [net/sandius/rembulan/ByteString (<| #try.Success net/sandius/rembulan/ByteString::decode)]
                [program/StructureValue (<| #try.Success program/StructureValue::getValue)]
                ))
          (case (host.check net/sandius/rembulan/impl/DefaultTable host_object)
            (#.Some typed_object)
            (case (read_variant read typed_object)
              (#try.Success value)
              (#try.Success value)

              (#try.Failure error)
              (case (read_tuple read typed_object)
                (#try.Success value)
                (#try.Success value)

                (#try.Failure error)
                (exception.throw ..unknown_kind_of_object host_object)))

            _
            (exception.throw ..unknown_kind_of_object host_object))
          )))

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

(def: ensure_function
  (-> Macro (Maybe net/sandius/rembulan/runtime/LuaFunction))
  (|>> (:coerce java/lang/Object) (host.check net/sandius/rembulan/runtime/LuaFunction)))

(type: Baggage
  [net/sandius/rembulan/StateContext
   net/sandius/rembulan/exec/DirectCallExecutor])

(def: (call_macro [state_context executor] inputs lux macro)
  (-> Baggage (List Code) Lux net/sandius/rembulan/runtime/LuaFunction (Try Any))
  (do try.monad
    [output (net/sandius/rembulan/exec/DirectCallExecutor::call state_context
                                                                (:coerce java/lang/Object macro)
                                                                (|> (array.new 2)
                                                                    (array.write! 0 ## (:coerce java/lang/Object inputs)
                                                                                  ## (net/sandius/rembulan/impl/ImmutableTable$Builder::build (net/sandius/rembulan/impl/ImmutableTable$Builder::new))
                                                                                  (:coerce java/lang/Object (lux_structure (:coerce (Array java/lang/Object) inputs))))
                                                                    (array.write! 1 ## (:coerce java/lang/Object lux)
                                                                                  ## (net/sandius/rembulan/impl/ImmutableTable$Builder::build (net/sandius/rembulan/impl/ImmutableTable$Builder::new))
                                                                                  (:coerce java/lang/Object (lux_structure (:coerce (Array java/lang/Object) lux)))))
                                                                executor)]
    (wrap (|> output (array.read 0) maybe.assume (:coerce java/lang/Object) ..read))))

(def: (expander baggage macro inputs lux)
  (-> Baggage Expander)
  (case (..ensure_function macro)
    (#.Some macro)
    (case (call_macro baggage inputs lux macro)
      (#try.Success output)
      (|> output
          (: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: separator "___")

(def: host
  (IO [Baggage (Host _.Expression _.Statement)])
  (io (let [runtime_env (net/sandius/rembulan/env/RuntimeEnvironments::system)
            std_lib (net/sandius/rembulan/lib/StandardLibrary::in runtime_env)
            state_context (net/sandius/rembulan/impl/StateContexts::newDefaultInstance)
            table (net/sandius/rembulan/lib/StandardLibrary::installInto state_context std_lib)
            variable (net/sandius/rembulan/Variable::new table)
            loader (net/sandius/rembulan/compiler/CompilerChunkLoader::of "_lux_definition")
            executor (net/sandius/rembulan/exec/DirectCallExecutor::newExecutor)
            scheduling_context (net/sandius/rembulan/exec/DirectCallExecutor::schedulingContextFactory executor)
            run! (: (-> _.Statement (Try Any))
                    (function (_ code)
                      (do try.monad
                        [#let [lua_function (net/sandius/rembulan/load/ChunkLoader::loadTextChunk variable "lux compilation" (_.code code)
                                                                                                  loader)]
                         output (net/sandius/rembulan/exec/DirectCallExecutor::call state_context (:coerce java/lang/Object lua_function) (array.new 0)
                                                                                    executor)]
                        (case (array.read 0 output)
                          #.None
                          (wrap [])

                          (#.Some value)
                          (read value)))))]
        [[state_context executor]
         (: (Host _.Expression _.Statement)
            (structure
             (def: (evaluate! context code)
               (run! (_.return code)))
             
             (def: execute! run!)
             
             (def: (define! context input)
               (let [global (reference.artifact context)
                     @global (_.var global)]
                 (do try.monad
                   [#let [definition (_.set (list @global) input)]
                    _ (run! definition)
                    value (run! (_.return @global))]
                   (wrap [global value definition]))))

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

             (def: (re_learn context content)
               (run! content))
             
             (def: (re_load context content)
               (do try.monad
                 [_ (run! content)]
                 (run! (_.return (_.var (reference.artifact context))))))))])))

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

(def: (program context program)
  (Program _.Expression _.Statement)
  (_.statement (_.apply/* (list (runtime.lux//program_args (_.var "arg"))
                                _.nil)
                          program)))

(for {@.old
      (def: (extender [state_context executor])
        (-> Baggage 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_lua (: (-> Any java/lang/Object)
                               (|>> (:coerce (Array java/lang/Object)) lux_structure (:coerce java/lang/Object)))]
               output (net/sandius/rembulan/exec/DirectCallExecutor::call state_context
                                                                          (:coerce java/lang/Object handler)
                                                                          (|> (array.new 5)
                                                                              (array.write! 0 name)
                                                                              (array.write! 1 (to_lua phase))
                                                                              (array.write! 2 (to_lua archive))
                                                                              (array.write! 3 (to_lua parameters))
                                                                              (array.write! 4 (to_lua state)))
                                                                          executor)]
              (|> output
                  (array.read 0)
                  maybe.assume
                  (:coerce java/lang/Object)
                  ..read))))

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

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

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

(program: [{service /cli.service}]
  (let [extension ".lua"]
    (do io.monad
      [[baggage platform] ..platform]
      (exec (do promise.monad
              [_ (/.compiler {#/static.host @.lua
                              #/static.host_module_extension extension
                              #/static.target (/cli.target service)
                              #/static.artifact_extension extension}
                             (..expander baggage)
                             analysis.bundle
                             (io.io platform)
                             generation.bundle
                             extension/bundle.empty
                             ..program
                             [_.Var _.Expression _.Statement]
                             (..extender baggage)
                             service
                             [(packager.package (_.manual "") _.code _.then ..scope)
                              (format (/cli.target service)
                                      (\ file.default separator)
                                      "program"
                                      extension)])]
              (..declare_success! []))
        (io.io [])))))