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

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

(ffi.import: java/lang/String)

(ffi.import: (java/lang/Class a)
  ["#::."
   ("static" forName [java/lang/String] "try" (java/lang/Class java/lang/Object))])

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

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

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

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

(ffi.import: org/renjin/sexp/SEXP
  ["#::."
   (asInt [] int)])

(ffi.import: org/renjin/sexp/AttributeMap
  ["#::."
   ("static" EMPTY org/renjin/sexp/AttributeMap)])

(ffi.import: org/renjin/sexp/AbstractSEXP)

(ffi.import: org/renjin/sexp/IntArrayVector)

(ffi.import: org/renjin/sexp/Logical
  ["#::."
   (toBooleanStrict [] boolean)])

(ffi.import: org/renjin/sexp/LogicalVector
  ["#::."
   (asLogical [] org/renjin/sexp/Logical)])

(ffi.import: org/renjin/sexp/LogicalArrayVector)

(ffi.import: org/renjin/sexp/StringVector
  ["#::."
   (asString [] java/lang/String)])

(ffi.import: org/renjin/sexp/StringArrayVector)

(ffi.import: org/renjin/sexp/Null)

(ffi.import: org/renjin/sexp/ListVector
  ["#::."
   (get "as" get_index [int] org/renjin/sexp/SEXP)
   (get "as" get_field [java/lang/String] org/renjin/sexp/SEXP)
   (length [] int)])

(ffi.import: org/renjin/sexp/PairList)

(ffi.import: org/renjin/sexp/PairList$Builder
  ["#::."
   (new [])
   (add [org/renjin/sexp/SEXP] org/renjin/sexp/PairList$Builder)
   (build [] org/renjin/sexp/PairList)])

(ffi.import: org/renjin/eval/Context)

(ffi.import: org/renjin/sexp/Environment)

(ffi.import: org/renjin/sexp/FunctionCall
  ["#::."
   (new [org/renjin/sexp/SEXP org/renjin/sexp/PairList])
   (eval [org/renjin/eval/Context org/renjin/sexp/Environment] "try" org/renjin/sexp/SEXP)])

(ffi.import: org/renjin/sexp/Closure
  ["#::."
   (getEnclosingEnvironment [] org/renjin/sexp/Environment)])

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

(ffi.import: org/renjin/script/RenjinScriptEngine
  ["#::."
   (getRuntimeContext [] org/renjin/eval/Context)])

(ffi.import: org/renjin/script/RenjinScriptEngineFactory
  ["#::."
   (new [])
   (getScriptEngine [] org/renjin/script/RenjinScriptEngine)])

(template [<name>]
  [(exception: (<name> {object java/lang/Object})
     (exception.report
      ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))]
      ["Object" (java/lang/Object::toString object)]))]

  [unknown_kind_of_object]
  [cannot_apply_a_non_function]
  )

... (def: host_bit
...   (-> Bit org/armedbear/lisp/LispObject)
...   (|>> (case> #0 (org/armedbear/lisp/Nil::NIL)
...               #1 (org/armedbear/lisp/Symbol::T))))

(syntax: (%%code [term <code>.any])
  (wrap (list (code.text (%.code term)))))

(def: (host_value value)
  (-> Any org/renjin/sexp/SEXP)
  (let [... to_sub (: (-> Any org/armedbear/lisp/LispObject)
        ...           (function (_ sub_value)
        ...             (let [sub_value (:as java/lang/Object sub_value)]
        ...               (`` (<| (~~ (template [<type> <then>]
        ...                             [(case (ffi.check <type> sub_value)
        ...                                (#.Some sub_value)
        ...                                (`` (|> sub_value (~~ (template.splice <then>))))
        ...                                #.None)]

        ...                             [[java/lang/Object] [host_value]]
        ...                             [java/lang/Boolean [..host_bit]]
        ...                             [java/lang/Integer [java/lang/Integer::longValue org/armedbear/lisp/Fixnum::getInstance]]
        ...                             [java/lang/Long [org/armedbear/lisp/Bignum::getInstance]]
        ...                             [java/lang/Double [org/armedbear/lisp/DoubleFloat::new]]
        ...                             [java/lang/String [org/armedbear/lisp/SimpleString::new]]
        ...                             ))
        ...                       ... else
        ...                       (:as org/armedbear/lisp/LispObject sub_value))))))
        ]
    (`` (macro.log_expand_once!
         (ffi.object []
           ... org/renjin/sexp/AbstractSEXP
           org/renjin/sexp/ListVector
           ... java/lang/Object
           [                    ... program/LuxADT
            ... org/renjin/sexp/SEXP
            ]
           [{[org/renjin/sexp/SEXP]
             (ffi.array org/renjin/sexp/SEXP 0)
             
             ... (java/util/List java/lang/Object)
             ... (:expected (..fake_list []))
             }]
           ... Methods
           ... (program/LuxADT
           ...  [] (getValue self) java/lang/Object
           ...  (:as java/lang/Object value))

           ... (org/renjin/sexp/AbstractSEXP
           ...  [] (eval self {context org/renjin/eval/Context} {environment org/renjin/sexp/Environment})
           ...  org/renjin/sexp/SEXP
           ...  (exec
           ...    ("lux io log" (exception.report
           ...                   ["@@" "eval"]
           ...                   ["context" (debug.inspect context)]
           ...                   ["environment" (debug.inspect environment)]))
           ...    self))

           ... (org/renjin/sexp/AbstractSEXP
           ...  [] (getAttributes self)
           ...  org/renjin/sexp/AttributeMap
           ...  (org/renjin/sexp/AttributeMap::EMPTY))

           ... (org/renjin/sexp/AbstractSEXP
           ...  [] (getTypeName self)
           ...  java/lang/String
           ...  "LUX")

           (org/renjin/sexp/ListVector
            [] (get self {_ int})
            org/renjin/sexp/SEXP
            (exec
              ... ("lux io log" (..%%code <call>))
              _jvm_this))

           (org/renjin/sexp/ListVector
            [] (get self {_ java/lang/String})
            org/renjin/sexp/SEXP
            (exec
              ... ("lux io log" (..%%code <call>))
              _jvm_this))
           
           (~~ (template [<call> <output>]
                 [(org/renjin/sexp/ListVector
                   ... org/renjin/sexp/AbstractSEXP
                   ... org/renjin/sexp/SEXP
                   [] <call>
                   <output>
                   ... (exec
                   ...   ... ("lux io log" (..%%code <call>))
                   ...   (panic! (..%%code <call>)))
                   (panic! (..%%code <call>)))]

                 ... org/renjin/sexp/ListVector
                 [(accept self {_ org/renjin/sexp/SexpVisitor}) void]
                 [(anyNA self) boolean]
                 [(contains self {_ org/renjin/sexp/Vector} {_ int}) boolean]
                 ... [(copyTo self {_ [double]} {_ int} {_ int}) void]
                 [(equals self {_ java/lang/Object}) boolean]
                 
                 [(getComputationDepth self) int]
                 [(getElementAsByte self {_ int}) byte]
                 [(getElementAsComplex self {_ int}) org/apache/commons/math/complex/Complex]
                 [(getElementAsComplexIm self {_ int}) double]
                 [(getElementAsDouble self {_ int}) double]

                 [(getElementAsDouble self {_ java/lang/String}) double]
                 [(getElementAsInt self {_ int}) int]
                 [(getElementAsInt self {_ java/lang/String}) int]
                 [(getElementAsList self {_ java/lang/String}) org/renjin/sexp/ListVector]
                 [(getElementAsLogical self {_ int}) org/renjin/sexp/Logical]
                 [(getElementAsObject self {_ int}) java/lang/Object]
                 [(getElementAsRawLogical self {_ int}) int]
                 [(getElementAsSEXP self {_ int}) org/renjin/sexp/SEXP]
                 [(getElementAsSEXP self {_ java/lang/String}) org/renjin/sexp/SEXP]
                 [(getElementAsString self {_ int}) java/lang/String]
                 [(getElementAsString self {_ java/lang/String}) java/lang/String]
                 [(getElementAsVector self {_ java/lang/String}) org/renjin/sexp/Vector]
                 
                 [(getTypeName self) java/lang/String]
                 [(getVectorType self) org/renjin/sexp/Vector$Type]
                 [(indexOf self {_ org/renjin/sexp/Vector} {_ int} {_ int}) int]
                 [(indexOfName self {_ java/lang/String}) int]
                 [(isConstantAccessTime self) boolean]
                 [(isDeferred self) boolean]
                 [(isElementNA self {_ int}) boolean]
                 [(isElementNaN self {_ int}) boolean]
                 [(isElementTrue self {_ int}) boolean]
                 [(iterator self) (java/util/Iterator org/renjin/sexp/SEXP)]
                 [(length self) int]
                 [(maxElementLength self) int]
                 [(minElementLength self) int]
                 [(namedValues self) (java/lang/Iterable org/renjin/sexp/NamedValue)]
                 [(newBuilderWithInitialCapacity self {_ int}) org/renjin/sexp/ListVector$Builder]
                 [(newBuilderWithInitialSize self {_ int}) org/renjin/sexp/Vector$Builder]
                 [(newCopyBuilder self) org/renjin/sexp/ListVector$Builder]
                 [(newCopyBuilder self {_ org/renjin/sexp/Vector$Type}) org/renjin/sexp/Vector$Builder]
                 [(newCopyNamedBuilder self) org/renjin/sexp/ListVector$NamedBuilder]
                 [(promise self {_ org/renjin/sexp/Environment}) org/renjin/sexp/SEXP]
                 [(repromise self) org/renjin/sexp/SEXP]
                 [(repromise self {_ org/renjin/sexp/SEXP}) org/renjin/sexp/SEXP]
                 [(toArrayUnsafe self) [org/renjin/sexp/SEXP]]
                 [(toString self) java/lang/String]

                 ... org/renjin/sexp/AbstractSEXP
                 ... org/renjin/sexp/SEXP
                 ... [(accept self {_ org/renjin/sexp/SexpVisitor}) void]
                 ... [(asInt self) int]
                 ... [(asLogical self) org/renjin/sexp/Logical]
                 ... [(asReal self) double]
                 ... [(asString self) java/lang/String]
                 ... [(force self {_ org/renjin/eval/Context}) org/renjin/sexp/SEXP]
                 ... [(getAttribute self {_ org/renjin/sexp/Symbol}) org/renjin/sexp/SEXP]
                 ... [(getElementAsSEXP self {_ int}) org/renjin/sexp/SEXP]
                 ... [(getImplicitClass self) java/lang/String]
                 ... ... [(getIndexByName self {_ java/lang/String}) int]
                 ... [(getName self {_ int}) java/lang/String]
                 ... [(getNames self) org/renjin/sexp/AtomicVector]
                 ... [(getS3Class self) org/renjin/sexp/StringVector]
                 ... ... [(hasAttributes self) boolean]
                 ... [(hasNames self) boolean]
                 ... [(inherits self {_ java/lang/String}) boolean]
                 ... [(isNumeric self) boolean]
                 ... ... [(isObject self) boolean]
                 ... [(length self) int]
                 ... ... [(setAttribute self {_ java/lang/String} {_ org/renjin/sexp/SEXP}) org/renjin/sexp/SEXP]
                 ... [(setAttribute self {_ org/renjin/sexp/Symbol} {_ org/renjin/sexp/SEXP}) org/renjin/sexp/SEXP]
                 ... [(setAttributes self {_ org/renjin/sexp/AttributeMap$Builder}) org/renjin/sexp/SEXP]
                 ... [(setAttributes self {_ org/renjin/sexp/AttributeMap}) org/renjin/sexp/SEXP]
                 ))
           )))))

(type: (Reader a)
  (-> a (Try Any)))

(def: (read_variant read host_object)
  (-> (Reader java/lang/Object) (Reader org/renjin/sexp/ListVector))
  (do try.monad
    [tag (|> host_object
             (org/renjin/sexp/ListVector::get_field runtime.variant_tag_field)
             (:as java/lang/Object)
             read)
     value (|> host_object
               (org/renjin/sexp/ListVector::get_field runtime.variant_value_field)
               (:as java/lang/Object)
               read)]
    (wrap [(|> tag (:as java/lang/Long) java/lang/Long::intValue)
           (case (|> host_object
                     (org/renjin/sexp/ListVector::get_field runtime.variant_flag_field)
                     (ffi.check org/renjin/sexp/Null))
             (#.Some _)
             (: Any (ffi.null))

             _
             (: Any synthesis.unit))
           value])))

(def: (read_i64 host_object)
  (Reader org/renjin/sexp/ListVector)
  (case [(|> host_object
             (org/renjin/sexp/ListVector::get_field runtime.i64_high_field)
             (ffi.check org/renjin/sexp/IntArrayVector))
         (|> host_object
             (org/renjin/sexp/ListVector::get_field runtime.i64_low_field)
             (ffi.check org/renjin/sexp/IntArrayVector))]
    [(#.Some high) (#.Some low)]
    (#try.Success (runtime.lux_i64 (org/renjin/sexp/SEXP::asInt high)
                                   (org/renjin/sexp/SEXP::asInt low)))

    _
    (#try.Failure "")))

(def: (read_tuple read host_object)
  (-> (Reader java/lang/Object) (Reader org/renjin/sexp/ListVector))
  (let [size (.nat (org/renjin/sexp/ListVector::length host_object))]
    (loop [idx 0
           output (:as (Array Any) (array.new size))]
      (if (n.< size idx)
        (case (|> host_object (org/renjin/sexp/ListVector::get_index (.int idx)) (:as java/lang/Object) read)
          (#try.Failure error)
          (#try.Failure error)

          (#try.Success member)
          (recur (++ idx) (array.write! idx (:as Any member) output)))
        (#try.Success output)))))

(def: (field_class field host_object)
  (-> Text org/renjin/sexp/ListVector Text)
  (|> host_object
      (org/renjin/sexp/ListVector::get_field field)
      java/lang/Object::getClass
      java/lang/Object::toString
      (:as Text)))

(def: (read host_object)
  (Reader java/lang/Object)
  (exec
    ... ("lux io log" (exception.construct ..unknown_kind_of_object [host_object]))
    (`` (<| (case (ffi.check org/renjin/sexp/ListVector host_object)
              (#.Some host_object)
              (<| (case (..read_variant read host_object)
                    (#try.Success output)
                    (#try.Success output)

                    (#try.Failure _))
                  (case (..read_i64 host_object)
                    (#try.Success output)
                    (#try.Success output)

                    (#try.Failure _))
                  (..read_tuple read host_object))

              #.None)
            (~~ (template [<class> <post_processing>]
                  [(case (ffi.check <class> host_object)
                     (#.Some host_object)
                     (`` (|> host_object (~~ (template.splice <post_processing>))))

                     #.None)]

                  [org/renjin/sexp/StringArrayVector [org/renjin/sexp/StringVector::asString #try.Success]]
                  [org/renjin/sexp/IntArrayVector [org/renjin/sexp/SEXP::asInt #try.Success]]
                  [org/renjin/sexp/LogicalArrayVector [org/renjin/sexp/LogicalVector::asLogical
                                                       org/renjin/sexp/Logical::toBooleanStrict
                                                       #try.Success]]
                  [org/renjin/sexp/Closure [#try.Success]]
                  ... [org/armedbear/lisp/DoubleFloat [org/armedbear/lisp/DoubleFloat::doubleValue #try.Success]]
                  ... [program/LuxADT [program/LuxADT::getValue #try.Success]]
                  ))
            ... else
            (exception.throw ..unknown_kind_of_object [host_object])
            ))))

(def: ensure_macro
  (-> Macro (Maybe org/renjin/sexp/Closure))
  (|>> (:as java/lang/Object) (ffi.check org/renjin/sexp/Closure)))

(def: (call_macro interpreter inputs lux macro)
  (-> org/renjin/script/RenjinScriptEngine (List Code) Lux org/renjin/sexp/Closure (Try (Try [Lux (List Code)])))
  (let [_ ("lux io log" "@call_macro 0")
        r_inputs (: org/renjin/sexp/PairList
                    (case (ffi.try (|> (org/renjin/sexp/PairList$Builder::new)
                                       (org/renjin/sexp/PairList$Builder::add (..host_value inputs))
                                       (org/renjin/sexp/PairList$Builder::add (..host_value lux))
                                       org/renjin/sexp/PairList$Builder::build
                                       (:as org/renjin/sexp/PairList)))
                      (#try.Success r_inputs)
                      r_inputs
                      
                      (#try.Failure error)
                      (exec
                        ("lux io log" error)
                        (panic! error))))
        _ ("lux io log" "@call_macro 1")
        r_macro (org/renjin/sexp/FunctionCall::new macro r_inputs)
        _ ("lux io log" "@call_macro 2")
        r_environment (org/renjin/sexp/Closure::getEnclosingEnvironment macro)
        _ ("lux io log" "@call_macro 3")
        r_context (org/renjin/script/RenjinScriptEngine::getRuntimeContext interpreter)
        _ ("lux io log" "@call_macro 4")]
    (do try.monad
      [raw_output (org/renjin/sexp/FunctionCall::eval r_context r_environment r_macro)
       #let [_ ("lux io log" "@call_macro 5")]]
      (:as (Try (Try [Lux (List Code)]))
           (..read (:as java/lang/Object raw_output))))))

(def: (expander interpreter macro inputs lux)
  (-> org/renjin/script/RenjinScriptEngine Expander)
  (case (ensure_macro macro)
    (#.Some macro)
    (call_macro interpreter inputs lux macro)

    #.None
    (exception.throw ..cannot_apply_a_non_function [(:as java/lang/Object macro)])))

(def: host
  (IO [org/renjin/script/RenjinScriptEngine
       (Host _.Expression _.Expression)])
  (io (let [interpreter (|> (org/renjin/script/RenjinScriptEngineFactory::new)
                            org/renjin/script/RenjinScriptEngineFactory::getScriptEngine)
            run! (: (-> (_.Code Any) (Try Any))
                    (function (_ code)
                      (do try.monad
                        [host_value (javax/script/ScriptEngine::eval (_.code code) interpreter)]
                        (read host_value))))]
        [(:as org/renjin/script/RenjinScriptEngine interpreter)
         (: (Host _.Expression _.Expression)
            (structure
             (def: (evaluate! context code)
               (exec ("lux io log" "@evaluate!")
                 (run! code)))
             
             (def: (execute! input)
               (exec
                 ("lux io log" "@execute!")
                 ... ("lux io log" (_.code input))
                 (javax/script/ScriptEngine::eval (_.code input) interpreter)))
             
             (def: (define! context input)
               (let [global (reference.artifact context)
                     $global (_.var global)]
                 (do try.monad
                   [#let [definition (_.set! $global input)]
                    #let [_ ("lux io log" "@define! 0")
                          ... _ ("lux io log" (_.code definition))
                          ]
                    _ (javax/script/ScriptEngine::eval (_.code definition) interpreter)
                    #let [_ ("lux io log" "@define! 1")]
                    value (run! $global)
                    #let [_ ("lux io log" "@define! 2")]]
                   (wrap [global value definition]))))

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

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

(def: platform
  (IO [org/renjin/script/RenjinScriptEngine
       (Platform _.SVar _.Expression _.Expression)])
  (do io.monad
    [[interpreter host] ..host]
    (wrap [interpreter
           [#platform.&file_system (file.async file.default)
            #platform.host host
            #platform.phase r.generate
            #platform.runtime runtime.generate
            #platform.write (|>> _.code (\ utf8.codec encoded))]])))

(def: (program context program)
  (Program _.Expression _.Expression)
  (_.apply/2 program [(runtime.lux::program_args (_.commandArgs/0 [])) _.null]))

(for {@.old
      (def: extender
        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)
            (exec
              ("lux io log" "TODO: Extender")
              (#try.Failure "TODO: Extender"))))

      @.r
      (def: (extender handler)
        Extender
        (:expected handler))})

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

(def: (scope body)
  (-> _.Expression _.Expression)
  (let [$program (_.var "lux_program")]
    ($_ _.then
        (_.set! $program (_.function (list) body))
        (_.apply/0 $program [])
        )))

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