diff options
27 files changed, 1315 insertions, 554 deletions
diff --git a/lux-scheme/commands.md b/lux-scheme/commands.md index 055e90d8f..7c915200c 100644 --- a/lux-scheme/commands.md +++ b/lux-scheme/commands.md @@ -11,6 +11,7 @@ cd ~/lux/lux-scheme/ && lein clean && lein lux auto test ``` ## Develop +## NOTE: Must set lux/control/concurrency/thread.parallelism = 1 before compiling to make sure Kawa doesn't cause trouble. cd ~/lux/lux-scheme/ \ && lein clean \ && lein lux auto build @@ -19,6 +20,11 @@ cd ~/lux/lux-scheme/ \ ## Try ``` -cd ~/lux/lux-scheme/ && java -jar target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux +## Compile Lux's Standard Library's tests using a JVM-based compiler. +cd ~/lux/stdlib/ \ +&& lein clean \ +&& time java -jar ~/lux/lux-scheme/target/program.jar build --source ~/lux/stdlib/source --target ~/lux/stdlib/target --module test/lux + +clear && time kawa ~/lux/stdlib/target/program.scm ``` diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux index da9317961..e318c6abd 100644 --- a/lux-scheme/source/program.lux +++ b/lux-scheme/source/program.lux @@ -6,7 +6,7 @@ [abstract ["." monad (#+ do)]] [control - [pipe (#+ exec> case>)] + [pipe (#+ exec> case> new>)] ["." try (#+ Try)] ["." exception (#+ exception:)] ["." io (#+ IO io)] @@ -94,19 +94,30 @@ ["#::." (toString [] String)]) +(host.import: gnu/lists/IString + ["#::." + (toString [] String)]) + (host.import: gnu/lists/Pair ["#::." (getCar [] java/lang/Object) (getCdr [] java/lang/Object)]) +(host.import: gnu/lists/EmptyList + ["#::." + (#static emptyList gnu/lists/EmptyList)]) + (host.import: (gnu/lists/FVector E) ["#::." (getBufferLength [] int) (getRaw [int] E)]) +(host.import: gnu/lists/U8Vector) + (host.import: gnu/mapping/Procedure ["#::." - (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object)]) + (apply2 [java/lang/Object java/lang/Object] #try java/lang/Object) + (applyN [[java/lang/Object]] #try java/lang/Object)]) (host.import: gnu/mapping/Environment) @@ -165,10 +176,10 @@ (if cdr? (case (array.read 1 value) (#.Some flag_is_set) - (:coerce java/lang/Object "") + true #.None - (host.null)) + false) (|> value (array.read 0) maybe.assume @@ -185,7 +196,7 @@ (def: (tuple_value lux_value value) (-> (-> java/lang/Object java/lang/Object) (Array java/lang/Object) gnu/lists/FVector) - (host.object [] gnu/lists/SimpleVector [program/TupleValue] + (host.object [] gnu/lists/SimpleVector [program/TupleValue gnu/lists/GVector] [] ## Methods (program/TupleValue @@ -255,12 +266,12 @@ (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 + flag (case (host.check java/lang/Boolean (gnu/lists/Pair::getCar host_object)) + (#.Some flag) + (:coerce Bit flag) #.None - false)] + (undefined))] value (read (gnu/lists/Pair::getCdr host_object))] (wrap (..variant (:coerce Nat tag) flag value)))) @@ -287,17 +298,23 @@ (#try.Success host_object) #.None)] - [java/lang/Boolean] [java/lang/String] [gnu/mapping/Procedure] + [java/lang/Boolean] [java/lang/Long] [java/lang/Double] [java/lang/String] + [gnu/mapping/Procedure] [gnu/lists/U8Vector] )) - (~~ (template [<class> <method>] + (~~ (template [<class> <processing>] [(case (host.check <class> host_object) (#.Some host_object) - (#try.Success (<method> host_object)) + (#try.Success (<| <processing> host_object)) #.None)] + [java/lang/Integer java/lang/Integer::longValue] + + [gnu/lists/EmptyList (new> [] [])] [gnu/math/IntNum gnu/math/IntNum::longValue] [gnu/math/DFloNum gnu/math/DFloNum::doubleValue] [gnu/lists/FString gnu/lists/FString::toString] + [gnu/lists/IString gnu/lists/IString::toString] + [program/VariantValue program/VariantValue::getValue] [program/TupleValue program/TupleValue::getValue] )) @@ -318,7 +335,7 @@ (def: (expander macro inputs lux) Expander - (case (ensure_macro macro) + (case (..ensure_macro macro) (#.Some macro) (case (gnu/mapping/Procedure::apply2 (lux_value (:coerce java/lang/Object inputs)) (lux_value (:coerce java/lang/Object lux)) @@ -408,7 +425,15 @@ (:coerce Try) try.assume (:coerce Try) - (#try.Failure "YOLO"))) + (do try.monad + [handler (try.from_maybe (..ensure_macro (:coerce Macro handler))) + output (gnu/mapping/Procedure::applyN (array.from_list (list (lux_value (:coerce java/lang/Object name)) + (lux_value (:coerce java/lang/Object phase)) + (lux_value (:coerce java/lang/Object archive)) + (lux_value (:coerce java/lang/Object parameters)) + (lux_value (:coerce java/lang/Object state)))) + handler)] + (..read output)))) @.scheme (def: (extender handler) diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux index 8a46413da..f8a95a41a 100644 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ b/stdlib/source/lux/control/concurrency/atom.lux @@ -27,20 +27,23 @@ @.python "python array new" @.lua "lua array new" @.ruby "ruby array new" - @.php "php array new"} + @.php "php array new" + @.scheme "scheme array new"} (as_is)) <write> (for {@.js "js array write" @.python "python array write" @.lua "lua array write" @.ruby "ruby array write" - @.php "php array write"} + @.php "php array write" + @.scheme "scheme array write"} (as_is)) <read> (for {@.js "js array read" @.python "python array read" @.lua "lua array read" @.ruby "ruby array read" - @.php "php array read"} + @.php "php array read" + @.scheme "scheme array read"} (as_is))] (abstract: #export (Atom a) (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference a)] diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux index 52c0062eb..74d5940bc 100644 --- a/stdlib/source/lux/control/thread.lux +++ b/stdlib/source/lux/control/thread.lux @@ -46,7 +46,8 @@ @.python ("python array read" 0 (:representation box)) @.lua ("lua array read" 0 (:representation box)) @.ruby ("ruby array read" 0 (:representation box)) - @.php ("php array read" 0 (:representation box))}))) + @.php ("php array read" 0 (:representation box)) + @.scheme ("scheme array read" 0 (:representation box))}))) (def: #export (write value box) (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any))))) diff --git a/stdlib/source/lux/data/binary.lux b/stdlib/source/lux/data/binary.lux index 1fa94f565..40a7b3fc7 100644 --- a/stdlib/source/lux/data/binary.lux +++ b/stdlib/source/lux/data/binary.lux @@ -81,7 +81,16 @@ @.python (type: #export Binary - (primitive "bytearray"))} + (primitive "bytearray")) + + @.scheme + (as_is (type: #export Binary + (primitive "bytevector")) + + (host.import: (make-bytevector [Nat] Binary)) + (host.import: (bytevector-u8-ref [Binary Nat] I64)) + (host.import: (bytevector-u8-set! [Binary Nat (I64 Any)] Any)) + (host.import: (bytevector-length [Binary] Nat)))} ## Default (type: #export Binary @@ -99,7 +108,10 @@ @.python (|> binary (:coerce (array.Array (I64 Any))) - "python array length")} + "python array length") + + @.scheme + (..bytevector-length [binary])} ## Default (array.size binary))) @@ -119,7 +131,10 @@ @.python (|> binary (:coerce (array.Array .I64)) - ("python array read" idx))} + ("python array read" idx)) + + @.scheme + (..bytevector-u8-ref [binary idx])} ## Default (|> binary @@ -139,7 +154,9 @@ @.jvm (host.array_write idx (..byte value) binary) @.js (!!write .Frac n.frac "js array write" idx value binary) - @.python (!!write (I64 Any) (:coerce (I64 Any)) "python array write" idx value binary)} + @.python (!!write (I64 Any) (:coerce (I64 Any)) "python array write" idx value binary) + @.scheme (exec (..bytevector-u8-set! [binary idx value]) + binary)} ## Default (array.write! idx (|> value .nat (n.% (hex "100"))) binary))) @@ -158,7 +175,10 @@ @.python (|>> ("python apply" (:coerce host.Function ("python constant" "bytearray"))) - (:coerce Binary))} + (:coerce Binary)) + + @.scheme + (|>> ..make-bytevector)} ## Default array.new)) @@ -238,15 +258,24 @@ (def: #export (write/64 idx value binary) (-> Nat (I64 Any) Binary (Try Binary)) (if (n.< (..!size binary) (n.+ 7 idx)) - (#try.Success (|> binary - (!write idx (i64.right_shift 56 value)) - (!write (n.+ 1 idx) (i64.right_shift 48 value)) - (!write (n.+ 2 idx) (i64.right_shift 40 value)) - (!write (n.+ 3 idx) (i64.right_shift 32 value)) - (!write (n.+ 4 idx) (i64.right_shift 24 value)) - (!write (n.+ 5 idx) (i64.right_shift 16 value)) - (!write (n.+ 6 idx) (i64.right_shift 8 value)) - (!write (n.+ 7 idx) value))) + (for {@.scheme (let [write_high (|>> (!write idx (i64.right_shift 56 value)) + (!write (n.+ 1 idx) (i64.right_shift 48 value)) + (!write (n.+ 2 idx) (i64.right_shift 40 value)) + (!write (n.+ 3 idx) (i64.right_shift 32 value))) + write_low (|>> (!write (n.+ 4 idx) (i64.right_shift 24 value)) + (!write (n.+ 5 idx) (i64.right_shift 16 value)) + (!write (n.+ 6 idx) (i64.right_shift 8 value)) + (!write (n.+ 7 idx) value))] + (|> binary write_high write_low #try.Success))} + (#try.Success (|> binary + (!write idx (i64.right_shift 56 value)) + (!write (n.+ 1 idx) (i64.right_shift 48 value)) + (!write (n.+ 2 idx) (i64.right_shift 40 value)) + (!write (n.+ 3 idx) (i64.right_shift 32 value)) + (!write (n.+ 4 idx) (i64.right_shift 24 value)) + (!write (n.+ 5 idx) (i64.right_shift 16 value)) + (!write (n.+ 6 idx) (i64.right_shift 8 value)) + (!write (n.+ 7 idx) value)))) (exception.throw ..index_out_of_bounds [(..!size binary) idx]))) (structure: #export equivalence diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index 73c6767e4..9e8f850f8 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -49,7 +49,8 @@ @.python ("python array new" size) @.lua ("lua array new" size) @.ruby ("ruby array new" size) - @.php ("php array new" size)})) + @.php ("php array new" size) + @.scheme ("scheme array new" size)})) (def: #export (size array) (All [a] (-> (Array a) Nat)) @@ -69,7 +70,8 @@ @.python ("python array length" array) @.lua ("lua array length" array) @.ruby ("ruby array length" array) - @.php ("php array length" array)})) + @.php ("php array length" array) + @.scheme ("scheme array length" array)})) (template: (!read <read> <null?>) (let [output (<read> index array)] @@ -99,7 +101,8 @@ @.python (!read "python array read" "python object none?") @.lua (!read "lua array read" "lua object nil?") @.ruby (!read "ruby array read" "ruby object nil?") - @.php (!read "php array read" "php object null?")}) + @.php (!read "php array read" "php object null?") + @.scheme (!read "scheme array read" "scheme object nil?")}) #.None)) (def: #export (write! index value array) @@ -118,7 +121,8 @@ @.python ("python array write" index value array) @.lua ("lua array write" index value array) @.ruby ("ruby array write" index value array) - @.php ("php array write" index value array)})) + @.php ("php array write" index value array) + @.scheme ("scheme array write" index value array)})) (def: #export (delete! index array) (All [a] @@ -134,7 +138,8 @@ @.python ("python array delete" index array) @.lua ("lua array delete" index array) @.ruby ("ruby array delete" index array) - @.php ("php array delete" index array)}) + @.php ("php array delete" index array) + @.scheme ("scheme array delete" index array)}) array)) ) diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux index 3296f78c4..a081233c9 100644 --- a/stdlib/source/lux/data/text/encoding.lux +++ b/stdlib/source/lux/data/text/encoding.lux @@ -207,7 +207,12 @@ (as_is (host.import: Almost_Binary) (host.import: (unpack [host.String host.String] Almost_Binary)) (host.import: (array_values [Almost_Binary] Binary)) - (def: php_byte_array_format "C*"))} + (def: php_byte_array_format "C*")) + + @.scheme + ## https://srfi.schemers.org/srfi-140/srfi-140.html + (as_is (host.import: (string->utf8 [Text] Binary)) + (host.import: (utf8->string [Binary] Text)))} (as_is))) (def: (utf8\encode value) @@ -254,7 +259,10 @@ (|> (..unpack [..php_byte_array_format value]) ..array_values ("php object new" "ArrayObject") - (:coerce Binary))})) + (:coerce Binary)) + + @.scheme + (..string->utf8 value)})) (def: (utf8\decode value) (-> Binary (Try Text)) @@ -295,6 +303,11 @@ @.php (|> value ("php pack" ..php_byte_array_format) + #try.Success) + + @.scheme + (|> value + ..utf8->string #try.Success)}))) (structure: #export utf8 diff --git a/stdlib/source/lux/debug.lux b/stdlib/source/lux/debug.lux index 29919a588..d5bbd3be2 100644 --- a/stdlib/source/lux/debug.lux +++ b/stdlib/source/lux/debug.lux @@ -15,7 +15,7 @@ ["<.>" code]]] [data ["." text - ["%" format (#+ format)]] + ["%" format]] [format [xml (#+ XML)] ["." json]] @@ -28,6 +28,9 @@ ["." template] ["." syntax (#+ syntax:)] ["." code]] + [math + [number + ["i" int]]] [time [instant (#+ Instant)] [duration (#+ Duration)] @@ -90,6 +93,17 @@ @.php (as_is (import: (gettype [.Any] host.String)) (import: (strval [.Any] host.String))) + + @.scheme + (as_is (import: (boolean? [.Any] Bit)) + (import: (integer? [.Any] Bit)) + (import: (real? [.Any] Bit)) + (import: (string? [.Any] Bit)) + (import: (vector? [.Any] Bit)) + (import: (pair? [.Any] Bit)) + (import: (car [.Any] .Any)) + (import: (cdr [.Any] .Any)) + (import: (format [Text .Any] Text))) })) (def: Inspector (-> Any Text)) @@ -130,9 +144,9 @@ (let [last? (case last? (#.Some _) #1 #.None #0)] - (|> (format (%.nat (.nat (java/lang/Integer::longValue tag))) - " " (%.bit last?) - " " (inspect choice)) + (|> (%.format (%.nat (.nat (java/lang/Integer::longValue tag))) + " " (%.bit last?) + " " (inspect choice)) (text.enclose ["(" ")"]))) _ @@ -159,9 +173,9 @@ (cond (not (or ("js object undefined?" variant_tag) ("js object undefined?" variant_flag) ("js object undefined?" variant_value))) - (|> (format (JSON::stringify variant_tag) - " " (%.bit (not ("js object null?" variant_flag))) - " " (inspect variant_value)) + (|> (%.format (JSON::stringify variant_tag) + " " (%.bit (not ("js object null?" variant_flag))) + " " (inspect variant_value)) (text.enclose ["(" ")"])) (not (or ("js object undefined?" ("js object get" "_lux_low" value)) @@ -200,9 +214,9 @@ (if (or ("python object none?" variant_tag) ("python object none?" variant_value)) (..str value) - (|> (format (|> variant_tag (:coerce .Nat) %.nat) - " " (|> variant_flag "python object none?" not %.bit) - " " (inspect variant_value)) + (|> (%.format (|> variant_tag (:coerce .Nat) %.nat) + " " (|> variant_flag "python object none?" not %.bit) + " " (inspect variant_value)) (text.enclose ["(" ")"])))) _ (..str value))) @@ -233,9 +247,9 @@ (if (not (or ("lua object nil?" variant_tag) ("lua object nil?" variant_flag) ("lua object nil?" variant_value))) - (|> (format (|> variant_tag (:coerce .Nat) %.nat) - " " (%.bit (not ("lua object nil?" variant_flag))) - " " (inspect variant_value)) + (|> (%.format (|> variant_tag (:coerce .Nat) %.nat) + " " (%.bit (not ("lua object nil?" variant_flag))) + " " (inspect variant_value)) (text.enclose ["(" ")"])) (inspect_tuple inspect value))) @@ -265,9 +279,9 @@ (if (not (or ("ruby object nil?" variant_tag) ("ruby object nil?" variant_flag) ("ruby object nil?" variant_value))) - (|> (format (|> variant_tag (:coerce .Nat) %.nat) - " " (%.bit (not ("ruby object nil?" variant_flag))) - " " (inspect variant_value)) + (|> (%.format (|> variant_tag (:coerce .Nat) %.nat) + " " (%.bit (not ("ruby object nil?" variant_flag))) + " " (inspect variant_value)) (text.enclose ["(" ")"])) (inspect_tuple inspect value))) @@ -296,14 +310,44 @@ (if (not (or ("php object null?" variant_tag) ("php object null?" variant_flag) ("php object null?" variant_value))) - (|> (format (|> variant_tag (:coerce .Nat) %.nat) - " " (%.bit (not ("php object null?" variant_flag))) - " " (inspect variant_value)) + (|> (%.format (|> variant_tag (:coerce .Nat) %.nat) + " " (%.bit (not ("php object null?" variant_flag))) + " " (inspect variant_value)) (text.enclose ["(" ")"])) (..strval value))) _ (..strval value)) + + @.scheme + (`` (cond (~~ (template [<when> <then>] + [(<when> value) + (`` (|> value (~~ (template.splice <then>))))] + + [..boolean? [(:coerce .Bit) %.bit]] + [..integer? [(:coerce .Int) %.int]] + [..real? [(:coerce .Frac) %.frac]] + [..string? [(:coerce .Text) %.text]] + ["scheme object nil?" [(new> "()" [])]] + [..vector? [(inspect_tuple inspect)]])) + + (..pair? value) + (let [variant_tag (..car value) + variant_rest (..cdr value)] + (if (and (..integer? variant_tag) + (i.> +0 (:coerce Int variant_tag)) + (..pair? variant_rest)) + (let [variant_flag (..car variant_rest) + variant_value (..cdr variant_rest)] + (|> (%.format (|> variant_tag (:coerce .Nat) %.nat) + " " (%.bit (not ("scheme object nil?" variant_flag))) + " " (inspect variant_value)) + (text.enclose ["(" ")"]))) + (..format ["~s" value]))) + + ## else + (..format ["~s" value]) + )) }))) (exception: #export (cannot_represent_value {type Type}) @@ -361,7 +405,7 @@ "#.None" (#.Some elemV) - (format "(#.Some " (elemR elemV) ")")))))))) + (%.format "(#.Some " (elemR elemV) ")")))))))) (def: (variant_representation representation) (-> (Parser Representation) (Parser Representation)) @@ -387,7 +431,7 @@ _ (undefined)))] - (format "(" (%.nat lefts) " " (%.bit right?) " " sub_repr ")")))))) + (%.format "(" (%.nat lefts) " " (%.bit right?) " " sub_repr ")")))))) (def: (tuple_representation representation) (-> (Parser Representation) (Parser Representation)) @@ -405,8 +449,8 @@ (#.Cons headR tailR) (let [[leftV rightV] (:coerce [Any Any] tupleV)] - (format (headR leftV) " " (recur tailR rightV)))))] - (format "[" tuple_body "]")))))) + (%.format (headR leftV) " " (recur tailR rightV)))))] + (%.format "[" tuple_body "]")))))) (def: representation (Parser Representation) diff --git a/stdlib/source/lux/host.scm.lux b/stdlib/source/lux/host.scm.lux new file mode 100644 index 000000000..1dde8ab69 --- /dev/null +++ b/stdlib/source/lux/host.scm.lux @@ -0,0 +1,219 @@ +(.module: + [lux (#- Alias) + ["." meta] + ["@" target] + [abstract + [monad (#+ do)]] + [control + ["." io] + ["<>" parser ("#\." monad) + ["<.>" code (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + ["." list ("#\." functor fold)]]] + [type + abstract] + [macro (#+ with_gensyms) + [syntax (#+ syntax:)] + ["." code] + ["." template]]]) + +(abstract: #export (Object brand) Any) + +(template [<name>] + [(with_expansions [<brand> (template.identifier [<name> "'"])] + (abstract: #export <brand> Any) + (type: #export <name> + (..Object <brand>)))] + + [Nil] + [Function] + ) + +(template [<name> <type>] + [(type: #export <name> + <type>)] + + [Boolean Bit] + [Integer Int] + [Float Frac] + [String Text] + ) + +(type: Nilable + [Bit Code]) + +(def: nilable + (Parser Nilable) + (let [token (' #?)] + (<| (<>.and (<>.parses? (<code>.this! token))) + (<>.after (<>.not (<code>.this! token))) + <code>.any))) + +(type: Alias + Text) + +(def: alias + (Parser Alias) + (<>.after (<code>.this! (' #as)) <code>.local_identifier)) + +(type: Field + [Bit Text (Maybe Alias) Nilable]) + +(def: static! + (Parser Any) + (<code>.this! (' #static))) + +(def: field + (Parser Field) + (<code>.form ($_ <>.and + (<>.parses? ..static!) + <code>.local_identifier + (<>.maybe ..alias) + ..nilable))) + +(def: constant + (Parser Field) + (<code>.form ($_ <>.and + (<>\wrap true) + <code>.local_identifier + (<>.maybe ..alias) + ..nilable))) + +(type: Common_Method + {#name Text + #alias (Maybe Alias) + #inputs (List Nilable) + #io? Bit + #try? Bit + #output Nilable}) + +(def: common_method + (Parser Common_Method) + ($_ <>.and + <code>.local_identifier + (<>.maybe ..alias) + (<code>.tuple (<>.some ..nilable)) + (<>.parses? (<code>.this! (' #io))) + (<>.parses? (<code>.this! (' #try))) + ..nilable)) + +(def: input_variables + (-> (List Nilable) (List [Bit Code])) + (|>> list.enumeration + (list\map (function (_ [idx [nilable? type]]) + [nilable? (|> idx %.nat code.local_identifier)])))) + +(def: (nilable_type [nilable? type]) + (-> Nilable Code) + (if nilable? + (` (.Maybe (~ type))) + type)) + +(def: (with_nil g!temp [nilable? input]) + (-> Code [Bit Code] Code) + (if nilable? + (` (case (~ input) + (#.Some (~ g!temp)) + (~ g!temp) + + #.Nil + ("scheme object nil"))) + input)) + +(def: (without_nil g!temp [nilable? outputT] output) + (-> Code Nilable Code Code) + (if nilable? + (` (let [(~ g!temp) (~ output)] + (if ("scheme object nil?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))) + (` (let [(~ g!temp) (~ output)] + (if (not ("scheme object nil?" (~ g!temp))) + (~ g!temp) + (.error! "Nil is an invalid value!")))))) + +(type: Import + (#Function Common_Method) + (#Constant Field)) + +(def: import + (Parser Import) + ($_ <>.or + (<code>.form ..common_method) + ..constant + )) + +(syntax: #export (try expression) + {#.doc (doc (case (try (risky_computation input)) + (#.Right success) + (do_something success) + + (#.Left error) + (recover_from_failure error)))} + (wrap (list (` ("lux try" ((~! io.io) (~ expression))))))) + +(def: (with_io with? without) + (-> Bit Code Code) + (if with? + (` (io.io (~ without))) + without)) + +(def: (io_type io? rawT) + (-> Bit Code Code) + (if io? + (` (io.IO (~ rawT))) + rawT)) + +(def: (with_try with? without_try) + (-> Bit Code Code) + (if with? + (` (..try (~ without_try))) + without_try)) + +(def: (try_type try? rawT) + (-> Bit Code Code) + (if try? + (` (.Either .Text (~ rawT))) + rawT)) + +(def: (make_function g!method g!temp source inputsT io? try? outputT) + (-> Code Code Code (List Nilable) Bit Bit Nilable Code) + (let [g!inputs (input_variables inputsT)] + (` (def: ((~ g!method) + [(~+ (list\map product.right g!inputs))]) + (-> [(~+ (list\map nilable_type inputsT))] + (~ (|> (nilable_type outputT) + (try_type try?) + (io_type io?)))) + (:assume + (~ (<| (with_io io?) + (with_try try?) + (without_nil g!temp outputT) + (` ("scheme apply" + (:coerce ..Function (~ source)) + (~+ (list\map (with_nil g!temp) g!inputs))))))))))) + +(syntax: #export (import: {import ..import}) + (with_gensyms [g!temp] + (case import + (#Function [name alias inputsT io? try? outputT]) + (let [imported (` ("scheme constant" (~ (code.text name))))] + (wrap (list (..make_function (code.local_identifier (maybe.default name alias)) + g!temp + imported + inputsT + io? + try? + outputT)))) + + (#Constant [_ name alias fieldT]) + (let [imported (` ("scheme constant" (~ (code.text name))))] + (wrap (list (` ((~! syntax:) ((~ (code.local_identifier (maybe.default name alias)))) + (\ (~! meta.monad) (~' wrap) + (list (` (.:coerce (~ (nilable_type fieldT)) (~ imported)))))))))) + ))) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 420e0bc83..1928d7c9a 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -245,6 +245,38 @@ (def: #export root/3 (-> Frac Frac) (..pow ("lux f64 /" +3.0 +1.0)))) + + @.scheme + (as_is (template [<name> <method>] + [(def: #export <name> + (-> Frac Frac) + (|>> ("scheme apply" ("scheme constant" <method>)) + (:coerce Frac)))] + + [cos "cos"] + [sin "sin"] + [tan "tan"] + + [acos "acos"] + [asin "asin"] + [atan "atan"] + + [exp "exp"] + [log "log"] + + [ceil "ceiling"] + [floor "floor"] + + [root/2 "sqrt"] + ) + + (def: #export (pow param subject) + (-> Frac Frac Frac) + (:coerce Frac ("scheme apply" ("scheme constant" "expt") subject param))) + + (def: #export root/3 + (-> Frac Frac) + (..pow ("lux f64 /" +3.0 +1.0)))) }) (def: #export (round input) diff --git a/stdlib/source/lux/target/scheme.lux b/stdlib/source/lux/target/scheme.lux index ecdaa7324..20bb08be3 100644 --- a/stdlib/source/lux/target/scheme.lux +++ b/stdlib/source/lux/target/scheme.lux @@ -1,23 +1,55 @@ (.module: - [lux (#- Code int or and if function cond let) + [lux (#- Code int or and if cond let) + ["@" target] + ["." host] + [abstract + [equivalence (#+ Equivalence)] + [hash (#+ Hash)]] [control [pipe (#+ new> cond> case>)]] [data ["." text ["%" format (#+ format)]] [collection - ["." list ("#\." functor fold)]]] + ["." list ("#\." functor fold monoid)]]] [macro ["." template]] [math [number + ["n" nat] ["f" frac]]] [type abstract]]) +(for {@.old (as_is (host.import: java/lang/CharSequence) + (host.import: java/lang/String + ["#::." + (replace [java/lang/CharSequence java/lang/CharSequence] java/lang/String)]))} + (as_is)) + +(def: nest + (-> Text Text) + (.let [nested_new_line (format text.new_line text.tab)] + (for {@.old (|>> (:coerce java/lang/String) + (java/lang/String::replace (:coerce java/lang/CharSequence text.new_line) + (:coerce java/lang/CharSequence nested_new_line)))} + (text.replace_all text.new_line nested_new_line)))) + (abstract: #export (Code k) Text + (structure: #export equivalence + (All [brand] (Equivalence (Code brand))) + + (def: (= reference subject) + (\ text.equivalence = (:representation reference) (:representation subject)))) + + (structure: #export hash + (All [brand] (Hash (Code brand))) + + (def: &equivalence ..equivalence) + (def: hash (|>> :representation (\ text.hash hash)))) + (template [<type> <brand> <super>+] [(abstract: #export (<brand> brand) Any) (`` (type: #export <type> (|> Any <brand> (~~ (template.splice <super>+)))))] @@ -110,14 +142,14 @@ (`` (|>> (~~ (template [<find> <replace>] [(text.replace_all <find> <replace>)] + ["\" "\\"] + ["|" "\|"] [text.alarm "\a"] [text.back_space "\b"] [text.tab "\t"] [text.new_line "\n"] [text.carriage_return "\r"] [text.double_quote (format "\" text.double_quote)] - ["\" "\\"] - ["|" "\|"] )) ))) @@ -131,10 +163,17 @@ (def: form (-> (List (Code Any)) Code) - (|>> (list\map ..code) - (text.join_with " ") - (text.enclose ["(" ")"]) - :abstraction)) + (.let [nested_new_line (format text.new_line text.tab)] + (|>> (case> #.Nil + (:abstraction "()") + + (#.Cons head tail) + (|> tail + (list\map (|>> :representation nest)) + (#.Cons (:representation head)) + (text.join_with nested_new_line) + (text.enclose ["(" ")"]) + :abstraction))))) (def: #export (apply/* args func) (-> (List Expression) Expression Computation) @@ -154,16 +193,17 @@ (..apply/* (list))) (template [<lux_name> <scheme_name>] - [(def: #export <lux_name> (apply/0 (..var <scheme_name>)))] + [(def: #export <lux_name> + (apply/0 (..var <scheme_name>)))] [newline/0 "newline"] ) (template [<apply> <arg>+ <type>+ <function>+] - [(`` (def: #export (<apply> function) + [(`` (def: #export (<apply> procedure) (-> Expression (~~ (template.splice <type>+)) Computation) - (.function (_ (~~ (template.splice <arg>+))) - (..apply/* (list (~~ (template.splice <arg>+))) function)))) + (function (_ (~~ (template.splice <arg>+))) + (..apply/* (list (~~ (template.splice <arg>+))) procedure)))) (`` (template [<definition> <function>] [(def: #export <definition> (<apply> (..var <function>)))] @@ -173,40 +213,47 @@ [apply/1 [_0] [Expression] [[exact/1 "exact"] [integer->char/1 "integer->char"] + [char->integer/1 "char->integer"] [number->string/1 "number->string"] + [string->number/1 "string->number"] + [floor/1 "floor"] + [truncate/1 "truncate"] [string/1 "string"] + [string?/1 "string?"] [length/1 "length"] [values/1 "values"] [null?/1 "null?"] [car/1 "car"] [cdr/1 "cdr"] [raise/1 "raise"] - [error_object_message/1 "error-object-message"] - [make_vector/1 "make-vector"] - [vector_length/1 "vector-length"] + [error-object-message/1 "error-object-message"] + [make-vector/1 "make-vector"] + [vector-length/1 "vector-length"] [not/1 "not"] - [string_length/1 "string-length"] - [string_hash/1 "string-hash"] + [string-hash/1 "string-hash"] [reverse/1 "reverse"] [display/1 "display"] - [exit/1 "exit"]]] + [exit/1 "exit"] + [string-length/1 "string-length"]]] [apply/2 [_0 _1] [Expression Expression] [[append/2 "append"] [cons/2 "cons"] - [make_vector/2 "make-vector"] - ## [vector_ref/2 "vector-ref"] - [list_tail/2 "list-tail"] + [make-vector/2 "make-vector"] + ## [vector-ref/2 "vector-ref"] + [list-tail/2 "list-tail"] [map/2 "map"] - [string_ref/2 "string-ref"] - [string_append/2 "string-append"]]] + [string-ref/2 "string-ref"] + [string-append/2 "string-append"] + [make-string/2 "make-string"]]] [apply/3 [_0 _1 _2] [Expression Expression Expression] [[substring/3 "substring"] - [vector_set!/3 "vector-set!"]]] + [vector-set!/3 "vector-set!"] + [string-contains/3 "string-contains"]]] [apply/5 [_0 _1 _2 _3 _4] [Expression Expression Expression Expression Expression] - [[vector_copy!/5 "vector-copy!"]]] + [[vector-copy!/5 "vector-copy!"]]] ) ## TODO: define "vector-ref/2" like a normal apply/2 function. @@ -222,7 +269,7 @@ ## 1. To carry on, and then, when it's time to compile the compiler ## itself into Scheme, switch from 'invoke' to normal 'vector-ref'. ## Either way, the 'invoke' needs to go away. - (def: #export (vector_ref/2 vector index) + (def: #export (vector-ref/2 vector index) (-> Expression Expression Computation) (..form (list (..var "invoke") vector (..symbol "getRaw") index))) @@ -248,10 +295,10 @@ [remainder/2 "remainder"] [quotient/2 "quotient"] [mod/2 "mod"] - [arithmetic_shift/2 "arithmetic-shift"] - [bit_and/2 "bitwise-and"] - [bit_or/2 "bitwise-ior"] - [bit_xor/2 "bitwise-xor"] + [arithmetic-shift/2 "arithmetic-shift"] + [bitwise-and/2 "bitwise-and"] + [bitwise-ior/2 "bitwise-ior"] + [bitwise-xor/2 "bitwise-xor"] ) (template [<lux_name> <scheme_name>] @@ -268,7 +315,7 @@ (-> (List [<var> Expression]) Expression Computation) (..form (list (..var <scheme_name>) (|> bindings - (list\map (.function (_ [binding/name binding/value]) + (list\map (function (_ [binding/name binding/value]) (..form (list (|> binding/name <pre>) binding/value)))) ..form) @@ -290,15 +337,6 @@ (-> Expression Expression Computation) (..form (list (..var "when") test then))) - (def: #export (cond clauses else) - (-> (List [Expression Expression]) Expression Computation) - (|> (list\fold (.function (_ [test then] next) - (if test then next)) - else - (list.reverse clauses)) - :representation - :abstraction)) - (def: #export (lambda arguments body) (-> Arguments Expression Computation) (..form (list (..var "lambda") @@ -328,4 +366,23 @@ (def: #export (with_exception_handler handler body) (-> Expression Expression Computation) (..form (list (..var "with-exception-handler") handler body))) + + (def: #export (call_with_current_continuation body) + (-> Expression Computation) + (..form (list (..var "call-with-current-continuation") body))) + + (def: #export (guard variable clauses else body) + (-> Var (List [Expression Expression]) (Maybe Expression) Expression Computation) + (..form (list (..var "guard") + (..form (|> (case else + #.None + (list) + + (#.Some else) + (list (..form (list (..var "else") else)))) + (list\compose (list\map (function (_ [when then]) + (..form (list when then))) + clauses)) + (list& variable))) + body))) ) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index cb006d9f7..0ef931275 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -171,20 +171,21 @@ <State+> (Try <State+>))) (|> (:share [<type_vars>] - {<State+> - state} - {(///directive.Operation <type_vars> Any) - (do ///phase.monad - [_ (///directive.lift_analysis - (///analysis.install analysis_state)) - _ (///directive.lift_analysis - (extension.with extender analysers)) - _ (///directive.lift_synthesis - (extension.with extender synthesizers)) - _ (///directive.lift_generation - (extension.with extender (:assume generators))) - _ (extension.with extender (:assume directives))] - (wrap []))}) + <State+> + state + + (///directive.Operation <type_vars> Any) + (do ///phase.monad + [_ (///directive.lift_analysis + (///analysis.install analysis_state)) + _ (///directive.lift_analysis + (extension.with extender analysers)) + _ (///directive.lift_synthesis + (extension.with extender synthesizers)) + _ (///directive.lift_generation + (extension.with extender (:assume generators))) + _ (extension.with extender (:assume directives))] + (wrap []))) (///phase.run' state) (\ try.monad map product.left))) @@ -343,70 +344,73 @@ (-> <Compiler> <Importer>))) (let [current (stm.var initial) pending (:share [<type_vars>] - {<Context> - initial} - {(Var (Dictionary Module <Pending>)) - (:assume (stm.var (dictionary.new text.hash)))}) + <Context> + initial + + (Var (Dictionary Module <Pending>)) + (:assume (stm.var (dictionary.new text.hash)))) dependence (: (Var Dependence) (stm.var ..independence))] (function (_ compile) (function (import! importer module) (do {! promise.monad} [[return signal] (:share [<type_vars>] - {<Context> - initial} - {(Promise [<Return> (Maybe [<Context> - archive.ID - <Signal>])]) - (:assume - (stm.commit - (do {! stm.monad} - [dependence (if (text\= archive.runtime_module importer) - (stm.read dependence) - (do ! - [[_ dependence] (stm.update (..depend importer module) dependence)] - (wrap dependence)))] - (case (..verify_dependencies importer module dependence) - (#try.Failure error) - (wrap [(promise.resolved (#try.Failure error)) - #.None]) - - (#try.Success _) - (do ! - [[archive state] (stm.read current)] - (if (archive.archived? archive module) - (wrap [(promise\wrap (#try.Success [archive state])) - #.None]) - (do ! - [@pending (stm.read pending)] - (case (dictionary.get module @pending) - (#.Some [return signal]) - (wrap [return - #.None]) - - #.None - (case (if (archive.reserved? archive module) - (do try.monad - [module_id (archive.id module archive)] - (wrap [module_id archive])) - (archive.reserve module archive)) - (#try.Success [module_id archive]) - (do ! - [_ (stm.write [archive state] current) - #let [[return signal] (:share [<type_vars>] - {<Context> - initial} - {<Pending> - (promise.promise [])})] - _ (stm.update (dictionary.put module [return signal]) pending)] - (wrap [return - (#.Some [[archive state] - module_id - signal])])) - - (#try.Failure error) - (wrap [(promise\wrap (#try.Failure error)) - #.None]))))))))))}) + <Context> + initial + + (Promise [<Return> (Maybe [<Context> + archive.ID + <Signal>])]) + (:assume + (stm.commit + (do {! stm.monad} + [dependence (if (text\= archive.runtime_module importer) + (stm.read dependence) + (do ! + [[_ dependence] (stm.update (..depend importer module) dependence)] + (wrap dependence)))] + (case (..verify_dependencies importer module dependence) + (#try.Failure error) + (wrap [(promise.resolved (#try.Failure error)) + #.None]) + + (#try.Success _) + (do ! + [[archive state] (stm.read current)] + (if (archive.archived? archive module) + (wrap [(promise\wrap (#try.Success [archive state])) + #.None]) + (do ! + [@pending (stm.read pending)] + (case (dictionary.get module @pending) + (#.Some [return signal]) + (wrap [return + #.None]) + + #.None + (case (if (archive.reserved? archive module) + (do try.monad + [module_id (archive.id module archive)] + (wrap [module_id archive])) + (archive.reserve module archive)) + (#try.Success [module_id archive]) + (do ! + [_ (stm.write [archive state] current) + #let [[return signal] (:share [<type_vars>] + <Context> + initial + + <Pending> + (promise.promise []))] + _ (stm.update (dictionary.put module [return signal]) pending)] + (wrap [return + (#.Some [[archive state] + module_id + signal])])) + + (#try.Failure error) + (wrap [(promise\wrap (#try.Failure error)) + #.None]))))))))))) _ (case signal #.None (wrap []) @@ -472,11 +476,12 @@ (-> Import Static Expander <Platform> Compilation <Context> <Return>)) (let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation base_compiler (:share [<type_vars>] - {<Context> - context} - {(///.Compiler <State+> .Module Any) - (:assume - ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))}) + <Context> + context + + (///.Compiler <State+> .Module Any) + (:assume + ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list)))) compiler (..parallel context (function (_ import! module_id [archive state] module) @@ -494,12 +499,13 @@ (let [new_dependencies (get@ #///.dependencies compilation) all_dependencies (list\compose new_dependencies all_dependencies) continue! (:share [<type_vars>] - {<Platform> - platform} - {(-> <Context> (///.Compilation <State+> .Module Any) (List Module) - (Action [Archive <State+>])) - (:assume - recur)})] + <Platform> + platform + + (-> <Context> (///.Compilation <State+> .Module Any) (List Module) + (Action [Archive <State+>])) + (:assume + recur))] (do ! [[archive state] (case new_dependencies #.Nil diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux index 1c0a89df5..ef13cb2ef 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux @@ -27,8 +27,130 @@ [/// ["." phase]]]]]]) +(def: array::new + Handler + (custom + [<c>.any + (function (_ extension phase archive lengthC) + (do phase.monad + [lengthA (analysis/type.with_type Nat + (phase archive lengthC)) + [var_id varT] (analysis/type.with_env check.var) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list lengthA)))))])) + +(def: array::length + Handler + (custom + [<c>.any + (function (_ extension phase archive arrayC) + (do phase.monad + [[var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer Nat)] + (wrap (#analysis.Extension extension (list arrayA)))))])) + +(def: array::read + Handler + (custom + [(<>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer varT)] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: array::write + Handler + (custom + [($_ <>.and <c>.any <c>.any <c>.any) + (function (_ extension phase archive [indexC valueC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + valueA (analysis/type.with_type varT + (phase archive valueC)) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA valueA arrayA)))))])) + +(def: array::delete + Handler + (custom + [($_ <>.and <c>.any <c>.any) + (function (_ extension phase archive [indexC arrayC]) + (do phase.monad + [indexA (analysis/type.with_type Nat + (phase archive indexC)) + [var_id varT] (analysis/type.with_env check.var) + arrayA (analysis/type.with_type (type (Array varT)) + (phase archive arrayC)) + _ (analysis/type.infer (type (Array varT)))] + (wrap (#analysis.Extension extension (list indexA arrayA)))))])) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "new" array::new) + (bundle.install "length" array::length) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + (bundle.install "delete" array::delete) + ))) + +(def: Nil + (for {@.scheme + host.Nil} + Any)) + +(def: Function + (for {@.scheme host.Function} + Any)) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "nil" (/.nullary ..Nil)) + (bundle.install "nil?" (/.unary Any Bit)) + ))) + +(def: scheme::constant + Handler + (custom + [<c>.text + (function (_ extension phase archive name) + (do phase.monad + [_ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list (analysis.text name))))))])) + +(def: scheme::apply + Handler + (custom + [($_ <>.and <c>.any (<>.some <c>.any)) + (function (_ extension phase archive [abstractionC inputsC]) + (do {! phase.monad} + [abstractionA (analysis/type.with_type ..Function + (phase archive abstractionC)) + inputsA (monad.map ! (|>> (phase archive) (analysis/type.with_type Any)) inputsC) + _ (analysis/type.infer Any)] + (wrap (#analysis.Extension extension (list& abstractionA inputsA)))))])) + (def: #export bundle Bundle (<| (bundle.prefix "scheme") (|> bundle.empty + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + + (bundle.install "constant" scheme::constant) + (bundle.install "apply" scheme::apply) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux index 4b84727aa..458b6bcd5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux @@ -328,10 +328,11 @@ _ (<| <scope> (///.install extender (:coerce Text name)) (:share [anchor expression directive] - {(Handler anchor expression directive) - handler} - {<type> - (:assume handlerV)})) + (Handler anchor expression directive) + handler + + <type> + (:assume handlerV))) _ (/////directive.lift_generation (/////generation.log! (format <description> " " (%.text (:coerce Text name)))))] (wrap /////directive.no_requirements)) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux index 6a13e29bb..71a122eff 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux @@ -54,145 +54,122 @@ (|>> list _.apply/* (|> (_.constant function)))) ## TODO: Get rid of this ASAP -## (def: lux::syntax_char_case! -## (..custom [($_ <>.and -## <s>.any -## <s>.any -## (<>.some (<s>.tuple ($_ <>.and -## (<s>.tuple (<>.many <s>.i64)) -## <s>.any)))) -## (function (_ extension_name phase archive [input else conditionals]) -## (do {! /////.monad} -## [inputG (phase archive input) -## [[context_module context_artifact] elseG] (generation.with_new_context archive -## (phase archive else)) -## @input (\ ! map _.var (generation.gensym "input")) -## conditionalsG (: (Operation (List [Expression Expression])) -## (monad.map ! (function (_ [chars branch]) -## (do ! -## [branchG (phase archive branch)] -## (wrap [(|> chars -## (list\map (|>> .int _.int (_.=== @input))) -## (list\fold (function (_ clause total) -## (if (is? _.null total) -## clause -## (_.or clause total))) -## _.null)) -## branchG]))) -## conditionals)) -## #let [foreigns (|> conditionals -## (list\map (|>> product.right synthesis.path/then //case.dependencies)) -## (list& (//case.dependencies (synthesis.path/then else))) -## list.concat -## (set.from_list _.hash) -## set.to_list) -## @expression (_.constant (reference.artifact [context_module context_artifact])) -## directive (_.define_function @expression (list& (_.parameter @input) (list\map _.reference foreigns)) -## (list\fold (function (_ [test then] else) -## (_.if test (_.return then) else)) -## (_.return elseG) -## conditionalsG))] -## _ (generation.execute! directive) -## _ (generation.save! (%.nat context_artifact) directive)] -## (wrap (_.apply/* (list& inputG foreigns) @expression))))])) - -## (def: lux_procs -## Bundle -## (|> /.empty -## (/.install "syntax char case!" lux::syntax_char_case!) -## (/.install "is" (binary (product.uncurry _.===))) -## (/.install "try" (unary //runtime.lux//try)) -## )) - -## (def: (left_shift [parameter subject]) -## (Binary Expression) -## (_.bit_shl (_.% (_.int +64) parameter) subject)) - -## (def: i64_procs -## Bundle -## (<| (/.prefix "i64") -## (|> /.empty -## (/.install "and" (binary (product.uncurry _.bit_and))) -## (/.install "or" (binary (product.uncurry _.bit_or))) -## (/.install "xor" (binary (product.uncurry _.bit_xor))) -## (/.install "left-shift" (binary ..left_shift)) -## (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) -## (/.install "=" (binary (product.uncurry _.==))) -## (/.install "<" (binary (product.uncurry _.<))) -## (/.install "+" (binary (product.uncurry //runtime.i64//+))) -## (/.install "-" (binary (product.uncurry //runtime.i64//-))) -## (/.install "*" (binary (product.uncurry //runtime.i64//*))) -## (/.install "/" (binary (function (_ [parameter subject]) -## (_.intdiv/2 [subject parameter])))) -## (/.install "%" (binary (product.uncurry _.%))) -## (/.install "f64" (unary (_./ (_.float +1.0)))) -## (/.install "char" (unary //runtime.i64//char)) -## ))) - -## (def: (f64//% [parameter subject]) -## (Binary Expression) -## (_.fmod/2 [subject parameter])) - -## (def: (f64//encode subject) -## (Unary Expression) -## (_.number_format/2 [subject (_.int +17)])) - -## (def: f64_procs -## Bundle -## (<| (/.prefix "f64") -## (|> /.empty -## (/.install "=" (binary (product.uncurry _.==))) -## (/.install "<" (binary (product.uncurry _.<))) -## (/.install "+" (binary (product.uncurry _.+))) -## (/.install "-" (binary (product.uncurry _.-))) -## (/.install "*" (binary (product.uncurry _.*))) -## (/.install "/" (binary (product.uncurry _./))) -## (/.install "%" (binary ..f64//%)) -## (/.install "i64" (unary _.intval/1)) -## (/.install "encode" (unary ..f64//encode)) -## (/.install "decode" (unary //runtime.f64//decode))))) - -## (def: (text//clip [paramO extraO subjectO]) -## (Trinary Expression) -## (//runtime.text//clip paramO extraO subjectO)) - -## (def: (text//index [startO partO textO]) -## (Trinary Expression) -## (//runtime.text//index textO partO startO)) +(def: lux::syntax_char_case! + (..custom [($_ <>.and + <s>.any + <s>.any + (<>.some (<s>.tuple ($_ <>.and + (<s>.tuple (<>.many <s>.i64)) + <s>.any)))) + (function (_ extension_name phase archive [input else conditionals]) + (do {! /////.monad} + [@input (\ ! map _.var (generation.gensym "input")) + inputG (phase archive input) + elseG (phase archive else) + conditionalsG (: (Operation (List [Expression Expression])) + (monad.map ! (function (_ [chars branch]) + (do ! + [branchG (phase archive branch)] + (wrap [(|> chars (list\map (|>> .int _.int (_.=/2 @input))) _.or) + branchG]))) + conditionals))] + (wrap (_.let (list [@input inputG]) + (list\fold (function (_ [test then] else) + (_.if test then else)) + elseG + conditionalsG)))))])) + +(def: lux_procs + Bundle + (|> /.empty + (/.install "syntax char case!" lux::syntax_char_case!) + (/.install "is" (binary (product.uncurry _.eq?/2))) + (/.install "try" (unary //runtime.lux//try)) + )) + +(def: (capped operation parameter subject) + (-> (-> Expression Expression Expression) + (-> Expression Expression Expression)) + (//runtime.i64//64 (operation parameter subject))) + +(def: i64_procs + Bundle + (<| (/.prefix "i64") + (|> /.empty + (/.install "and" (binary (product.uncurry //runtime.i64//and))) + (/.install "or" (binary (product.uncurry //runtime.i64//or))) + (/.install "xor" (binary (product.uncurry //runtime.i64//xor))) + (/.install "left-shift" (binary (product.uncurry //runtime.i64//left_shift))) + (/.install "right-shift" (binary (product.uncurry //runtime.i64//right_shift))) + (/.install "=" (binary (product.uncurry _.=/2))) + (/.install "<" (binary (product.uncurry _.</2))) + (/.install "+" (binary (product.uncurry (..capped _.+/2)))) + (/.install "-" (binary (product.uncurry (..capped _.-/2)))) + (/.install "*" (binary (product.uncurry (..capped _.*/2)))) + (/.install "/" (binary (product.uncurry //runtime.i64//division))) + (/.install "%" (binary (product.uncurry _.remainder/2))) + (/.install "f64" (unary (_.//2 (_.float +1.0)))) + (/.install "char" (unary (|>> _.integer->char/1 (_.make-string/2 (_.int +1))))) + ))) -## (def: text_procs -## Bundle -## (<| (/.prefix "text") -## (|> /.empty -## (/.install "=" (binary (product.uncurry _.==))) -## (/.install "<" (binary (product.uncurry _.<))) -## (/.install "concat" (binary (product.uncurry (function.flip _.concat)))) -## (/.install "index" (trinary ..text//index)) -## (/.install "size" (unary //runtime.text//size)) -## (/.install "char" (binary (product.uncurry //runtime.text//char))) -## (/.install "clip" (trinary ..text//clip)) -## ))) +(def: f64_procs + Bundle + (<| (/.prefix "f64") + (|> /.empty + (/.install "=" (binary (product.uncurry _.=/2))) + (/.install "<" (binary (product.uncurry _.</2))) + (/.install "+" (binary (product.uncurry _.+/2))) + (/.install "-" (binary (product.uncurry _.-/2))) + (/.install "*" (binary (product.uncurry _.*/2))) + (/.install "/" (binary (product.uncurry _.//2))) + (/.install "%" (binary (product.uncurry _.remainder/2))) + (/.install "i64" (unary _.truncate/1)) + (/.install "encode" (unary _.number->string/1)) + (/.install "decode" (unary //runtime.f64//decode))))) + +(def: (text//index [offset sub text]) + (Trinary Expression) + (//runtime.text//index offset sub text)) + +(def: (text//clip [paramO extraO subjectO]) + (Trinary Expression) + (//runtime.text//clip paramO extraO subjectO)) + +(def: text_procs + Bundle + (<| (/.prefix "text") + (|> /.empty + (/.install "=" (binary (product.uncurry _.string=?/2))) + (/.install "<" (binary (product.uncurry _.string<?/2))) + (/.install "concat" (binary (product.uncurry _.string-append/2))) + (/.install "index" (trinary ..text//index)) + (/.install "size" (unary _.string-length/1)) + (/.install "char" (binary (product.uncurry //runtime.text//char))) + (/.install "clip" (trinary ..text//clip)) + ))) -## (def: io//current-time -## (Nullary Expression) -## (|>> _.time/0 -## (_.* (_.int +1,000)))) +(def: (io//log! message) + (Unary Expression) + (_.begin (list (_.display/1 message) + (_.display/1 (_.string text.new_line)) + //runtime.unit))) -## (def: io_procs -## Bundle -## (<| (/.prefix "io") -## (|> /.empty -## (/.install "log" (unary //runtime.io//log!)) -## (/.install "error" (unary //runtime.io//throw!)) -## (/.install "current-time" (nullary ..io//current-time))))) +(def: io_procs + Bundle + (<| (/.prefix "io") + (|> /.empty + (/.install "log" (unary ..io//log!)) + (/.install "error" (unary _.raise/1)) + (/.install "current-time" (nullary (function.constant (//runtime.io//current_time //runtime.unit)))) + ))) (def: #export bundle Bundle (<| (/.prefix "lux") (|> /.empty - ## (dictionary.merge lux_procs) - ## (dictionary.merge i64_procs) - ## (dictionary.merge f64_procs) - ## (dictionary.merge text_procs) - ## (dictionary.merge io_procs) + (dictionary.merge lux_procs) + (dictionary.merge i64_procs) + (dictionary.merge f64_procs) + (dictionary.merge text_procs) + (dictionary.merge io_procs) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux index 0a05436c2..55e46ad23 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux @@ -32,8 +32,76 @@ ["//#" /// #_ ["#." phase]]]]]]) +(def: (array::new size) + (Unary Expression) + (_.make-vector/2 size _.nil)) + +(def: array::length + (Unary Expression) + _.vector-length/1) + +(def: (array::read [indexG arrayG]) + (Binary Expression) + (_.vector-ref/2 arrayG indexG)) + +(def: (array::write [indexG valueG arrayG]) + (Trinary Expression) + (//runtime.array//write indexG valueG arrayG)) + +(def: (array::delete [indexG arrayG]) + (Binary Expression) + (//runtime.array//write indexG _.nil arrayG)) + +(def: array + Bundle + (<| (/.prefix "array") + (|> /.empty + (/.install "new" (unary array::new)) + (/.install "length" (unary array::length)) + (/.install "read" (binary array::read)) + (/.install "write" (trinary array::write)) + (/.install "delete" (binary array::delete)) + ))) + +(template [<!> <?> <unit>] + [(def: <!> (Nullary Expression) (function.constant <unit>)) + (def: <?> (Unary Expression) (_.eq?/2 <unit>))] + + [object::nil object::nil? _.nil] + ) + +(def: object + Bundle + (<| (/.prefix "object") + (|> /.empty + (/.install "nil" (nullary object::nil)) + (/.install "nil?" (unary object::nil?)) + ))) + +(def: scheme::constant + (custom + [<s>.text + (function (_ extension phase archive name) + (do ////////phase.monad + [] + (wrap (_.var name))))])) + +(def: scheme::apply + (custom + [($_ <>.and <s>.any (<>.some <s>.any)) + (function (_ extension phase archive [abstractionS inputsS]) + (do {! ////////phase.monad} + [abstractionG (phase archive abstractionS) + inputsG (monad.map ! (phase archive) inputsS)] + (wrap (_.apply/* inputsG abstractionG))))])) + (def: #export bundle Bundle (<| (/.prefix "scheme") (|> /.empty + (dictionary.merge ..array) + (dictionary.merge ..object) + + (/.install "constant" scheme::constant) + (/.install "apply" scheme::apply) ))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux index 1638a64ca..ec8ff641f 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux @@ -250,19 +250,20 @@ (_.set (list wantedTag) (_.- sum_tag wantedTag)) (_.set (list sum) sum_value)) no_match!)] - (<| (_.while (_.bool true)) - (_.cond (list [(_.= wantedTag sum_tag) - (_.if (_.= wantsLast sum_flag) - (_.return sum_value) - test_recursion!)] + (_.while (_.bool true) + (_.cond (list [(_.= wantedTag sum_tag) + (_.if (_.= wantsLast sum_flag) + (_.return sum_value) + test_recursion!)] - [(_.< wantedTag sum_tag) - test_recursion!] + [(_.< wantedTag sum_tag) + test_recursion!] - [(_.= ..unit wantsLast) - (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) + [(_.= ..unit wantsLast) + (_.return (variant' (_.- wantedTag sum_tag) sum_flag sum_value))]) - no_match!)))) + no_match!) + #.None))) (def: runtime//adt (Statement Any) @@ -296,13 +297,8 @@ ## This +- is only necessary to guarantee that values within the limits are always longs in Python 2 (|> input (_.+ ..i64//+limit) (_.- ..i64//+limit)))))))) -(runtime: i64//nat_top - (|> (_.int +1) - (_.bit_shl (_.int +64)) - (_.- (_.int +1)))) - (def: as_nat - (_.% (_.manual "0x10000000000000000"))) + (_.% ..i64//+iteration)) (runtime: (i64//left_shift param subject) (_.return (|> subject @@ -345,14 +341,14 @@ [i64//xor _.bit_xor] ) -(def: version +(def: python_version (Expression Any) (|> (_.__import__/1 (_.unicode "sys")) (_.the "version_info") (_.the "major"))) (runtime: (i64//char value) - (_.return (_.? (_.= (_.int +3) ..version) + (_.return (_.? (_.= (_.int +3) ..python_version) (_.chr/1 value) (_.unichr/1 value)))) @@ -360,7 +356,6 @@ (Statement Any) ($_ _.then @i64//64 - @i64//nat_top @i64//left_shift @i64//right_shift @i64//division diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux index 8f7d8a8b1..884e20c0f 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux @@ -9,6 +9,8 @@ [collection ["." list ("#\." functor fold)] ["." set]]] + [macro + ["." template]] [math [number ["i" int]]] @@ -87,7 +89,7 @@ (def: (pop! var) (-> Var Computation) - (_.set! var var)) + (_.set! var (_.cdr/1 var))) (def: save_cursor! Computation @@ -95,7 +97,8 @@ (def: restore_cursor! Computation - (_.set! @cursor (_.car/1 @savepoint))) + (_.begin (list (_.set! @cursor (_.car/1 @savepoint)) + (_.set! @savepoint (_.cdr/1 @savepoint))))) (def: peek Computation @@ -106,17 +109,20 @@ (pop! @cursor)) (def: pm_error - (_.string "PM-ERROR")) + (_.string (template.with_locals [pm_error] + (template.text [pm_error])))) (def: fail! (_.raise/1 pm_error)) -(def: (pm_catch handler) - (-> Expression Computation) - (_.lambda [(list @alt_error) #.None] - (_.if (|> @alt_error (_.eqv?/2 pm_error)) - handler - (_.raise/1 @alt_error)))) +(def: (try_pm on_failure happy_path) + (-> Expression Expression Computation) + (_.guard @alt_error + (list [(_.and (list (_.string?/1 @alt_error) + (_.string=?/2 ..pm_error @alt_error))) + on_failure]) + #.None + happy_path)) (def: (pattern_matching' expression archive) (Generator Path) @@ -158,49 +164,54 @@ ..peek) then!]))) (#.Cons cons))] - (wrap (_.cond clauses ..fail!)))]) + (wrap (list\fold (function (_ [when then] else) + (_.if when then else)) + ..fail! + clauses)))]) ([#/////synthesis.I64_Fork //primitive.i64 _.=/2] [#/////synthesis.F64_Fork //primitive.f64 _.=/2] - [#/////synthesis.Text_Fork //primitive.text _.eqv?/2]) + [#/////synthesis.Text_Fork //primitive.text _.string=?/2]) (^template [<pm> <flag> <prep>] [(^ (<pm> idx)) - (///////phase\wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek <flag>))]) + (///////phase\wrap (_.let (list [@temp (|> idx <prep> .int _.int (//runtime.sum//get ..peek (_.bool <flag>)))]) (_.if (_.null?/1 @temp) ..fail! (push_cursor! @temp))))]) - ([/////synthesis.side/left _.nil (<|)] - [/////synthesis.side/right (_.string "") inc]) + ([/////synthesis.side/left false (<|)] + [/////synthesis.side/right true inc]) + + (^ (/////synthesis.member/left 0)) + (///////phase\wrap (..push_cursor! (_.vector-ref/2 ..peek (_.int +0)))) (^template [<pm> <getter>] - [(^ (<pm> idx)) - (///////phase\wrap (push_cursor! (<getter> (_.int (.int idx)) ..peek)))]) + [(^ (<pm> lefts)) + (///////phase\wrap (|> ..peek (<getter> (_.int (.int lefts))) ..push_cursor!))]) ([/////synthesis.member/left //runtime.tuple//left] [/////synthesis.member/right //runtime.tuple//right]) - (^template [<tag> <computation>] - [(^ (<tag> leftP rightP)) - (do ///////phase.monad - [leftO (recur leftP) - rightO (recur rightP)] - (wrap <computation>))]) - ([/////synthesis.path/seq (_.begin (list leftO - rightO))] - [/////synthesis.path/alt (_.with_exception_handler - (pm_catch (_.begin (list restore_cursor! - rightO))) - (_.lambda [(list) #.None] - (_.begin (list save_cursor! - leftO))))])))) + (^ (/////synthesis.path/seq leftP rightP)) + (do ///////phase.monad + [leftO (recur leftP) + rightO (recur rightP)] + (wrap (_.begin (list leftO + rightO)))) + + (^ (/////synthesis.path/alt leftP rightP)) + (do {! ///////phase.monad} + [leftO (recur leftP) + rightO (recur rightP)] + (wrap (try_pm (_.begin (list restore_cursor! + rightO)) + (_.begin (list save_cursor! + leftO))))) + ))) (def: (pattern_matching expression archive pathP) (Generator Path) - (do ///////phase.monad - [pattern_matching! (pattern_matching' expression archive pathP)] - (wrap (_.with_exception_handler - (pm_catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) - (_.lambda [(list) #.None] - pattern_matching!))))) + (\ ///////phase.monad map + (try_pm (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (pattern_matching' expression archive pathP))) (def: #export (case expression archive [valueS pathP]) (Generator [Synthesis Path]) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux index edcdb89b4..380352c5b 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux @@ -89,9 +89,10 @@ output_func_args (//runtime.slice arityO (|> @num_args (_.-/2 arityO)) @curried)] - (|> @self - (apply_poly arity_args) - (apply_poly output_func_args)))) + (_.begin (list ## (_.display/1 (_.string (format "!!! PRE [slice]" text.new_line))) + (|> @self + (apply_poly arity_args) + (apply_poly output_func_args)))))) ## (|> @num_args (_.</2 arityO)) (_.lambda [(list) (#.Some @missing)] (|> @self diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux index d6ae1cffd..815b5a8a5 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux @@ -53,41 +53,9 @@ (type: #export (Generator i) (-> Phase Archive i (Operation Expression))) -(def: unit +(def: #export unit (_.string /////synthesis.unit)) -(def: (flag value) - (-> Bit Computation) - (if value - ..unit - _.nil)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Computation) - (<| (_.cons/2 tag) - (_.cons/2 last?) - value)) - -(def: #export (variant [lefts right? value]) - (-> (Variant Expression) Computation) - (variant' (_.int (.int lefts)) (flag right?) value)) - -(def: #export none - Computation - (variant [0 #0 ..unit])) - -(def: #export some - (-> Expression Computation) - (|>> [0 #1] ..variant)) - -(def: #export left - (-> Expression Computation) - (|>> [0 #0] ..variant)) - -(def: #export right - (-> Expression Computation) - (|>> [0 #1] ..variant)) - (syntax: #export (with_vars {vars (<code>.tuple (<>.some <code>.local_identifier))} body) (do {! meta.monad} @@ -137,41 +105,6 @@ (_.define_function (~ runtime_name) [(list (~+ inputsC)) #.None] (~ code)))))))))))))) -(runtime: (slice offset length list) - (<| (_.if (_.null?/1 list) - list) - (_.if (|> offset (_.>/2 (_.int +0))) - (slice (|> offset (_.-/2 (_.int +1))) - length - (_.cdr/1 list))) - (_.if (|> length (_.>/2 (_.int +0))) - (_.cons/2 (_.car/1 list) - (slice offset - (|> length (_.-/2 (_.int +1))) - (_.cdr/1 list)))) - _.nil)) - -(runtime: (lux//try op) - (with_vars [error] - (_.with_exception_handler - (_.lambda [(list error) #.None] - (..left error)) - (_.lambda [(list) #.None] - (..right (_.apply/* (list ..unit) op)))))) - -(runtime: (lux//program_args program_args) - (with_vars [@loop @input @output] - (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] - (_.if (_.eqv?/2 _.nil @input) - @output - (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) - (_.apply/2 @loop (_.reverse/1 program_args) ..none)))) - -(def: runtime//lux - Computation - (_.begin (list @lux//try - @lux//program_args))) - (def: last_index (-> Expression Computation) (|>> _.length/1 (_.-/2 (_.int +1)))) @@ -182,50 +115,62 @@ (list (_.define_constant last_index_right (..last_index tuple)) (_.if (_.>/2 lefts last_index_right) ## No need for recursion - (_.vector_ref/2 tuple lefts) + (_.vector-ref/2 tuple lefts) ## Needs recursion (tuple//left (_.-/2 last_index_right lefts) - (_.vector_ref/2 tuple last_index_right))))))) + (_.vector-ref/2 tuple last_index_right))))))) (runtime: (tuple//right lefts tuple) (with_vars [last_index_right right_index @slice] (_.begin (list (_.define_constant last_index_right (..last_index tuple)) (_.define_constant right_index (_.+/2 (_.int +1) lefts)) - (_.cond (list [(_.=/2 last_index_right right_index) - (_.vector_ref/2 tuple right_index)] - [(_.>/2 last_index_right right_index) - ## Needs recursion. - (tuple//right (_.-/2 last_index_right lefts) - (_.vector_ref/2 tuple last_index_right))]) - (_.begin - (list (_.define_constant @slice (_.make_vector/1 (_.-/2 right_index (_.length/1 tuple)))) - (_.vector_copy!/5 @slice (_.int +0) tuple right_index (_.length/1 tuple)) - @slice)))) + (<| (_.if (_.=/2 last_index_right right_index) + (_.vector-ref/2 tuple right_index)) + (_.if (_.>/2 last_index_right right_index) + ## Needs recursion. + (tuple//right (_.-/2 last_index_right lefts) + (_.vector-ref/2 tuple last_index_right))) + (_.begin + (list (_.define_constant @slice (_.make-vector/1 (_.-/2 right_index (_.length/1 tuple)))) + (_.vector-copy!/5 @slice (_.int +0) tuple right_index (_.length/1 tuple)) + @slice)))) ))) +(def: (variant' tag last? value) + (-> Expression Expression Expression Computation) + ($_ _.cons/2 + tag + last? + value)) + +(runtime: (sum//make tag last? value) + (variant' tag last? value)) + +(def: #export (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (..sum//make (_.int (.int lefts)) (_.bool right?) value)) + (runtime: (sum//get sum last? wanted_tag) - (with_vars [sum_tag sum_flag sum_value] + (with_vars [sum_tag sum_flag sum_value sum_temp sum_dump] (let [no_match _.nil - is_last? (|> sum_flag (_.eqv?/2 ..unit)) - test_recursion (_.if is_last? + test_recursion (_.if sum_flag ## Must recurse. (sum//get sum_value last? (|> wanted_tag (_.-/2 sum_tag))) no_match)] (<| (_.let (list [sum_tag (_.car/1 sum)] - [sum_value (_.cdr/1 sum)])) - (_.let (list [sum_flag (_.car/1 sum_value)] - [sum_value (_.cdr/1 sum_value)])) - (_.if (|> wanted_tag (_.=/2 sum_tag)) - (_.if (|> sum_flag (_.eqv?/2 last?)) + [sum_temp (_.cdr/1 sum)])) + (_.let (list [sum_flag (_.car/1 sum_temp)] + [sum_value (_.cdr/1 sum_temp)])) + (_.if (_.=/2 wanted_tag sum_tag) + (_.if (_.eqv?/2 last? sum_flag) sum_value test_recursion)) - (_.if (|> wanted_tag (_.>/2 sum_tag)) + (_.if (_.</2 wanted_tag sum_tag) test_recursion) - (_.if (_.and (list (|> last? (_.eqv?/2 ..unit)) - (|> wanted_tag (_.</2 sum_tag)))) + (_.if last? (variant' (|> sum_tag (_.-/2 wanted_tag)) sum_flag sum_value)) no_match)))) @@ -233,36 +178,178 @@ Computation (_.begin (list @tuple//left @tuple//right - @sum//get))) + @sum//get + @sum//make))) + +(def: #export none + Computation + (|> ..unit [0 #0] variant)) + +(def: #export some + (-> Expression Computation) + (|>> [1 #1] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [0 #0] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [1 #1] ..variant)) + +(runtime: (slice offset length list) + (<| (_.if (_.null?/1 list) + list) + (_.if (|> offset (_.>/2 (_.int +0))) + (slice (|> offset (_.-/2 (_.int +1))) + length + (_.cdr/1 list))) + (_.if (|> length (_.>/2 (_.int +0))) + (_.cons/2 (_.car/1 list) + (slice offset + (|> length (_.-/2 (_.int +1))) + (_.cdr/1 list)))) + _.nil)) -(runtime: (i64//logical_right_shift shift input) - (_.if (_.=/2 (_.int +0) shift) - input - (|> input - (_.arithmetic_shift/2 (_.*/2 (_.int -1) shift)) - (_.bit_and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) +(runtime: (lux//try op) + (with_vars [error] + (_.with_exception_handler + (_.lambda [(list error) #.None] + (..left error)) + (_.lambda [(list) #.None] + (..right (_.apply/* (list ..unit) op)))))) -(def: runtime//bit +(runtime: (lux//program_args program_args) + (with_vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] + (_.if (_.null?/1 @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.apply/2 @loop (_.reverse/1 program_args) ..none)))) + +(def: runtime//lux Computation - (_.begin (list @i64//logical_right_shift))) + (_.begin (list @lux//try + @lux//program_args))) + +(def: i64//+limit (_.manual "+9223372036854775807" + ## "+0x7FFFFFFFFFFFFFFF" + )) +(def: i64//-limit (_.manual "-9223372036854775808" + ## "-0x8000000000000000" + )) +(def: i64//+iteration (_.manual "+18446744073709551616" + ## "+0x10000000000000000" + )) +(def: i64//-iteration (_.manual "-18446744073709551616" + ## "-0x10000000000000000" + )) +(def: i64//+cap (_.manual "+9223372036854775808" + ## "+0x8000000000000000" + )) +(def: i64//-cap (_.manual "-9223372036854775809" + ## "-0x8000000000000001" + )) + +(runtime: (i64//64 input) + (with_vars [temp] + (`` (<| (~~ (template [<scenario> <iteration> <cap> <entrance>] + [(_.if (|> input <scenario>) + (_.let (list [temp (_.remainder/2 <iteration> input)]) + (_.if (|> temp <scenario>) + (|> temp (_.-/2 <cap>) (_.+/2 <entrance>)) + temp)))] + + [(_.>/2 ..i64//+limit) ..i64//+iteration ..i64//+cap ..i64//-limit] + [(_.</2 ..i64//-limit) ..i64//-iteration ..i64//-cap ..i64//+limit] + )) + input)))) + +(runtime: (i64//left_shift param subject) + (|> subject + (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) param)) + ..i64//64)) + +(def: as_nat + (_.remainder/2 ..i64//+iteration)) + +(runtime: (i64//right_shift shift subject) + (_.let (list [shift (_.remainder/2 (_.int +64) shift)]) + (_.if (_.=/2 (_.int +0) shift) + subject + (|> subject + ..as_nat + (_.arithmetic-shift/2 (_.-/2 shift (_.int +0))))))) + +(template [<runtime> <host>] + [(runtime: (<runtime> left right) + (..i64//64 (<host> (..as_nat left) (..as_nat right))))] + + [i64//or _.bitwise-ior/2] + [i64//xor _.bitwise-xor/2] + [i64//and _.bitwise-and/2] + ) + +(runtime: (i64//division param subject) + (|> subject (_.//2 param) _.truncate/1 ..i64//64)) -(runtime: (frac//decode input) +(def: runtime//i64 + Computation + (_.begin (list @i64//64 + @i64//left_shift + @i64//right_shift + @i64//or + @i64//xor + @i64//and + @i64//division))) + +(runtime: (f64//decode input) (with_vars [@output] - (_.let (list [@output ((_.apply/1 (_.var "string->number")) input)]) - (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) - (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) - ..none - (..some @output))))) + (let [output_is_not_a_number? (_.not/1 (_.=/2 @output @output)) + input_is_not_a_number? (_.string=?/2 (_.string "+nan.0") input)] + (_.let (list [@output (_.string->number/1 input)]) + (_.if (_.and (list output_is_not_a_number? + (_.not/1 input_is_not_a_number?))) + ..none + (..some @output)))))) + +(def: runtime//f64 + Computation + (_.begin (list @f64//decode))) + +(runtime: (text//index offset sub text) + (with_vars [index] + (_.let (list [index (_.string-contains/3 text sub offset)]) + (_.if index + (..some index) + ..none)))) + +(runtime: (text//clip offset length text) + (_.substring/3 text offset (_.+/2 offset length))) + +(runtime: (text//char index text) + (_.char->integer/1 (_.string-ref/2 text index))) + +(def: runtime//text + (_.begin (list @text//index + @text//clip + @text//char))) + +(runtime: (array//write idx value array) + (_.begin (list (_.vector-set!/3 array idx value) + array))) -(def: runtime//frac +(def: runtime//array Computation - (_.begin - (list @frac//decode))) + ($_ _.then + @array//write + )) (runtime: (io//current_time _) (|> (_.apply/0 (_.var "current-second")) (_.*/2 (_.int +1,000)) - _.exact/1)) + _.exact/1 + _.truncate/1)) (def: runtime//io (_.begin (list @io//current_time))) @@ -271,9 +358,11 @@ Computation (_.begin (list @slice runtime//lux - runtime//bit + runtime//i64 runtime//adt - runtime//frac + runtime//f64 + runtime//text + runtime//array runtime//io ))) diff --git a/stdlib/source/lux/tool/compiler/meta/packager/script.lux b/stdlib/source/lux/tool/compiler/meta/packager/script.lux index c874cfd88..95026ae37 100644 --- a/stdlib/source/lux/tool/compiler/meta/packager/script.lux +++ b/stdlib/source/lux/tool/compiler/meta/packager/script.lux @@ -54,10 +54,11 @@ (function (_ content) (sequence so_far (:share [directive] - {directive - so_far} - {directive - (:assume content)})))))) + directive + so_far + + directive + (:assume content))))))) so_far))) (def: #export (package header to_code sequence scope) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 52a56aa04..3b80a7ea8 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -1568,6 +1568,9 @@ ..default_separator) )) ) + + @.scheme + (as_is) })) (template [<get> <signature> <create> <find> <exception>] diff --git a/stdlib/source/lux/world/program.lux b/stdlib/source/lux/world/program.lux index d6fe4c2e3..0abdb2225 100644 --- a/stdlib/source/lux/world/program.lux +++ b/stdlib/source/lux/world/program.lux @@ -24,7 +24,9 @@ ["." list ("#\." functor)]]] [math [number - ["i" int]]]] + ["i" int]]] + [type + abstract]] [// [file (#+ Path)] [shell (#+ Exit)]]) @@ -229,7 +231,18 @@ ## https://www.php.net/manual/en/function.getenv.php ## https://www.php.net/manual/en/function.array-keys.php (host.import: (array_keys [(Array host.String)] (Array host.String))) - )} + ) + + @.scheme + (as_is (host.import: (exit [Int] #io Nothing)) + ## https://srfi.schemers.org/srfi-98/srfi-98.html + (abstract: Pair Any) + (abstract: PList Any) + (host.import: (get-environment-variables [] #io PList)) + (host.import: (car [Pair] Text)) + (host.import: (cdr [Pair] Text)) + (host.import: (car #as head [PList] Pair)) + (host.import: (cdr #as tail [PList] PList)))} (as_is))) (structure: #export default @@ -275,7 +288,16 @@ array.to_list (list\map (function (_ variable) [variable ("php array read" (:coerce Nat variable) environment)])) - (dictionary.from_list text.hash))))} + (dictionary.from_list text.hash)))) + @.scheme (do io.monad + [input (..get-environment-variables [])] + (loop [input input + output environment.empty] + (if ("scheme object nil?" input) + (wrap output) + (let [entry (..head input)] + (recur (..tail input) + (dictionary.put (..car entry) (..cdr entry) output))))))} ## TODO: Replace dummy implementation. (io.io environment.empty)))) @@ -346,4 +368,5 @@ @.python (os::_exit [code]) @.lua (os/exit [code]) @.ruby (RubyKernel::exit [code]) - @.php (..exit [code])})))) + @.php (..exit [code]) + @.scheme (..exit [code])})))) diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux index a66022594..03e9b281d 100644 --- a/stdlib/source/program/compositor.lux +++ b/stdlib/source/program/compositor.lux @@ -78,15 +78,17 @@ (#try.Success content) (do (try.with monad) [package (:share [!] - {(Monad !) - monad} - {(! (Try (File !))) - (:assume (file.get_file monad file_system package))})] + (Monad !) + monad + + (! (Try (File !))) + (:assume (file.get_file monad file_system package)))] (!.use (\ (:share [!] - {(Monad !) - monad} - {(File !) - (:assume package)}) + (Monad !) + monad + + (File !) + (:assume package)) over_write) [content])) @@ -134,17 +136,19 @@ [#let [[compilation_sources compilation_libraries compilation_target compilation_module] compilation] import (/import.import (get@ #platform.&file_system platform) compilation_libraries) [state archive] (:share [<parameters>] - {(Platform <parameters>) - platform} - {(Promise (Try [(directive.State+ <parameters>) - Archive])) - (:assume (platform.initialize static compilation_module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender - import compilation_sources))}) + (Platform <parameters>) + platform + + (Promise (Try [(directive.State+ <parameters>) + Archive])) + (:assume (platform.initialize static compilation_module expander host_analysis platform generation_bundle host_directive_bundle program anchorT,expressionT,directiveT extender + import compilation_sources))) [archive state] (:share [<parameters>] - {(Platform <parameters>) - platform} - {(Promise (Try [Archive (directive.State+ <parameters>)])) - (:assume (platform.compile import static expander platform compilation [archive state]))}) + (Platform <parameters>) + platform + + (Promise (Try [Archive (directive.State+ <parameters>)])) + (:assume (platform.compile import static expander platform compilation [archive state]))) _ (ioW.freeze (get@ #platform.&file_system platform) static archive) program_context (promise\wrap ($/program.context archive)) _ (promise.future (..package! io.monad file.default packager,package static archive program_context))] diff --git a/stdlib/source/test/lux/extension.lux b/stdlib/source/test/lux/extension.lux index cdd934e3e..8ff1cdc00 100644 --- a/stdlib/source/test/lux/extension.lux +++ b/stdlib/source/test/lux/extension.lux @@ -7,7 +7,8 @@ ["." python] ["." lua] ["." ruby] - ["." php]] + ["." php] + ["." scheme]] [abstract [monad (#+ do)]] [control @@ -69,7 +70,8 @@ @.python (python.unicode self) @.lua (lua.string self) @.ruby (ruby.string self) - @.php (php.string self)}))))) + @.php (php.string self) + @.scheme (scheme.string self)}))))) (for {@.old (as_is)} diff --git a/stdlib/source/test/lux/host.scm.lux b/stdlib/source/test/lux/host.scm.lux new file mode 100644 index 000000000..0b6cac81b --- /dev/null +++ b/stdlib/source/test/lux/host.scm.lux @@ -0,0 +1,24 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try]] + [data + ["." text ("#\." equivalence)]] + [math + ["." random (#+ Random)] + [number + ["." nat] + ["." frac]]]] + {1 + ["." /]}) + +(def: #export test + Test + (do {! random.monad} + [] + (<| (_.covering /._) + (_.test "TBD" + true)))) diff --git a/stdlib/source/test/lux/world/file.lux b/stdlib/source/test/lux/world/file.lux index b59202972..002d76c42 100644 --- a/stdlib/source/test/lux/world/file.lux +++ b/stdlib/source/test/lux/world/file.lux @@ -35,40 +35,40 @@ (let [millis +1,000] (|>> (i./ millis) (i.* millis)))) -(def: (creation_and_deletion number) - (-> Nat Test) - (random\wrap - (do promise.monad - [#let [path (format "temp_file_" (%.nat number))] - result (promise.future - (do (try.with io.monad) - [#let [check_existence! (: (IO (Try Bit)) - (try.lift io.monad (/.exists? io.monad /.default path)))] - pre! check_existence! - file (!.use (\ /.default create_file) path) - post! check_existence! - _ (!.use (\ file delete) []) - remains? check_existence!] - (wrap (and (not pre!) - post! - (not remains?)))))] - (_.assert "Can create/delete files." - (try.default #0 result))))) +## (def: (creation_and_deletion number) +## (-> Nat Test) +## (random\wrap +## (do promise.monad +## [#let [path (format "temp_file_" (%.nat number))] +## result (promise.future +## (do (try.with io.monad) +## [#let [check_existence! (: (IO (Try Bit)) +## (try.lift io.monad (/.exists? io.monad /.default path)))] +## pre! check_existence! +## file (!.use (\ /.default create_file) path) +## post! check_existence! +## _ (!.use (\ file delete) []) +## remains? check_existence!] +## (wrap (and (not pre!) +## post! +## (not remains?)))))] +## (_.assert "Can create/delete files." +## (try.default #0 result))))) -(def: (read_and_write number data) - (-> Nat Binary Test) - (random\wrap - (do promise.monad - [#let [path (format "temp_file_" (%.nat number))] - result (promise.future - (do (try.with io.monad) - [file (!.use (\ /.default create_file) path) - _ (!.use (\ file over_write) data) - content (!.use (\ file content) []) - _ (!.use (\ file delete) [])] - (wrap (\ binary.equivalence = data content))))] - (_.assert "Can write/read files." - (try.default #0 result))))) +## (def: (read_and_write number data) +## (-> Nat Binary Test) +## (random\wrap +## (do promise.monad +## [#let [path (format "temp_file_" (%.nat number))] +## result (promise.future +## (do (try.with io.monad) +## [file (!.use (\ /.default create_file) path) +## _ (!.use (\ file over_write) data) +## content (!.use (\ file content) []) +## _ (!.use (\ file delete) [])] +## (wrap (\ binary.equivalence = data content))))] +## (_.assert "Can write/read files." +## (try.default #0 result))))) (def: #export test Test |