aboutsummaryrefslogtreecommitdiff
path: root/lux-scheme/source
diff options
context:
space:
mode:
Diffstat (limited to 'lux-scheme/source')
-rw-r--r--lux-scheme/source/program.lux428
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 []))))))