diff options
Diffstat (limited to 'lux-scheme/source')
| -rw-r--r-- | lux-scheme/source/program.lux | 428 |
1 files changed, 268 insertions, 160 deletions
diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux index 8eb29a3aa..da9317961 100644 --- a/lux-scheme/source/program.lux +++ b/lux-scheme/source/program.lux @@ -1,88 +1,122 @@ (.module: [lux #* + [program (#+ program:)] + ["." host] ["." debug] - ["." host (#+ import: interface: do-to object)] [abstract - [monad (#+ do)]] + ["." monad (#+ do)]] [control + [pipe (#+ exec> case>)] + ["." try (#+ Try)] ["." exception (#+ exception:)] ["." io (#+ IO io)] - [parser - [cli (#+ program:)]]] + [concurrency + ["." promise (#+ Promise)]]] [data ["." maybe] - ["." error (#+ Error)] - [number - ["." i64]] - ["." text ("#@." hash) - format] + ["." text ("#\." hash) + ["%" format (#+ format)] + ["." encoding]] [collection ["." array (#+ Array)]]] [macro ["." template]] - [world - ["." file]] - [target + [math + [number (#+ hex) + ["n" nat] + ["." i64]]] + ["." world #_ + ["." file] + ["#/." program]] + ["@" target ["_" scheme]] [tool [compiler - ["." name] - ["." synthesis] - [phase - [macro (#+ Expander)] - ["." generation - ["." scheme - ["." runtime] - ["." extension]]]] + [phase (#+ Operation Phase)] + [reference + [variable (#+ Register)]] + [language + [lux + [program (#+ Program)] + [generation (#+ Context Host)] + ["." synthesis] + [analysis + [macro (#+ Expander)]] + [phase + ["." extension (#+ Extender Handler) + ["#/." bundle] + ["." analysis #_ + ["#" scheme]] + ["." generation #_ + ["#" scheme]]] + [generation + ["." reference] + ["." scheme + ["." runtime]]]]]] [default - ["." platform (#+ Platform)]]]]] + ["." platform (#+ Platform)]] + [meta + ["." packager #_ + ["#" script]]]]]] [program ["/" compositor - ["/." cli]]]) + ["#." cli] + ["#." static]]]) -(import: #long java/lang/Boolean) -(import: #long java/lang/String) +(host.import: java/lang/Boolean) +(host.import: java/lang/String) -(import: #long (java/lang/Class a)) +(host.import: (java/lang/Class a)) -(import: #long java/lang/Object - (toString [] java/lang/String) - (getClass [] (java/lang/Class java/lang/Object))) +(host.import: java/lang/Object + ["#::." + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))]) -(import: #long java/lang/Long - (intValue [] java/lang/Integer)) +(host.import: java/lang/Long + ["#::." + (intValue [] java/lang/Integer)]) -(import: #long java/lang/Integer - (longValue [] java/lang/Long)) +(host.import: java/lang/Integer + ["#::." + (longValue [] java/lang/Long)]) -(import: #long gnu/math/IntNum - (new #manual [int]) - (longValue [] long)) +(host.import: gnu/math/IntNum + ["#::." + (new #manual [int]) + (longValue [] long)]) -(import: #long gnu/math/DFloNum - (doubleValue [] double)) +(host.import: gnu/math/DFloNum + ["#::." + (doubleValue [] double)]) -(import: #long gnu/lists/FString - (toString [] String)) +(host.import: gnu/lists/FString + ["#::." + (toString [] String)]) -(import: #long gnu/lists/Pair - (getCar [] java/lang/Object) - (getCdr [] java/lang/Object)) +(host.import: gnu/lists/Pair + ["#::." + (getCar [] java/lang/Object) + (getCdr [] java/lang/Object)]) -(import: #long (gnu/lists/FVector E) - (getBufferLength [] int) - (getRaw [int] E)) +(host.import: (gnu/lists/FVector E) + ["#::." + (getBufferLength [] int) + (getRaw [int] E)]) -(import: #long gnu/expr/ModuleMethod - (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object)) +(host.import: gnu/mapping/Procedure + ["#::." + (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object)]) -(import: #long gnu/mapping/Environment) +(host.import: gnu/mapping/Environment) -(import: #long gnu/expr/Language - (eval [java/lang/String] #try java/lang/Object)) +(host.import: gnu/expr/Language + ["#::." + (eval [java/lang/String] #try java/lang/Object)]) -(import: #long kawa/standard/Scheme - (#static getR7rsInstance [] kawa/standard/Scheme)) +(host.import: kawa/standard/Scheme + ["#::." + (#static getR7rsInstance [] kawa/standard/Scheme)]) (def: (variant? value) (-> Any Bit) @@ -90,7 +124,7 @@ (#.Some array) ## TODO: Get rid of this coercion ASAP. (let [array (:coerce (Array java/lang/Object) array)] - (and (n/= 3 (array.size array)) + (and (n.= 3 (array.size array)) (case (array.read 0 array) (#.Some tag) (case (host.check java/lang/Integer tag) @@ -107,29 +141,30 @@ false)) (template [<name>] - [(interface: <name> + [(host.interface: <name> (getValue [] java/lang/Object)) - (`` (import: #long (~~ (template.identifier ["program/" <name>])) - (getValue [] java/lang/Object)))] + (`` (host.import: (~~ (template.identifier ["program/" <name>])) + ["#::." + (getValue [] java/lang/Object)]))] [VariantValue] [TupleValue] ) -(def: (variant-value lux-value cdr? value) +(def: (variant_value lux_value cdr? value) (-> (-> java/lang/Object java/lang/Object) Bit (Array java/lang/Object) gnu/lists/Pair) - (object [] gnu/lists/Pair [program/VariantValue] + (host.object [] gnu/lists/Pair [program/VariantValue] [] ## Methods (program/VariantValue - (getValue self) java/lang/Object + [] (getValue self) java/lang/Object (:coerce java/lang/Object value)) (gnu/lists/Pair - (getCar self) java/lang/Object + [] (getCar self) java/lang/Object (if cdr? (case (array.read 1 value) - (#.Some flag-is-set) + (#.Some flag_is_set) (:coerce java/lang/Object "") #.None @@ -140,71 +175,71 @@ (:coerce java/lang/Integer) gnu/math/IntNum::new))) (gnu/lists/Pair - (getCdr self) java/lang/Object + [] (getCdr self) java/lang/Object (if cdr? (|> value (array.read 2) maybe.assume - lux-value) - (variant-value lux-value true value))))) + lux_value) + (variant_value lux_value true value))))) -(def: (tuple-value lux-value value) +(def: (tuple_value lux_value value) (-> (-> java/lang/Object java/lang/Object) (Array java/lang/Object) gnu/lists/FVector) - (object [] gnu/lists/SimpleVector [program/TupleValue] + (host.object [] gnu/lists/SimpleVector [program/TupleValue] [] ## Methods (program/TupleValue - (getValue self) java/lang/Object + [] (getValue self) java/lang/Object (:coerce java/lang/Object value)) (gnu/lists/SimpleVector - (getBufferLength self) int - (host.long-to-int (array.size value))) + [] (getBufferLength self) int + (host.long_to_int (array.size value))) (gnu/lists/SimpleVector - (getRaw self {idx int}) java/lang/Object + [] (getRaw self {idx int}) java/lang/Object (|> value (array.read (|> idx java/lang/Integer::longValue (:coerce Nat))) maybe.assume - lux-value)) + lux_value)) (gnu/lists/SimpleVector - (getBuffer self) java/lang/Object - (error! "tuple-value getBuffer")) + [] (getBuffer self) java/lang/Object + (undefined)) (gnu/lists/SimpleVector - (setBuffer self {_ java/lang/Object}) void - (error! "tuple-value setBuffer")) + [] (setBuffer self {_ java/lang/Object}) void + (undefined)) (gnu/lists/SimpleVector - (clearBuffer self {_ int} {_ int}) void - (error! "tuple-value clearBuffer")) + [] (clearBuffer self {_ int} {_ int}) void + (undefined)) (gnu/lists/SimpleVector - (copyBuffer self {_ int}) void - (error! "tuple-value copyBuffer")) + [] (copyBuffer self {_ int}) void + (undefined)) (gnu/lists/SimpleVector - (newInstance self {_ int}) gnu/lists/SimpleVector - (error! "tuple-value newInstance")) + [] (newInstance self {_ int}) gnu/lists/SimpleVector + (undefined)) )) -(exception: (unknown-kind-of-host-object {object java/lang/Object}) +(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)])) -(exception: (cannot-apply-a-non-function {object java/lang/Object}) +(exception: (cannot_apply_a_non_function {object java/lang/Object}) (exception.report ["Class" (java/lang/Object::toString (java/lang/Object::getClass object))] ["Object" (java/lang/Object::toString object)])) -(def: (lux-value value) +(def: (lux_value value) (-> java/lang/Object java/lang/Object) (<| (case (host.check [java/lang/Object] value) (#.Some value) ## TODO: Get rid of the coercions below. (if (variant? value) - (variant-value lux-value false (:coerce (Array java/lang/Object) value)) - (tuple-value lux-value (:coerce (Array java/lang/Object) value))) + (variant_value lux_value false (:coerce (Array java/lang/Object) value)) + (tuple_value lux_value (:coerce (Array java/lang/Object) value))) #.None) value)) (type: (Reader a) - (-> a (Error Any))) + (-> a (Try Any))) (def: (variant tag flag value) (-> Nat Bit Any Any) @@ -215,49 +250,49 @@ (host.null))) value]) -(def: (read-variant read host-object) +(def: (read_variant read host_object) (-> (Reader java/lang/Object) (Reader gnu/lists/Pair)) - (do error.monad - [tag (read (gnu/lists/Pair::getCar host-object)) - #let [host-object (:coerce gnu/lists/Pair (gnu/lists/Pair::getCdr host-object)) - flag (case (host.check java/lang/String (gnu/lists/Pair::getCar host-object)) + (do try.monad + [tag (read (gnu/lists/Pair::getCar host_object)) + #let [host_object (:coerce gnu/lists/Pair (gnu/lists/Pair::getCdr host_object)) + flag (case (host.check java/lang/String (gnu/lists/Pair::getCar host_object)) (#.Some _) true #.None false)] - value (read (gnu/lists/Pair::getCdr host-object))] + value (read (gnu/lists/Pair::getCdr host_object))] (wrap (..variant (:coerce Nat tag) flag value)))) -(def: (read-tuple read host-object) +(def: (read_tuple read host_object) (-> (Reader java/lang/Object) (Reader (gnu/lists/FVector java/lang/Object))) - (let [size (.nat (gnu/lists/FVector::getBufferLength host-object))] + (let [size (.nat (gnu/lists/FVector::getBufferLength host_object))] (loop [idx 0 output (: (Array Any) (array.new size))] - (if (n/< size idx) - (case (read (gnu/lists/FVector::getRaw (.int idx) host-object)) - (#error.Failure error) - (#error.Failure error) + (if (n.< size idx) + (case (read (gnu/lists/FVector::getRaw (.int idx) host_object)) + (#try.Failure error) + (#try.Failure error) - (#error.Success lux-value) - (recur (inc idx) (array.write idx (: Any lux-value) output))) - (#error.Success output))))) + (#try.Success lux_value) + (recur (inc idx) (array.write! idx (: Any lux_value) output))) + (#try.Success output))))) -(def: (read host-object) +(def: (read host_object) (Reader java/lang/Object) (`` (<| (~~ (template [<class>] - [(case (host.check <class> host-object) - (#.Some host-object) - (#error.Success host-object) + [(case (host.check <class> host_object) + (#.Some host_object) + (#try.Success host_object) #.None)] - [java/lang/Boolean] [java/lang/String] [gnu/expr/ModuleMethod] + [java/lang/Boolean] [java/lang/String] [gnu/mapping/Procedure] )) (~~ (template [<class> <method>] - [(case (host.check <class> host-object) - (#.Some host-object) - (#error.Success (<method> host-object)) + [(case (host.check <class> host_object) + (#.Some host_object) + (#try.Success (<method> host_object)) #.None)] [gnu/math/IntNum gnu/math/IntNum::longValue] @@ -266,90 +301,163 @@ [program/VariantValue program/VariantValue::getValue] [program/TupleValue program/TupleValue::getValue] )) - (case (host.check gnu/lists/Pair host-object) - (#.Some host-object) - (read-variant read host-object) + (case (host.check gnu/lists/Pair host_object) + (#.Some host_object) + (read_variant read host_object) #.None) - (case (host.check gnu/lists/FVector host-object) - (#.Some host-object) - (read-tuple read (:coerce (gnu/lists/FVector java/lang/Object) host-object)) + (case (host.check gnu/lists/FVector host_object) + (#.Some host_object) + (read_tuple read (:coerce (gnu/lists/FVector java/lang/Object) host_object)) #.None) ## else - (exception.throw ..unknown-kind-of-host-object host-object)))) + (exception.throw ..unknown_kind_of_host_object host_object)))) -(def: ensure-macro - (-> Macro (Maybe gnu/expr/ModuleMethod)) - (|>> (:coerce java/lang/Object) (host.check gnu/expr/ModuleMethod))) +(def: ensure_macro + (-> Macro (Maybe gnu/mapping/Procedure)) + (|>> (:coerce java/lang/Object) (host.check gnu/mapping/Procedure))) (def: (expander macro inputs lux) Expander - (case (ensure-macro macro) + (case (ensure_macro macro) (#.Some macro) - (case (gnu/expr/ModuleMethod::apply2 (lux-value (:coerce java/lang/Object inputs)) - (lux-value (:coerce java/lang/Object lux)) + (case (gnu/mapping/Procedure::apply2 (lux_value (:coerce java/lang/Object inputs)) + (lux_value (:coerce java/lang/Object lux)) macro) - (#error.Success output) + (#try.Success output) (|> output ..read - (:coerce (Error (Error [Lux (List Code)])))) + (:coerce (Try (Try [Lux (List Code)])))) - (#error.Failure error) - (#error.Failure error)) + (#try.Failure error) + (#try.Failure error)) #.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: separator "$") -(type: Host - (generation.Host _.Expression _.Expression)) - (def: host - (IO Host) + (IO (Host _.Expression _.Expression)) (io (let [interpreter (kawa/standard/Scheme::getR7rsInstance) - evaluate! (function (evaluate! alias input) - (do error.monad - [output (gnu/expr/Language::eval (_.code input) interpreter)] - (read output)))] - (: Host + run! (: (-> (_.Code Any) (Try Any)) + (function (_ input) + (do try.monad + [output (gnu/expr/Language::eval (_.code input) interpreter)] + (read output))))] + (: (Host _.Expression _.Expression) (structure - (def: evaluate! evaluate!) - (def: (execute! alias input) + (def: (evaluate! context code) + (run! code)) + + (def: (execute! input) (gnu/expr/Language::eval (_.code input) interpreter)) - (def: (define! [module name] input) - (let [global (format (text.replace-all .module-separator ..separator module) - ..separator (name.normalize name) - "___" (%n (text@hash name))) + + (def: (define! context input) + (let [global (reference.artifact context) @global (_.var global)] - (do error.monad - [#let [definition (_.define-constant @global input)] + (do try.monad + [#let [definition (_.define_constant @global input)] _ (gnu/expr/Language::eval (_.code definition) interpreter) - value (evaluate! global @global)] - (wrap [global value definition]))))))))) + value (run! @global)] + (wrap [global value definition])))) + + (def: (ingest context content) + (|> content (\ encoding.utf8 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 IO _.Var _.Expression _.Expression)) + (IO (Platform _.Var _.Expression _.Expression)) (do io.monad [host ..host] - (wrap {#platform.&monad io.monad - #platform.&file-system file.system + (wrap {#platform.&file_system (file.async file.default) #platform.host host #platform.phase scheme.generate - #platform.runtime runtime.generate}))) + #platform.runtime runtime.generate + #platform.write (|>> _.code (\ encoding.utf8 encode))}))) -(def: (program program) - (-> _.Expression _.Expression) +(def: (program context program) + (Program _.Expression _.Expression) (_.apply/2 program ## TODO: Figure out how to always get the command-line ## arguments. ## It appears that it differs between Scheme implementations. - (runtime.lux//program-args _.nil) + (runtime.lux//program_args _.nil) _.nil)) -(program: [{service /cli.service}] - (/.compiler ..expander - ..platform - extension.bundle - ..program - service)) +(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) + (#try.Failure "YOLO"))) + + @.scheme + (def: (extender handler) + Extender + (:assume handler))}) + +(def: (declare_success! _) + (-> Any (Promise Any)) + (promise.future (\ world/program.default exit +0))) + +(def: (then pre post) + (-> _.Expression _.Expression _.Expression) + (_.manual (format (_.code pre) + text.new_line + (_.code post)))) + +(def: (scope body) + (-> _.Expression _.Expression) + (let [@program (_.var "lux_program")] + ($_ ..then + (_.define_function @program [(list) #.None] body) + (_.apply/* (list) @program) + ))) + +(`` (program: [{service /cli.service}] + (let [extension ".scm"] + (do io.monad + [platform ..platform] + (exec (do promise.monad + [_ (/.compiler {#/static.host @.scheme + #/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 + [_.Var _.Expression _.Expression] + ..extender + service + [(packager.package (_.manual "") + _.code + ..then + ..scope) + (format (/cli.target service) + (\ file.default separator) + "program" + extension)])] + (..declare_success! [])) + (io.io [])))))) |