aboutsummaryrefslogtreecommitdiff
path: root/new-luxc
diff options
context:
space:
mode:
authorEduardo Julian2018-02-23 00:42:23 -0400
committerEduardo Julian2018-02-23 00:42:23 -0400
commitc8e2898611fa759cbe7c2ac84738b5b403575664 (patch)
tree24d8ccebc1b6e32e55964726f016432ff3815958 /new-luxc
parentc8cda71ba02ab0986e3d4d839088aabdd02b37fa (diff)
- Added all the missing tests for translation of common procedures.
- Implemented some missing process functionality in the JVM runtime. - Minor bug fixes.
Diffstat (limited to '')
-rw-r--r--new-luxc/source/luxc/lang/host.jvm.lux1
-rw-r--r--new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux4
-rw-r--r--new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux18
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux41
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux99
-rw-r--r--new-luxc/test/test/luxc/lang/translation/common.lux471
6 files changed, 586 insertions, 48 deletions
diff --git a/new-luxc/source/luxc/lang/host.jvm.lux b/new-luxc/source/luxc/lang/host.jvm.lux
index 4b2dced82..f22bf3302 100644
--- a/new-luxc/source/luxc/lang/host.jvm.lux
+++ b/new-luxc/source/luxc/lang/host.jvm.lux
@@ -182,4 +182,5 @@
(def: #export runtime-class Text "LuxRuntime")
(def: #export function-class Text "LuxFunction")
+(def: #export runnable-class Text "LuxRunnable")
(def: #export unit Text "\u0000")
diff --git a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux
index 685043b83..efef6084c 100644
--- a/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/procedure/common.jvm.lux
@@ -398,7 +398,7 @@
## [[IO]]
(def: (io//log messageJS)
Unary
- (void (format "console.log(" messageJS ")")))
+ (void (format runtimeT.io//log "(" messageJS ")")))
(def: (io//error messageJS)
Unary
@@ -425,7 +425,7 @@
(def: (atom//read atomJS)
Unary
- (format atomJS "." runtimeT.atom-field))
+ (format (self-contained atomJS) "." runtimeT.atom-field))
(def: (atom//compare-and-swap [atomJS oldJS newJS])
Trinary
diff --git a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
index 8c33b2a82..70f648be1 100644
--- a/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/js/runtime.jvm.lux
@@ -1018,15 +1018,13 @@
(runtime: text//char "textChar"
(format "(function " @ "(text,idx) {"
- "var result = text.charAt(idx.L);"
- (format "if(result === '') {"
+ "var result = text.charCodeAt(idx.L);"
+ (format "if(result === NaN) {"
(format "return " none ";")
"}"
"else {"
- (format "return " (some "{'C':result}") ";")
+ (format "return " (some (format int//from-number "(result)")) ";")
"}")
- "var reEscaped = toFind.replace(/[.*+?^${}()|[\\]\\\\]/g, '\\\\$&');"
- "return text.replace(new RegExp(reEscaped, 'g'), replaceWith);"
"})"))
(runtime: text//hash "textHash"
@@ -1076,6 +1074,13 @@
__array//put
__array//remove))
+(runtime: io//log "log"
+ (format "(function " @ "(message) {"
+ "if(typeof console !== \"undefined\" && console.log) { console.log(message); }"
+ "else if(typeof print !== \"undefined\") { print(message); }"
+ "return " unit ";"
+ "})"))
+
(runtime: io//error "error"
(format "(function " @ "(message) {"
"throw new Error(message);"
@@ -1083,7 +1088,8 @@
(def: runtime//io
Runtime
- (format __io//error))
+ (format __io//log
+ __io//error))
(def: #export atom-field Text "V")
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux
index 57455e1e1..5ce483730 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux
@@ -434,29 +434,24 @@
)
(def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list)))
-(do-template [<name> <method>]
- [(def: (<name> [textI partI startI])
- Trinary
- (<| $i.with-label (function [@not-found])
- $i.with-label (function [@end])
- (|>> textI ($i.CHECKCAST "java.lang.String")
- partI ($i.CHECKCAST "java.lang.String")
- startI jvm-intI
- ($i.INVOKEVIRTUAL "java.lang.String" <method> index-method false)
- $i.DUP
- ($i.int -1)
- ($i.IF_ICMPEQ @not-found)
- lux-intI
- runtimeT.someI
- ($i.GOTO @end)
- ($i.label @not-found)
- $i.POP
- runtimeT.noneI
- ($i.label @end))))]
-
- [text//index "indexOf"]
- [text//last-index "lastIndexOf"]
- )
+(def: (text//index [textI partI startI])
+ Trinary
+ (<| $i.with-label (function [@not-found])
+ $i.with-label (function [@end])
+ (|>> textI ($i.CHECKCAST "java.lang.String")
+ partI ($i.CHECKCAST "java.lang.String")
+ startI jvm-intI
+ ($i.INVOKEVIRTUAL "java.lang.String" "indexOf" index-method false)
+ $i.DUP
+ ($i.int -1)
+ ($i.IF_ICMPEQ @not-found)
+ lux-intI
+ runtimeT.someI
+ ($i.GOTO @end)
+ ($i.label @not-found)
+ $i.POP
+ runtimeT.noneI
+ ($i.label @end))))
## [[Math]]
(def: math-unary-method ($t.method (list $t.double) (#.Some $t.double) (list)))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux
index 87a47f338..2cd1c75a9 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux
@@ -26,6 +26,8 @@
(def: #export $Datum $.Type $Object)
(def: #export $Function $.Type ($t.class hostL.function-class (list)))
(def: $Throwable $.Type ($t.class "java.lang.Throwable" (list)))
+(def: $Runtime $.Type ($t.class "java.lang.Runtime" (list)))
+(def: $Runnable $.Type ($t.class "java.lang.Runnable" (list)))
(def: #export logI
$.Inst
@@ -549,6 +551,69 @@
$i.ARETURN)))
)))
+(def: process-methods
+ $.Def
+ (let [executor-class "java.util.concurrent.ScheduledThreadPoolExecutor"
+ executorT ($t.class executor-class (list))
+ executor-field "executor"
+ endI (|>> ($i.string hostL.unit)
+ $i.ARETURN)
+ runnableI (: (-> $.Inst $.Inst)
+ (function [functionI]
+ (|>> ($i.NEW hostL.runnable-class)
+ $i.DUP
+ functionI
+ ($i.INVOKESPECIAL hostL.runnable-class "<init>" ($t.method (list $Function) #.None (list)) false))))
+ threadI (: (-> $.Inst $.Inst)
+ (function [runnableI]
+ (|>> ($i.NEW "java.lang.Thread")
+ $i.DUP
+ runnableI
+ ($i.INVOKESPECIAL "java.lang.Thread" "<init>" ($t.method (list $Runnable) #.None (list)) false))))]
+ (|>> ($d.field #$.Public ($.++F $.finalF $.staticF) executor-field executorT)
+ ($d.method #$.Public $.staticM "<clinit>" ($t.method (list) #.None (list))
+ (let [concurrency-levelI (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some $Runtime) (list)) false)
+ ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) false))
+ executorI (|>> ($i.NEW executor-class)
+ $i.DUP
+ concurrency-levelI
+ ($i.INVOKESPECIAL executor-class "<init>" ($t.method (list $t.int) #.None (list)) false))]
+ (|>> executorI
+ ($i.PUTSTATIC hostL.runtime-class executor-field executorT)
+ $i.RETURN)))
+ ($d.method #$.Public $.staticM "future"
+ ($t.method (list $Function) (#.Some $Object) (list))
+ (|>> (threadI (runnableI ($i.ALOAD +0)))
+ ($i.INVOKEVIRTUAL "java.lang.Thread" "start" ($t.method (list) #.None (list)) false)
+ endI))
+ ($d.method #$.Public $.staticM "schedule"
+ ($t.method (list $t.long $Function) (#.Some $Object) (list))
+ (let [delayI ($i.LLOAD +0)
+ immediacy-checkI (|>> delayI
+ ($i.long 0)
+ $i.LCMP)
+ time-unit-class "java.util.concurrent.TimeUnit"
+ time-unitT ($t.class time-unit-class (list))
+ futureT ($t.class "java.util.concurrent.ScheduledFuture" (list))
+ executorI ($i.GETSTATIC hostL.runtime-class executor-field executorT)
+ schedule-laterI (|>> executorI
+ (runnableI ($i.ALOAD +2))
+ delayI
+ ($i.GETSTATIC time-unit-class "MILLISECONDS" time-unitT)
+ ($i.INVOKEVIRTUAL executor-class "schedule" ($t.method (list $Runnable $t.long time-unitT) (#.Some futureT) (list)) false))
+ schedule-immediatelyI (|>> executorI
+ (runnableI ($i.ALOAD +2))
+ ($i.INVOKEVIRTUAL executor-class "execute" ($t.method (list $Runnable) #.None (list)) false))]
+ (<| $i.with-label (function [@immediately])
+ (|>> immediacy-checkI
+ ($i.IFEQ @immediately)
+ schedule-laterI
+ endI
+ ($i.label @immediately)
+ schedule-immediatelyI
+ endI))))
+ )))
+
(def: translate-runtime
(Meta commonT.Bytecode)
(do macro.Monad<Meta>
@@ -560,7 +625,8 @@
deg-methods
text-methods
pm-methods
- io-methods))]
+ io-methods
+ process-methods))]
_ (commonT.store-class hostL.runtime-class bytecode)]
(wrap bytecode)))
@@ -595,9 +661,34 @@
_ (commonT.store-class hostL.function-class bytecode)]
(wrap bytecode)))
+(def: translate-runnable
+ (Meta commonT.Bytecode)
+ (do macro.Monad<Meta>
+ [_ (wrap [])
+ #let [procedure-field "procedure"
+ bytecode ($d.class #$.V1_6 #$.Public $.finalC hostL.runnable-class (list) ["java.lang.Object" (list)] (list ["java.lang.Runnable" (list)])
+ (|>> ($d.field #$.Public $.finalF procedure-field $Function)
+ ($d.method #$.Public $.noneM "<init>" ($t.method (list $Function) #.None (list))
+ (|>> ($i.ALOAD +0)
+ ($i.INVOKESPECIAL "java.lang.Object" "<init>" ($t.method (list) #.None (list)) false)
+ ($i.ALOAD +0)
+ ($i.ALOAD +1)
+ ($i.PUTFIELD hostL.runnable-class procedure-field $Function)
+ $i.RETURN))
+ ($d.method #$.Public $.noneM "run" ($t.method (list) #.None (list))
+ (|>> ($i.ALOAD +0)
+ ($i.GETFIELD hostL.runnable-class procedure-field $Function)
+ $i.NULL
+ ($i.INVOKEVIRTUAL hostL.function-class apply-method (apply-signature +1) false)
+ $i.RETURN))
+ ))]
+ _ (commonT.store-class hostL.runnable-class bytecode)]
+ (wrap bytecode)))
+
(def: #export translate
- (Meta [commonT.Bytecode commonT.Bytecode])
+ (Meta [commonT.Bytecode commonT.Bytecode commonT.Bytecode])
(do macro.Monad<Meta>
[runtime-bc translate-runtime
- function-bc translate-function]
- (wrap [runtime-bc function-bc])))
+ function-bc translate-function
+ runnable-bc translate-runnable]
+ (wrap [runtime-bc function-bc runnable-bc])))
diff --git a/new-luxc/test/test/luxc/lang/translation/common.lux b/new-luxc/test/test/luxc/lang/translation/common.lux
index 7e46abfda..d3f1e9cf4 100644
--- a/new-luxc/test/test/luxc/lang/translation/common.lux
+++ b/new-luxc/test/test/luxc/lang/translation/common.lux
@@ -17,7 +17,7 @@
[host]
test)
(luxc [lang]
- (lang ["ls" synthesis]
+ (lang [synthesis #+ Synthesis]
(translation (jvm [".T_jvm" eval]
[".T_jvm" expression]
[".T_jvm" runtime])
@@ -28,7 +28,7 @@
(def: (bit-spec translate-expression eval translate-runtime init)
(All [a]
- (-> (-> ls.Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
+ (-> (-> Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
Test))
(do r.Monad<Random>
[param r.nat
@@ -90,7 +90,7 @@
(def: (nat-spec translate-expression eval translate-runtime init)
(All [a]
- (-> (-> ls.Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
+ (-> (-> Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
Test))
(do r.Monad<Random>
[param (|> r.nat (r.filter (|>> (n/= +0) not)))
@@ -157,7 +157,7 @@
(def: (int-spec translate-expression eval translate-runtime init)
(All [a]
- (-> (-> ls.Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
+ (-> (-> Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
Test))
(do r.Monad<Random>
[param (|> r.int (r.filter (|>> (i/= 0) not)))
@@ -226,7 +226,7 @@
(def: (frac-spec|0 translate-expression eval translate-runtime init)
(All [a]
- (-> (-> ls.Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
+ (-> (-> Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
Test))
(do r.Monad<Random>
[param (|> r.frac (r.filter (|>> (f/= 0.0) not)))
@@ -259,7 +259,7 @@
(def: (frac-spec|1 translate-expression eval translate-runtime init)
(All [a]
- (-> (-> ls.Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
+ (-> (-> Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
Test))
(do r.Monad<Random>
[param (|> r.frac (r.filter (|>> (f/= 0.0) not)))
@@ -321,7 +321,7 @@
(def: (frac-spec translate-expression eval translate-runtime init)
(All [a]
- (-> (-> ls.Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
+ (-> (-> Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
Test))
($_ seq
(frac-spec|0 translate-expression eval translate-runtime init)
@@ -346,7 +346,7 @@
(def: (deg-spec translate-expression eval translate-runtime init)
(All [a]
- (-> (-> ls.Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
+ (-> (-> Synthesis (Meta a)) (-> a (Meta Top)) (Meta Top) (IO Compiler)
Test))
(do r.Monad<Random>
[param (|> r.deg (:: @ map above-threshold))
@@ -427,6 +427,387 @@
))
))))
+(def: lower-alpha
+ (r.Random Nat)
+ (|> r.nat (:: r.Functor<Random> map (|>> (n/% +26) (n/+ +97)))))
+
+(def: upper-alpha
+ (r.Random Nat)
+ (|> r.nat (:: r.Functor<Random> map (|>> (n/% +26) (n/+ +65)))))
+
+(def: alpha
+ (r.Random Nat)
+ (r.either lower-alpha
+ upper-alpha))
+
+(def: (text-spec run)
+ (-> (-> Synthesis (e.Error Top)) Test)
+ (do r.Monad<Random>
+ [sample-size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
+ sample0 (r.text' lower-alpha sample-size)
+ sample1 (r.text' upper-alpha sample-size)
+ sample2 (|> (r.text' alpha sample-size)
+ (r.filter (|>> (text/= sample1) not)))
+ char-idx (|> r.nat (:: @ map (n/% sample-size)))
+ #let [sample0S (code.text sample0)
+ sample1S (code.text sample1)
+ sample2S (code.text sample2)
+ concatenatedS (` ("lux text concat" (~ sample0S) (~ sample1S)))
+ pre-rep-once (format sample0 sample1)
+ post-rep-once (format sample0 sample2)
+ pre-rep-all (|> (list.repeat sample-size sample0) (text.join-with sample1))
+ post-rep-all (|> (list.repeat sample-size sample0) (text.join-with sample2))]]
+ ($_ seq
+ (test "Can compare texts for equality."
+ (and (|> (run (` ("lux text =" (~ sample0S) (~ sample0S))))
+ (case> (#e.Success valueV)
+ (:! Bool valueV)
+
+ _
+ false))
+ (|> (run (` ("lux text =" (~ sample0S) (~ sample1S))))
+ (case> (#e.Success valueV)
+ (not (:! Bool valueV))
+
+ _
+ false))))
+ (test "Can compare texts for order."
+ (|> (run (` ("lux text <" (~ sample1S) (~ sample0S))))
+ (case> (#e.Success valueV)
+ (:! Bool valueV)
+
+ _
+ false)))
+ (test "Can change case of text."
+ (and (|> (run (` ("lux text =" (~ sample0S) ("lux text upper" (~ sample0S)))))
+ (case> (#e.Success valueV)
+ (not (:! Bool valueV))
+
+ _
+ false))
+ (|> (run (` ("lux text =" (~ sample0S) ("lux text lower" ("lux text upper" (~ sample0S))))))
+ (case> (#e.Success valueV)
+ (:! Bool valueV)
+
+ _
+ false))))
+ (test "Can get length of text."
+ (|> (run (` ("lux text size" (~ sample0S))))
+ (case> (#e.Success valueV)
+ (n/= sample-size (:! Nat valueV))
+
+ _
+ false)))
+ (test "Can concatenate text."
+ (|> (run (` ("lux text size" (~ concatenatedS))))
+ (case> (#e.Success valueV)
+ (n/= (n/* +2 sample-size) (:! Nat valueV))
+
+ _
+ false)))
+ (test "Can find index of sub-text."
+ (and (|> (run (` ("lux text index" (~ concatenatedS) (~ sample0S) +0)))
+ (case> (^multi (#e.Success valueV)
+ [(:! (Maybe Nat) valueV) (#.Some valueV)])
+ (n/= +0 valueV)
+
+ _
+ false))
+ (|> (run (` ("lux text index" (~ concatenatedS) (~ sample1S) +0)))
+ (case> (^multi (#e.Success valueV)
+ [(:! (Maybe Nat) valueV) (#.Some valueV)])
+ (n/= sample-size valueV)
+
+ _
+ false))))
+ (test "Text hashing is consistent."
+ (|> (run (` ("lux nat =" ("lux text hash" (~ sample0S)) ("lux text hash" (~ sample0S)))))
+ (case> (#e.Success valueV)
+ (:! Bool valueV)
+
+ _
+ false)))
+ (test "Can replace sub-text once."
+ (|> (run (` ("lux text ="
+ (~ (code.text post-rep-once))
+ ("lux text replace-once"
+ (~ (code.text pre-rep-once))
+ (~ sample1S)
+ (~ sample2S)))))
+ (case> (#e.Success valueV)
+ (:! Bool valueV)
+
+ _
+ false)))
+ (test "Can replace sub-text all times."
+ (|> (run (` ("lux text ="
+ (~ (code.text post-rep-all))
+ ("lux text replace-all"
+ (~ (code.text pre-rep-all))
+ (~ sample1S)
+ (~ sample2S)))))
+ (case> (#e.Success valueV)
+ (:! Bool valueV)
+
+ _
+ false)))
+ (let [test-clip (function [from to expected]
+ (|> (run (` ("lux text clip"
+ (~ concatenatedS)
+ (~ (code.nat from))
+ (~ (code.nat to)))))
+ (case> (^multi (#e.Success valueV)
+ [(:! (Maybe Text) valueV) (#.Some valueV)])
+ (text/= expected valueV)
+
+ _
+ false)))]
+ (test "Can clip text to extract sub-text."
+ (and (test-clip +0 sample-size sample0)
+ (test-clip sample-size (n/* +2 sample-size) sample1))))
+ (test "Can extract individual characters from text."
+ (|> (run (` ("lux text char"
+ (~ sample0S)
+ (~ (code.nat char-idx)))))
+ (case> (^multi (#e.Success valueV)
+ [(:! (Maybe Nat) valueV) (#.Some valueV)])
+ (text.contains? ("lux nat char" valueV)
+ sample0)
+
+ _
+ false)))
+ )))
+
+(def: (array-spec run)
+ (-> (-> Synthesis (e.Error Top)) Test)
+ (do r.Monad<Random>
+ [size (|> r.nat (:: @ map (|>> (n/% +10) (n/max +1))))
+ idx (|> r.nat (:: @ map (n/% size)))
+ value r.nat
+ #let [array0S (` ("lux array new" (~ (code.nat size))))
+ array1S (` ("lux array put" (~ array0S) (~ (code.nat idx)) (~ (code.nat value))))]]
+ ($_ seq
+ (test "Can get size of array."
+ (|> (run (` ("lux array size" (~ array0S))))
+ (case> (#e.Success valueV)
+ (n/= size (:! Nat valueV))
+
+ _
+ false)))
+ (test "Can get element from array (if it exists)."
+ (and (|> (run (` ("lux array get" (~ array0S) (~ (code.nat idx)))))
+ (case> (^multi (#e.Success valueV)
+ [(:! (Maybe Nat) valueV) #.None])
+ true
+
+ _
+ false))
+ (|> (run (` ("lux array get" (~ array1S) (~ (code.nat idx)))))
+ (case> (^multi (#e.Success valueV)
+ [(:! (Maybe Nat) valueV) (#.Some valueV)])
+ (n/= value valueV)
+
+ _
+ false))))
+ (test "Can remove element from array."
+ (|> (run (` ("lux array get"
+ ("lux array remove" (~ array1S)
+ (~ (code.nat idx)))
+ (~ (code.nat idx)))))
+ (case> (^multi (#e.Success valueV)
+ [(:! (Maybe Nat) valueV) #.None])
+ true
+
+ _
+ false)))
+ )))
+
+(def: (math-spec run)
+ (-> (-> Synthesis (e.Error Top)) Test)
+ (do r.Monad<Random>
+ [subject r.frac
+ param r.frac]
+ (`` ($_ seq
+ (~~ (do-template [<name>]
+ [(test (format "Can apply '" <name> "' procedure.")
+ (|> (run (` (<name> (~ (code.frac subject)))))
+ (case> (#e.Success valueV)
+ true
+
+ (#e.Error error)
+ false)))]
+
+ ["lux math cos"]
+ ["lux math sin"]
+ ["lux math tan"]
+ ["lux math acos"]
+ ["lux math asin"]
+ ["lux math atan"]
+ ["lux math cosh"]
+ ["lux math sinh"]
+ ["lux math tanh"]
+ ["lux math exp"]
+ ["lux math log"]
+ ["lux math root2"]
+ ["lux math root3"]
+ ["lux math ceil"]
+ ["lux math floor"]
+ ["lux math round"]))
+ (~~ (do-template [<name>]
+ [(test (format "Can apply '" <name> "' procedure.")
+ (|> (run (` (<name> (~ (code.frac subject)) (~ (code.frac param)))))
+ (case> (#e.Success valueV)
+ true
+
+ (#e.Error error)
+ false)))]
+
+ ["lux math atan2"]
+ ["lux math pow"]))
+ ))))
+
+(def: (io-spec run)
+ (-> (-> Synthesis (e.Error Top)) Test)
+ (do r.Monad<Random>
+ [message (r.text +5)]
+ ($_ seq
+ (test "Can log messages."
+ (|> (run (` ("lux io log" (~ (code.text (format "LOG: " message))))))
+ (case> (#e.Success valueV)
+ true
+
+ (#e.Error error)
+ false)))
+ (test "Can throw runtime errors."
+ (and (|> (run (` ("lux try" ("lux function" +1 []
+ ("lux io error" (~ (code.text message)))))))
+ (case> (^multi (#e.Success valueV)
+ [(:! (e.Error Text) valueV) (#e.Error error)])
+ (text.contains? message error)
+
+ _
+ false))
+ (|> (run (` ("lux try" ("lux function" +1 []
+ (~ (code.text message))))))
+ (case> (^multi (#e.Success valueV)
+ [(:! (e.Error Text) valueV) (#e.Success valueV)])
+ (text/= message valueV)
+
+ _
+ false))))
+ (test "Can obtain current time in milli-seconds."
+ (|> (run (` [("lux io current-time") ("lux io current-time")]))
+ (case> (#e.Success valueV)
+ (let [[pre post] (:! [Nat Nat] valueV)]
+ (n/>= pre post))
+
+ (#e.Error error)
+ false)))
+ )))
+
+(def: (atom-spec run)
+ (-> (-> Synthesis (e.Error Top)) Test)
+ (do r.Monad<Random>
+ [pre r.nat
+ post (|> r.nat (r.filter (|>> (n/= pre) not)))
+ #let [preS (code.nat pre)
+ postS (code.nat post)
+ atomS (` ("lux atom new" (~ preS)))]]
+ ($_ seq
+ (test "Can read atoms."
+ (|> (run (` ("lux atom read" (~ atomS))))
+ (case> (#e.Success valueV)
+ (n/= pre (:! Nat valueV))
+
+ (#e.Error error)
+ false)))
+ (test "Can compare-and-swap atoms."
+ (and (|> (run (` ("lux let" +0 (~ preS)
+ ("lux let" +1 ("lux atom new" (0))
+ [("lux atom compare-and-swap" (1) (0) (~ postS))
+ ("lux atom read" (1))]))))
+ (case> (#e.Success valueV)
+ (let [[swapped? current-value] (:! [Bool Nat] valueV)]
+ (and swapped?
+ (n/= post current-value)))
+
+ (#e.Error error)
+ false))
+ (|> (run (` ("lux let" +0 (~ preS)
+ ("lux let" +1 ("lux atom new" (0))
+ [("lux atom compare-and-swap" (1) (~ postS) (~ postS))
+ ("lux atom read" (1))]))))
+ (case> (#e.Success valueV)
+ (let [[swapped? current-value] (:! [Bool Nat] valueV)]
+ (and (not swapped?)
+ (n/= pre current-value)))
+
+ (#e.Error error)
+ false))))
+ )))
+
+(def: (box-spec run)
+ (-> (-> Synthesis (e.Error Top)) Test)
+ (do r.Monad<Random>
+ [pre r.nat
+ post (|> r.nat (r.filter (|>> (n/= pre) not)))
+ #let [preS (code.nat pre)
+ postS (code.nat post)
+ boxS (` ("lux box new" (~ preS)))]]
+ ($_ seq
+ (test "Can read boxes."
+ (|> (run (` ("lux box read" (~ boxS))))
+ (case> (#e.Success valueV)
+ (n/= pre (:! Nat valueV))
+
+ (#e.Error error)
+ false)))
+ (test "Can write boxes."
+ (|> (run (` ("lux let" +0 (~ boxS)
+ ("lux let" +1 ("lux box write" (~ postS) (0))
+ ("lux box read" (0))))))
+ (case> (#e.Success valueV)
+ (n/= post (:! Nat valueV))
+
+ (#e.Error error)
+ false)))
+ )))
+
+(def: (process-spec run)
+ (-> (-> Synthesis (e.Error Top)) Test)
+ ($_ seq
+ (test "Can query the concurrency level of the machine."
+ (|> (run (` ("lux process concurrency-level")))
+ (case> (#e.Success valueV)
+ (n/>= +1 (:! Nat valueV))
+
+ (#e.Error error)
+ false)))
+ (do r.Monad<Random>
+ [delay (|> r.nat (:: @ map (n/% +10)))
+ message (r.text +5)]
+ ($_ seq
+ (test "Can execute I/O operations in parallel."
+ (|> (run (` ("lux process future"
+ ("lux function" +1 []
+ ("lux io log" (~ (code.text (format "EXECUTE: " message))))))))
+ (case> (#e.Success valueV)
+ true
+
+ (#e.Error error)
+ false)))
+ (test "Can schedule I/O operations for future execution."
+ (|> (run (` ("lux process schedule"
+ (~ (code.nat delay))
+ ("lux function" +1 []
+ ("lux io log" (~ (code.text (format "SCHEDULE: " message))))))))
+ (case> (#e.Success valueV)
+ true
+
+ (#e.Error error)
+ false)))
+ ))))
+
## Bit
(context: "[JVM] Bit procedures"
(<| (times +100)
@@ -454,6 +835,15 @@
(<| (times +100)
(int-spec expressionT_js.translate evalT_js.eval runtimeT_js.translate init-js)))
+## Deg
+(context: "[JVM] Deg procedures"
+ (<| (times +100)
+ (deg-spec expressionT_jvm.translate evalT_jvm.eval runtimeT_jvm.translate init-jvm)))
+
+(context: "[JS] Deg procedures"
+ (<| (times +100)
+ (deg-spec expressionT_js.translate evalT_js.eval runtimeT_js.translate init-js)))
+
## Frac
(context: "[JVM] Frac procedures"
(<| (times +100)
@@ -463,11 +853,66 @@
(<| (times +100)
(frac-spec expressionT_js.translate evalT_js.eval runtimeT_js.translate init-js)))
-## Deg
-(context: "[JVM] Deg procedures"
+## Text
+(context: "[JVM] Text procedures"
+ (<| (seed +4439612689198907401)
+ ## (times +100)
+ (text-spec run-jvm)))
+
+(context: "[JS] Text procedures"
(<| (times +100)
- (deg-spec expressionT_jvm.translate evalT_jvm.eval runtimeT_jvm.translate init-jvm)))
+ (text-spec run-js)))
-(context: "[JS] Deg procedures"
+## Array
+(context: "[JVM] Array procedures"
(<| (times +100)
- (deg-spec expressionT_js.translate evalT_js.eval runtimeT_js.translate init-js)))
+ (array-spec run-jvm)))
+
+(context: "[JS] Array procedures"
+ (<| (times +100)
+ (array-spec run-js)))
+
+## Math
+(context: "[JVM] Math procedures"
+ (<| (times +100)
+ (math-spec run-jvm)))
+
+(context: "[JS] Math procedures"
+ (<| (times +100)
+ (math-spec run-js)))
+
+## I/O
+(context: "[JVM] I/O procedures"
+ (<| (times +100)
+ (io-spec run-jvm)))
+
+(context: "[JS] I/O procedures"
+ (<| (times +100)
+ (io-spec run-js)))
+
+## Atom
+(context: "[JVM] Atom procedures"
+ (<| (times +100)
+ (atom-spec run-jvm)))
+
+(context: "[JS] Atom procedures"
+ (<| (times +100)
+ (atom-spec run-js)))
+
+## Box
+(context: "[JVM] Box procedures"
+ (<| (times +100)
+ (box-spec run-jvm)))
+
+(context: "[JS] Box procedures"
+ (<| (times +100)
+ (box-spec run-js)))
+
+## Process
+(context: "[JVM] Process procedures"
+ (<| (times +100)
+ (process-spec run-jvm)))
+
+(context: "[JS] Process procedures"
+ (<| (times +100)
+ (process-spec run-js)))