From 26c22f6a8dccb41c41ff9f64ac1b7b2d5340baef Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 Jun 2021 00:51:05 -0400 Subject: Updates for R compiler. --- lux-r/source/program.lux | 501 ++++++++++++++++++++++++++++++++--------------- 1 file changed, 344 insertions(+), 157 deletions(-) (limited to 'lux-r/source/program.lux') diff --git a/lux-r/source/program.lux b/lux-r/source/program.lux index e2cf047e9..183797d4f 100644 --- a/lux-r/source/program.lux +++ b/lux-r/source/program.lux @@ -1,180 +1,367 @@ (.module: - [lux (#- Definition) - ["@" target] - ["." host (#+ import:)] + [lux #* + [program (#+ program:)] + ["." ffi] + ["." debug] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control - ["." io (#+ IO)] + [pipe (#+ exec> case> new>)] ["." try (#+ Try)] - [parser - [cli (#+ program:)]] + ["." exception (#+ exception:)] + ["." io (#+ IO io)] [concurrency ["." promise (#+ Promise)]]] [data - ["." product] - [text - ["%" format (#+ format)]] + ["." maybe] + ["." text ("#\." hash) + ["%" format (#+ format)] + [encoding + ["." utf8]]] [collection - [array (#+ Array)] - ["." dictionary]]] - [world - ["." file]] - [target - [jvm - [bytecode (#+ Bytecode)]]] + ["." array (#+ Array)]]] + [macro + ["." template]] + [math + [number (#+ hex) + ["n" nat] + ["." i64]]] + ["." world #_ + ["." file] + ["#/." program]] + ["@" target + ["_" r]] [tool [compiler - [default - ["." platform (#+ Platform)]] + [phase (#+ Operation Phase)] + [reference + [variable (#+ Register)]] [language [lux + [program (#+ Program)] + [generation (#+ Context Host)] + ["." synthesis] [analysis - ["." macro (#+ Expander)]] + [macro (#+ Expander)]] [phase - [extension (#+ Phase Bundle Operation Handler Extender) + ["." extension (#+ Extender Handler) + ["#/." bundle] ["." analysis #_ - ["#" jvm]] + ["#" r]] ["." generation #_ - ["#" jvm]] - ## ["." directive #_ - ## ["#" jvm]] - ] + ["#" r]]] [generation - ["." jvm #_ - ## ["." runtime (#+ Anchor Definition)] - ["." packager] - ## ["#/." host] - ]]]]]]]] + ["." reference] + ["." r + ["." runtime]]]]]] + [default + ["." platform (#+ Platform)]] + [meta + ["." packager #_ + ["#" script]]]]]] [program ["/" compositor - ["/." cli] - ["/." static]]] - [luxc - [lang - [host - ["_" jvm]] - ["." directive #_ - ["#" jvm]] - [translation - ["." jvm - ["." runtime] - ["." expression] - ["#/." program] - ["translation" extension]]]]]) - -(import: #long java/lang/reflect/Method - (invoke [java/lang/Object [java/lang/Object]] #try java/lang/Object)) - -(import: #long (java/lang/Class c) - (getMethod [java/lang/String [(java/lang/Class java/lang/Object)]] #try java/lang/reflect/Method)) - -(import: #long java/lang/Object - (getClass [] (java/lang/Class java/lang/Object))) - -(def: _object-class - (java/lang/Class java/lang/Object) - (host.class-for java/lang/Object)) - -(def: _apply2-args - (Array (java/lang/Class java/lang/Object)) - (|> (host.array (java/lang/Class java/lang/Object) 2) - (host.array-write 0 _object-class) - (host.array-write 1 _object-class))) - -(def: _apply4-args - (Array (java/lang/Class java/lang/Object)) - (|> (host.array (java/lang/Class java/lang/Object) 4) - (host.array-write 0 _object-class) - (host.array-write 1 _object-class) - (host.array-write 2 _object-class) - (host.array-write 3 _object-class))) - -(def: #export (expander macro inputs lux) + ["#." 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: javax/script/ScriptEngine + ["#::." + (eval [java/lang/String] #try java/lang/Object)]) + +(ffi.import: org/renjin/script/RenjinScriptEngine) + +(ffi.import: org/renjin/script/RenjinScriptEngineFactory + ["#::." + (new []) + (getScriptEngine [] org/renjin/script/RenjinScriptEngine)]) + +(template [] + [(exception: ( {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)))) + +## (def: (host_value value) +## (-> Any org/armedbear/lisp/LispObject) +## (let [to_sub (: (-> Any org/armedbear/lisp/LispObject) +## (function (_ sub_value) +## (let [sub_value (:coerce java/lang/Object sub_value)] +## (`` (<| (~~ (template [ ] +## [(case (ffi.check sub_value) +## (#.Some sub_value) +## (`` (|> sub_value (~~ (template.splice )))) +## #.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 +## (:coerce org/armedbear/lisp/LispObject sub_value))))))] +## (`` (ffi.object [] org/armedbear/lisp/LispObject [program/LuxADT] +## [] +## ## Methods +## (program/LuxADT +## [] (getValue self) java/lang/Object +## (:coerce java/lang/Object value)) + +## (org/armedbear/lisp/LispObject +## [] (length self) +## int +## (|> value +## (:coerce (Array java/lang/Object)) +## array.size +## (:coerce java/lang/Long) +## java/lang/Number::intValue)) + +## (~~ (template [] +## [(org/armedbear/lisp/LispObject +## [] ( self {idx int}) +## org/armedbear/lisp/LispObject +## (case (array.read (|> idx java/lang/Integer::longValue (:coerce Nat)) +## (:coerce (Array java/lang/Object) value)) +## (#.Some sub) +## (to_sub sub) + +## #.None +## (org/armedbear/lisp/Nil::NIL)))] + +## [NTH] [SVREF] [elt] +## )) +## )))) + +(type: (Reader a) + (-> a (Try Any))) + +## (def: (read_variant read host_object) +## (-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/Cons)) +## (do try.monad +## [tag (read (org/armedbear/lisp/LispObject::NTH +0 host_object)) +## value (read (org/armedbear/lisp/LispObject::NTH +2 host_object))] +## (wrap [(java/lang/Long::intValue (:coerce java/lang/Long tag)) +## (case (ffi.check org/armedbear/lisp/Nil (org/armedbear/lisp/LispObject::NTH +1 host_object)) +## (#.Some _) +## (: Any (ffi.null)) + +## _ +## (: Any synthesis.unit)) +## value]))) + +## (def: (read_tuple read host_object) +## (-> (Reader org/armedbear/lisp/LispObject) (Reader org/armedbear/lisp/SimpleVector)) +## (let [size (.nat (org/armedbear/lisp/LispObject::length host_object))] +## (loop [idx 0 +## output (:coerce (Array Any) (array.new size))] +## (if (n.< size idx) +## ## TODO: Start using "SVREF" instead of "elt" ASAP +## (case (read (org/armedbear/lisp/LispObject::elt (.int idx) host_object)) +## (#try.Failure error) +## (#try.Failure error) + +## (#try.Success member) +## (recur (inc idx) (array.write! idx (:coerce Any member) output))) +## (#try.Success output))))) + +(def: (read host_object) + (Reader java/lang/Object) + (`` (<| ## (~~ (template [ ] + ## [(case (ffi.check host_object) + ## (#.Some host_object) + ## (`` (|> host_object (~~ (template.splice )))) + + ## #.None)] + + ## [org/armedbear/lisp/Bignum [org/armedbear/lisp/Bignum::longValue #try.Success]] + ## [org/armedbear/lisp/Fixnum [org/armedbear/lisp/Fixnum::longValue #try.Success]] + ## [org/armedbear/lisp/DoubleFloat [org/armedbear/lisp/DoubleFloat::doubleValue #try.Success]] + ## [org/armedbear/lisp/SimpleString [org/armedbear/lisp/SimpleString::getStringValue #try.Success]] + ## [org/armedbear/lisp/Cons [(read_variant read)]] + ## [org/armedbear/lisp/SimpleVector [(read_tuple read)]] + ## [org/armedbear/lisp/Nil [(new> (#try.Success false) [])]] + ## [org/armedbear/lisp/Closure [#try.Success]] + ## [program/LuxADT [program/LuxADT::getValue #try.Success]])) + ## (case (ffi.check org/armedbear/lisp/Symbol host_object) + ## (#.Some host_object) + ## (if (is? (org/armedbear/lisp/Symbol::T) host_object) + ## (#try.Success true) + ## (exception.throw ..unknown_kind_of_object [host_object])) + + ## #.None) + ## else + (exception.throw ..unknown_kind_of_object [host_object]) + ))) + +## (def: ensure_macro +## (-> Macro (Maybe org/armedbear/lisp/Closure)) +## (|>> (:coerce java/lang/Object) (ffi.check org/armedbear/lisp/Closure))) + +## (def: (call_macro inputs lux macro) +## (-> (List Code) Lux org/armedbear/lisp/Closure (Try (Try [Lux (List Code)]))) +## (do try.monad +## [raw_output (org/armedbear/lisp/LispObject::execute (..host_value inputs) (..host_value lux) macro)] +## (:coerce (Try (Try [Lux (List Code)])) +## (..read raw_output)))) + +(def: (expander macro inputs lux) Expander - (do try.monad - [apply-method (|> macro - (:coerce java/lang/Object) - (java/lang/Object::getClass) - (java/lang/Class::getMethod "apply" _apply2-args))] - (:coerce (Try (Try [Lux (List Code)])) - (java/lang/reflect/Method::invoke - (:coerce java/lang/Object macro) - (|> (host.array java/lang/Object 2) - (host.array-write 0 (:coerce java/lang/Object inputs)) - (host.array-write 1 (:coerce java/lang/Object lux))) - apply-method)))) - -(def: #export platform - ## (IO (Platform Anchor (Bytecode Any) Definition)) - (IO (Platform _.Anchor _.Inst _.Definition)) + ## (case (ensure_macro macro) + ## (#.Some macro) + ## (call_macro inputs lux macro) + + ## #.None + ## (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro))) + (exception.throw ..cannot_apply_a_non_function (:coerce java/lang/Object macro))) + +(def: host + (IO (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))))] + (: (Host _.Expression _.Expression) + (structure + (def: (evaluate! context code) + (run! code)) + + (def: (execute! 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)] + _ (javax/script/ScriptEngine::eval (_.code definition) interpreter) + value (run! $global)] + (wrap [global value definition])))) + + (def: (ingest context content) + (|> content (\ utf8.codec decode) try.assume (:coerce _.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 (Platform _.SVar _.Expression _.Expression)) (do io.monad - [## host jvm/host.host - host jvm.host] - (wrap {#platform.&file-system (file.async file.system) + [host ..host] + (wrap {#platform.&file_system (file.async file.default) #platform.host host - ## #platform.phase jvm.generate - #platform.phase expression.translate - ## #platform.runtime runtime.generate - #platform.runtime runtime.translate - #platform.write product.right}))) - -(def: extender - Extender - ## TODO: Stop relying on coercions ASAP. - (<| (:coerce Extender) - (function (@self handler)) - (:coerce Handler) - (function (@self name phase)) - (:coerce Phase) - (function (@self parameters)) - (:coerce Operation) - (function (@self state)) - (:coerce Try) - try.assume - (:coerce Try) - (do try.monad - [method (|> handler - (:coerce java/lang/Object) - (java/lang/Object::getClass) - (java/lang/Class::getMethod "apply" _apply4-args))] - (java/lang/reflect/Method::invoke - (:coerce java/lang/Object handler) - (|> (host.array java/lang/Object 4) - (host.array-write 0 (:coerce java/lang/Object name)) - (host.array-write 1 (:coerce java/lang/Object phase)) - (host.array-write 2 (:coerce java/lang/Object parameters)) - (host.array-write 3 (:coerce java/lang/Object state))) - method)))) - -(def: (target service) - (-> /cli.Service /cli.Target) - (case service - (^or (#/cli.Compilation [sources libraries target module]) - (#/cli.Interpretation [sources libraries target module]) - (#/cli.Export [sources target])) - target)) - -(def: (declare-success! _) + #platform.phase r.generate + #platform.runtime runtime.generate + #platform.write (|>> _.code (\ utf8.codec encode))}))) + +(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. + (<| (: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) + (exec + ("lux io log" "TODO: Extender") + (#try.Failure "TODO: Extender")))) + + @.r + (def: (extender handler) + Extender + (:assume handler))}) + +(def: (declare_success! _) (-> Any (Promise Any)) - (promise.future (io.exit +0))) - -(program: [{service /cli.service}] - (let [jar-path (format (..target service) (:: file.system separator) "program.jar")] - (exec (do promise.monad - [_ (/.compiler {#/static.host @.jvm - #/static.host-module-extension ".jvm" - #/static.target (..target service) - #/static.artifact-extension ".class"} - ..expander - analysis.bundle - ..platform - ## generation.bundle - translation.bundle - (directive.bundle ..extender) - jvm/program.program - ..extender - service - [(packager.package jvm/program.class) jar-path])] - (..declare-success! [])) - (io.io [])))) + (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 + [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 + 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 [])))))) -- cgit v1.2.3