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

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

(ffi.import java/lang/String
  "[1]::[0]")

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

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

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

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

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

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

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

(ffi.import org/renjin/sexp/AbstractSEXP
  "[1]::[0]")

(ffi.import org/renjin/sexp/IntArrayVector
  "[1]::[0]")

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

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

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

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

(ffi.import org/renjin/sexp/StringArrayVector
  "[1]::[0]")

(ffi.import org/renjin/sexp/Null
  "[1]::[0]")

(ffi.import org/renjin/sexp/ListVector
  "[1]::[0]"
  (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
  "[1]::[0]")

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

(ffi.import org/renjin/eval/Context
  "[1]::[0]")

(ffi.import org/renjin/sexp/Environment
  "[1]::[0]")

(ffi.import org/renjin/sexp/FunctionCall
  "[1]::[0]"
  (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
  "[1]::[0]"
  (getEnclosingEnvironment [] org/renjin/sexp/Environment))

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

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

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

(with_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)
...   (|>> (pipe.case #0 (org/armedbear/lisp/Nil::NIL)
...               #1 (org/armedbear/lisp/Symbol::T))))

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

(def: (host_value value)
  (-> Any org/renjin/sexp/SEXP)
  (let [... to_sub (is (-> Any org/armedbear/lisp/LispObject)
        ...           (function (_ sub_value)
        ...             (let [sub_value (as java/lang/Object sub_value)]
        ...               (`` (<| (~~ (with_template [<type> <then>]
        ...                             [(case (ffi.as <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)
            ... (as_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))
           
           (~~ (with_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.as org/renjin/sexp/Null))
             {.#Some _}
             (is Any (ffi.null))

             _
             (is 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.as org/renjin/sexp/IntArrayVector))
         (|> host_object
             (org/renjin/sexp/ListVector::get_field runtime.i64_low_field)
             (ffi.as 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 (again [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}
          (again (++ 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.as 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})
            (~~ (with_template [<class> <post_processing>]
                  [(case (ffi.as <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.as 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 (is 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! (is (-> (_.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)
         (is (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 (at 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 (at 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
       (as_expected handler)))

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

(def: (scope body)
  (-> _.Expression _.Expression)
  (let [$program (_.var "lux_program")]
    (all _.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)
                                          (at file.default separator)
                                          "program"
                                          extension)])]
                  (..declare_success! []))
            (io.io []))))))