aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2021-05-24 11:23:40 -0400
committerEduardo Julian2021-05-24 11:23:40 -0400
commit86538182a50390e7882778cc02e69482e846edd5 (patch)
tree5f2b5800d4f9bd63355d78bc541110aaf0c6b134
parent20a3f2650e2e72b5f4e525bee8a6354a711f575b (diff)
Almost done with Scheme.
But will have to postpone finishing it because Kawa is not up to snuff.
-rw-r--r--lux-scheme/commands.md8
-rw-r--r--lux-scheme/source/program.lux53
-rw-r--r--stdlib/source/lux/control/concurrency/atom.lux9
-rw-r--r--stdlib/source/lux/control/thread.lux3
-rw-r--r--stdlib/source/lux/data/binary.lux57
-rw-r--r--stdlib/source/lux/data/collection/array.lux15
-rw-r--r--stdlib/source/lux/data/text/encoding.lux17
-rw-r--r--stdlib/source/lux/debug.lux90
-rw-r--r--stdlib/source/lux/host.scm.lux219
-rw-r--r--stdlib/source/lux/math.lux32
-rw-r--r--stdlib/source/lux/target/scheme.lux137
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux172
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/analysis/scheme.lux122
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux9
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/common.lux243
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/generation/scheme/host.lux68
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/python/runtime.lux33
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/case.lux83
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/function.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/scheme/runtime.lux313
-rw-r--r--stdlib/source/lux/tool/compiler/meta/packager/script.lux9
-rw-r--r--stdlib/source/lux/world/file.lux3
-rw-r--r--stdlib/source/lux/world/program.lux31
-rw-r--r--stdlib/source/program/compositor.lux40
-rw-r--r--stdlib/source/test/lux/extension.lux6
-rw-r--r--stdlib/source/test/lux/host.scm.lux24
-rw-r--r--stdlib/source/test/lux/world/file.lux66
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