diff options
Diffstat (limited to '')
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))) |