aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/concurrency/promise.lux8
-rw-r--r--stdlib/source/lux/control/concurrency/stm.lux3
-rw-r--r--stdlib/source/lux/control/concurrency/thread.lux (renamed from stdlib/source/lux/control/concurrency/process.lux)22
-rw-r--r--stdlib/source/lux/control/parser/cli.lux4
-rw-r--r--stdlib/source/lux/control/security/capability.lux7
-rw-r--r--stdlib/source/lux/data/collection/queue/priority.lux8
-rw-r--r--stdlib/source/lux/test.lux15
-rw-r--r--stdlib/source/lux/world/shell.lux516
-rw-r--r--stdlib/source/spec/lux/world/shell.lux97
-rw-r--r--stdlib/source/test/lux/control.lux30
-rw-r--r--stdlib/source/test/lux/control/concurrency/thread.lux (renamed from stdlib/source/test/lux/control/concurrency/process.lux)0
-rw-r--r--stdlib/source/test/lux/control/security/policy.lux7
-rw-r--r--stdlib/source/test/lux/data/collection/queue/priority.lux102
-rw-r--r--stdlib/source/test/lux/type/check.lux8
-rw-r--r--stdlib/source/test/lux/world.lux4
-rw-r--r--stdlib/source/test/lux/world/shell.lux58
16 files changed, 657 insertions, 232 deletions
diff --git a/stdlib/source/lux/control/concurrency/promise.lux b/stdlib/source/lux/control/concurrency/promise.lux
index 3b6341cf1..017ad67a8 100644
--- a/stdlib/source/lux/control/concurrency/promise.lux
+++ b/stdlib/source/lux/control/concurrency/promise.lux
@@ -13,7 +13,7 @@
[type
abstract]]
[//
- ["." process]
+ ["." thread]
["." atom (#+ Atom atom)]])
(abstract: #export (Promise a)
@@ -156,19 +156,19 @@
left||right))))
(def: #export (schedule millis-delay computation)
- {#.doc (doc "Runs an I/O computation on its own process (after a specified delay)."
+ {#.doc (doc "Runs an I/O computation on its own thread (after a specified delay)."
"Returns a Promise that will eventually host its result.")}
(All [a] (-> Nat (IO a) (Promise a)))
(let [[!out resolve] (..promise [])]
(exec (|> (do io.monad
[value computation]
(resolve value))
- (process.schedule millis-delay)
+ (thread.schedule millis-delay)
io.run)
!out)))
(def: #export future
- {#.doc (doc "Runs an I/O computation on its own process."
+ {#.doc (doc "Runs an I/O computation on its own thread."
"Returns a Promise that will eventually host its result.")}
(All [a] (-> (IO a) (Promise a)))
(schedule 0))
diff --git a/stdlib/source/lux/control/concurrency/stm.lux b/stdlib/source/lux/control/concurrency/stm.lux
index 259511eb7..d5684cf97 100644
--- a/stdlib/source/lux/control/concurrency/stm.lux
+++ b/stdlib/source/lux/control/concurrency/stm.lux
@@ -127,8 +127,7 @@
(#.Cons {#var _var
#original _original
#current _current}
- (update-tx-value var value tx')))
- ))
+ (update-tx-value var value tx')))))
(def: #export (write value var)
{#.doc "Writes value to var."}
diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/thread.lux
index 5e1bf7c3c..55b635672 100644
--- a/stdlib/source/lux/control/concurrency/process.lux
+++ b/stdlib/source/lux/control/concurrency/thread.lux
@@ -61,7 +61,7 @@
(as-is (host.import: (setTimeout [host.Function host.Number] #io Any)))}
## Default
- (type: Process
+ (type: Thread
{#creation Nat
#delay Nat
#action (IO Any)})
@@ -95,7 +95,7 @@
## Default
(def: runner
- (Atom (List Process))
+ (Atom (List Thread))
(atom.atom (list))))
(def: #export (schedule milli-seconds action)
@@ -142,13 +142,13 @@
(as-is)}
## Default
- (as-is (exception: #export cannot-continue-running-processes)
+ (as-is (exception: #export cannot-continue-running-threads)
(def: #export (run! _)
(-> Any (IO Any))
(do {! io.monad}
- [processes (atom.read ..runner)]
- (case processes
+ [threads (atom.read ..runner)]
+ (case threads
## And... we're done!
#.Nil
(wrap [])
@@ -156,16 +156,16 @@
_
(do !
[#let [now (.nat ("lux io current-time"))
- [ready pending] (list.partition (function (_ process)
- (|> (get@ #creation process)
- (n.+ (get@ #delay process))
+ [ready pending] (list.partition (function (_ thread)
+ (|> (get@ #creation thread)
+ (n.+ (get@ #delay thread))
(n.<= now)))
- processes)]
- swapped? (atom.compare-and-swap processes pending ..runner)]
+ threads)]
+ swapped? (atom.compare-and-swap threads pending ..runner)]
(if swapped?
(do !
[_ (monad.map ! (get@ #action) ready)]
(run! []))
- (error! (ex.construct ..cannot-continue-running-processes []))))
+ (error! (ex.construct ..cannot-continue-running-threads []))))
)))
))
diff --git a/stdlib/source/lux/control/parser/cli.lux b/stdlib/source/lux/control/parser/cli.lux
index 08e20ca26..0c1910d2f 100644
--- a/stdlib/source/lux/control/parser/cli.lux
+++ b/stdlib/source/lux/control/parser/cli.lux
@@ -19,7 +19,7 @@
[//
["." io]
[concurrency
- ["." process]]]])
+ ["." thread]]]])
(type: #export (Parser a)
{#.doc "A command-line interface parser."}
@@ -152,7 +152,7 @@
@.js
(list)}
(list g!_
- (` ((~! process.run!) [])))))]
+ (` ((~! thread.run!) [])))))]
((~' wrap) (~ g!output))))]
(case args
(#Raw args)
diff --git a/stdlib/source/lux/control/security/capability.lux b/stdlib/source/lux/control/security/capability.lux
index e69493f69..cd9d7b202 100644
--- a/stdlib/source/lux/control/security/capability.lux
+++ b/stdlib/source/lux/control/security/capability.lux
@@ -12,7 +12,7 @@
[text
["%" format (#+ format)]]
[collection
- ["." list ("#;." functor)]]]
+ ["." list ("#@." functor)]]]
[type
abstract]
["." meta]
@@ -55,9 +55,8 @@
(wrap (list (` (type: (~+ (writer.export export))
(~ (writer.declaration declaration))
(~ capability)))
- (` (def: (~+ (writer.export export))
- (~ (code.local-identifier forge))
- (All [(~+ (list;map code.local-identifier vars))]
+ (` (def: (~ (code.local-identifier forge))
+ (All [(~+ (list@map code.local-identifier vars))]
(-> (-> (~ input) (~ output))
(~ capability)))
(~! ..forge)))
diff --git a/stdlib/source/lux/data/collection/queue/priority.lux b/stdlib/source/lux/data/collection/queue/priority.lux
index 50f6f7de6..555c7b8d3 100644
--- a/stdlib/source/lux/data/collection/queue/priority.lux
+++ b/stdlib/source/lux/data/collection/queue/priority.lux
@@ -44,7 +44,11 @@
(#finger.Branch _ left right)
(n.+ (recur left) (recur right))))))
-(def: #export (member? Equivalence<a> queue member)
+(def: #export empty?
+ (All [a] (-> (Queue a) Bit))
+ (|>> ..size (n.= 0)))
+
+(def: #export (member? equivalence queue member)
(All [a] (-> (Equivalence a) (Queue a) a Bit))
(case queue
#.None
@@ -54,7 +58,7 @@
(loop [node (get@ #finger.node fingers)]
(case node
(#finger.Leaf _ reference)
- (:: Equivalence<a> = reference member)
+ (:: equivalence = reference member)
(#finger.Branch _ left right)
(or (recur left)
diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux
index dd00517d0..2f54866c0 100644
--- a/stdlib/source/lux/test.lux
+++ b/stdlib/source/lux/test.lux
@@ -69,17 +69,22 @@
(def: separator text.new-line)
+(def: #export (and' left right)
+ {#.doc "Sequencing combinator."}
+ (-> Assertion Assertion Assertion)
+ (do promise.monad
+ [[l-counter l-documentation] left
+ [r-counter r-documentation] right]
+ (wrap [(add-counters l-counter r-counter)
+ (format l-documentation ..separator r-documentation)])))
+
(def: #export (and left right)
{#.doc "Sequencing combinator."}
(-> Test Test Test)
(do random.monad
[left left
right right]
- (wrap (do promise.monad
- [[l-counter l-documentation] left
- [r-counter r-documentation] right]
- (wrap [(add-counters l-counter r-counter)
- (format l-documentation ..separator r-documentation)])))))
+ (wrap (..and' left right))))
(def: context-prefix text.tab)
diff --git a/stdlib/source/lux/world/shell.lux b/stdlib/source/lux/world/shell.lux
index f9f214562..47215c295 100644
--- a/stdlib/source/lux/world/shell.lux
+++ b/stdlib/source/lux/world/shell.lux
@@ -1,15 +1,21 @@
(.module:
[lux #*
- ["." io (#+ IO)]
+ ["@" target]
["jvm" host (#+ import:)]
[abstract
- ["." enum]]
+ [monad (#+ do)]]
[control
- [monad (#+ do)]
- ["." try (#+ Try)]]
+ ["." function]
+ ["." try (#+ Try)]
+ ["." io (#+ IO)]
+ [security
+ ["!" capability (#+ capability:)]
+ ["?" policy (#+ Safety Safe)]]
+ [concurrency
+ ["." stm (#+ Var STM)]
+ ["." promise (#+ Promise) ("#@." monad)]]]
[data
["." product]
- ["." maybe]
[number (#+ hex)
["n" nat]]
["." text
@@ -19,146 +25,366 @@
["." context (#+ Context)]]
[collection
["." array (#+ Array)]
- ["." list ("#;." fold functor)]
- ["." dictionary]]]
- [tool
- [compiler
- ["." host]]]
- [world
- ["." console (#+ Console)]]])
+ ["." list ("#@." fold functor)]
+ ["." dictionary]]]])
-## https://en.wikipedia.org/wiki/Code_injection#Shell_injection
-(def: windows?
- (-> Text Bit)
- (text.starts-with? "windows"))
-
-(def: (sanitize-command windows?)
- (-> Bit (-> Text Text))
- (let [dangerous (format "\&#;`|*?~<>^()[]{}$"
- (text.from-code (hex "0A"))
- (text.from-code (hex "FF")))
- dangerous (if windows?
- (format dangerous "%!")
- dangerous)
- indices (enum.range n.enum 0 (dec (text.size dangerous)))]
- (function (_ unsafe)
- (list;fold (function (_ index safer)
- (let [bad (|> dangerous (text.nth index) maybe.assume text.from-code)
- good (if windows?
- " "
- (format "\" bad))]
- (text.replace-all bad good safer)))
- unsafe
- indices))))
-
-(def: (sanitize-argument windows?)
- (-> Bit (-> Text Text))
- (if windows?
- (|>> (text.replace-all "%" " ")
- (text.replace-all "!" " ")
- (text.replace-all text.double-quote " ")
- (text.enclose' text.double-quote))
- (|>> (text.replace-all "'" "\'")
- (text.enclose' "'"))))
-
-(`` (for {(~~ (static host.old))
- (as-is (import: java/lang/String
- (toLowerCase [] java/lang/String))
-
- (def: (arguments-array arguments)
- (-> (List Text) (Array java/lang/String))
- (product.right
- (list;fold (function (_ argument [idx output])
- [(inc idx) (jvm.array-write idx argument output)])
- [0 (jvm.array java/lang/String (list.size arguments))]
- arguments)))
-
- (import: (java/util/Map k v)
- (put [k v] v))
-
- (def: (load-environment input target)
- (-> Context
- (java/util/Map java/lang/String java/lang/String)
- (java/util/Map java/lang/String java/lang/String))
- (list;fold (function (_ [key value] target')
- (exec (java/util/Map::put key value target')
- target'))
- target
- (dictionary.entries input)))
-
- (import: java/io/Reader
- (read [] #io #try int))
-
- (import: java/io/BufferedReader
- (new [java/io/Reader])
- (readLine [] #io #try java/lang/String))
-
- (import: java/io/InputStream)
-
- (import: java/io/InputStreamReader
- (new [java/io/InputStream]))
-
- (import: java/io/OutputStream
- (write [[byte]] #io #try void))
-
- (import: java/lang/Process
- (getInputStream [] #io #try java/io/InputStream)
- (getOutputStream [] #io #try java/io/OutputStream)
- (destroy [] #io #try void))
-
- (def: (process-console process)
- (-> java/lang/Process (IO (Try (Console IO))))
- (do (try.with io.monad)
- [jvm-input (java/lang/Process::getInputStream process)
- #let [jvm-input (|> jvm-input
- java/io/InputStreamReader::new
- java/io/BufferedReader::new)]
- jvm-output (java/lang/Process::getOutputStream process)]
- (wrap (: (Console IO)
- (structure
- (def: can-read
- (console.can-read
- (function (_ _)
- (|> jvm-input
- java/io/Reader::read
- (:: (try.with io.monad) map .nat)))))
-
- (def: can-read-line
- (console.can-read
- (function (_ _)
- (|> jvm-input
- java/io/BufferedReader::readLine))))
+(capability: #export (Can-Read !)
+ (can-read [] (! (Try Text))))
+
+(capability: #export (Can-Write !)
+ (can-write Text (! (Try Any))))
+
+(capability: #export (Can-Destroy !)
+ (can-destroy [] (! (Try Any))))
+
+(type: #export Exit
+ Int)
+
+(def: #export normal
+ Exit
+ +0)
+
+(capability: #export (Can-Wait !)
+ (can-wait [] (! (Try Exit))))
+
+(signature: #export (Process !)
+ (: (Can-Read !)
+ read)
+ (: (Can-Read !)
+ error)
+ (: (Can-Write !)
+ write)
+ (: (Can-Destroy !)
+ destroy)
+ (: (Can-Wait !)
+ await))
+
+(def: (async-process process)
+ (-> (Process IO) (Process Promise))
+ (`` (structure
+ (~~ (template [<method> <capability>]
+ [(def: <method>
+ (<capability>
+ (|>> (!.use (:: process <method>))
+ promise.future)))]
+
+ [read ..can-read]
+ [error ..can-read]
+ [write ..can-write]
+ [destroy ..can-destroy]
+ [await ..can-wait]
+ )))))
+
+(type: #export Environment
+ Context)
+
+(type: #export Command
+ Text)
+
+(type: #export Argument
+ Text)
+
+(capability: #export (Can-Execute !)
+ (can-execute [Environment Command (List Argument)] (! (Try (Process !)))))
+
+(signature: #export (Shell !)
+ (: (Can-Execute !)
+ execute))
+
+(def: #export (async shell)
+ (-> (Shell IO) (Shell Promise))
+ (structure
+ (def: execute
+ (..can-execute
+ (function (_ input)
+ (promise.future
+ (do (try.with io.monad)
+ [process (!.use (:: shell execute) input)]
+ (wrap (..async-process process)))))))))
+
+(signature: (Policy ?)
+ (: (-> Command (Safe Command ?))
+ command)
+ (: (-> Argument (Safe Argument ?))
+ argument)
+ (: (All [a] (-> (Safe a ?) a))
+ value))
+
+(type: (Sanitizer a)
+ (-> a a))
+
+(type: Replacer
+ (-> Text Text))
+
+(def: (replace bad replacer)
+ (-> Text Replacer (-> Text Text))
+ (text.replace-all bad (replacer bad)))
+
+(def: sanitize-common-command
+ (-> Replacer (Sanitizer Command))
+ (let [x0A (text.from-code (hex "0A"))
+ xFF (text.from-code (hex "FF"))]
+ (function (_ replacer)
+ (|>> (..replace x0A replacer)
+ (..replace xFF replacer)
+ (..replace "\" replacer)
+ (..replace "&" replacer)
+ (..replace "#" replacer)
+ (..replace ";" replacer)
+ (..replace "`" replacer)
+ (..replace "|" replacer)
+ (..replace "*" replacer)
+ (..replace "?" replacer)
+ (..replace "~" replacer)
+ (..replace "^" replacer)
+ (..replace "$" replacer)
+ (..replace "<" replacer) (..replace ">" replacer)
+ (..replace "(" replacer) (..replace ")" replacer)
+ (..replace "[" replacer) (..replace "]" replacer)
+ (..replace "{" replacer) (..replace "}" replacer)))))
+
+(def: (policy sanitize-command sanitize-argument)
+ (Ex [?] (-> (Sanitizer Command) (Sanitizer Argument) (Policy ?)))
+ (?.with-policy
+ (: (?.Context Safety Policy)
+ (function (_ (^open "?@."))
+ (structure
+ (def: command (|>> sanitize-command (!.use ?@can-upgrade)))
+ (def: argument (|>> sanitize-argument (!.use ?@can-upgrade)))
+ (def: value (!.use ?@can-downgrade)))))))
+
+(def: unix-policy
+ (let [replacer (: Replacer
+ (|>> (format "\")))
+ sanitize-command (: (Sanitizer Command)
+ (..sanitize-common-command replacer))
+ sanitize-argument (: (Sanitizer Argument)
+ (|>> (..replace "'" replacer)
+ (text.enclose' "'")))]
+ (..policy sanitize-command sanitize-argument)))
+
+(def: windows-policy
+ (let [replacer (: Replacer
+ (function.constant " "))
+ sanitize-command (: (Sanitizer Command)
+ (|>> (..sanitize-common-command replacer)
+ (..replace "%" replacer)
+ (..replace "!" replacer)))
+ sanitize-argument (: (Sanitizer Argument)
+ (|>> (..replace "%" replacer)
+ (..replace "!" replacer)
+ (..replace text.double-quote replacer)
+ (text.enclose' text.double-quote)))]
+ (..policy sanitize-command sanitize-argument)))
+
+(with-expansions [<jvm> (as-is (import: java/lang/String
+ (toLowerCase [] java/lang/String))
+
+ (def: (jvm::arguments-array arguments)
+ (-> (List Argument) (Array java/lang/String))
+ (product.right
+ (list@fold (function (_ argument [idx output])
+ [(inc idx) (jvm.array-write idx argument output)])
+ [0 (jvm.array java/lang/String (list.size arguments))]
+ arguments)))
+
+ (import: (java/util/Map k v)
+ (put [k v] v))
+
+ (def: (jvm::load-environment input target)
+ (-> Environment
+ (java/util/Map java/lang/String java/lang/String)
+ (java/util/Map java/lang/String java/lang/String))
+ (list@fold (function (_ [key value] target')
+ (exec (java/util/Map::put key value target')
+ target'))
+ target
+ (dictionary.entries input)))
- (def: can-write
- (console.can-write
- (function (_ message)
- (|> jvm-output
- (java/io/OutputStream::write (encoding.to-utf8 message))))))
+ (import: java/io/Reader
+ (read [] #io #try int))
+
+ (import: java/io/BufferedReader
+ (new [java/io/Reader])
+ (readLine [] #io #try java/lang/String))
+
+ (import: java/io/InputStream)
- (def: can-close
- (console.can-close
- (function (_ _)
- (|> process
- java/lang/Process::destroy)))))))))
-
- (import: java/lang/ProcessBuilder
- (new [[java/lang/String]])
- (environment [] #io #try (java/util/Map java/lang/String java/lang/String))
- (start [] #io #try java/lang/Process))
-
- (import: java/lang/System
- (#static getProperty [java/lang/String] #io #try java/lang/String))
- )}))
-
-(def: #export (execute environment command arguments)
- (-> Context Text (List Text) (IO (Try (Console IO))))
- (`` (for {(~~ (static host.old))
- (do {! (try.with io.monad)}
- [windows? (:: ! map (|>> java/lang/String::toLowerCase ..windows?)
- (java/lang/System::getProperty "os.name"))
- #let [builder (java/lang/ProcessBuilder::new (arguments-array (list& (sanitize-command windows? command)
- (list;map (sanitize-argument windows?) arguments))))]
- environment (:: ! map (load-environment environment)
- (java/lang/ProcessBuilder::environment builder))
- process (java/lang/ProcessBuilder::start builder)]
- (process-console process))})))
+ (import: java/io/InputStreamReader
+ (new [java/io/InputStream]))
+
+ (import: java/io/OutputStream
+ (write [[byte]] #io #try void))
+
+ (import: java/lang/Process
+ (getInputStream [] #io #try java/io/InputStream)
+ (getErrorStream [] #io #try java/io/InputStream)
+ (getOutputStream [] #io #try java/io/OutputStream)
+ (destroy [] #io #try void)
+ (waitFor [] #io #try int))
+
+ (def: (default-process process)
+ (-> java/lang/Process (IO (Try (Process IO))))
+ (do (try.with io.monad)
+ [jvm-input (java/lang/Process::getInputStream process)
+ jvm-error (java/lang/Process::getErrorStream process)
+ jvm-output (java/lang/Process::getOutputStream process)
+ #let [jvm-input (|> jvm-input
+ java/io/InputStreamReader::new
+ java/io/BufferedReader::new)
+ jvm-error (|> jvm-error
+ java/io/InputStreamReader::new
+ java/io/BufferedReader::new)]]
+ (wrap (: (Process IO)
+ (`` (structure
+ (~~ (template [<name> <stream>]
+ [(def: <name>
+ (..can-read
+ (function (_ _)
+ (java/io/BufferedReader::readLine <stream>))))]
+
+ [read jvm-input]
+ [error jvm-error]
+ ))
+ (def: write
+ (..can-write
+ (function (_ message)
+ (|> jvm-output
+ (java/io/OutputStream::write (encoding.to-utf8 message))))))
+ (~~ (template [<name> <capability> <method>]
+ [(def: <name>
+ (<capability>
+ (function (_ _)
+ (<method> process))))]
+
+ [destroy ..can-destroy java/lang/Process::destroy]
+ [await ..can-wait java/lang/Process::waitFor]
+ ))))))))
+
+ (import: java/lang/ProcessBuilder
+ (new [[java/lang/String]])
+ (environment [] #io #try (java/util/Map java/lang/String java/lang/String))
+ (start [] #io #try java/lang/Process))
+
+ (import: java/lang/System
+ (#static getProperty [java/lang/String] #io #try java/lang/String))
+ )]
+ (for {@.old (as-is <jvm>)
+ @.jvm (as-is <jvm>)}))
+
+## https://en.wikipedia.org/wiki/Code_injection#Shell_injection
+(def: windows?
+ (IO (Try Bit))
+ (:: (try.with io.monad) map
+ (|>> java/lang/String::toLowerCase (text.starts-with? "windows"))
+ (java/lang/System::getProperty "os.name")))
+
+(def: (jvm::process-builder policy command arguments)
+ (All [?]
+ (-> (Policy ?) (Safe Command ?) (List (Safe Argument ?))
+ java/lang/ProcessBuilder))
+ (|> (list@map (:: policy value) arguments)
+ (list& (:: policy value command))
+ ..jvm::arguments-array
+ java/lang/ProcessBuilder::new))
+
+(structure: #export default
+ (Shell IO)
+
+ (def: execute
+ (..can-execute
+ (function (_ [environment command arguments])
+ (with-expansions [<jvm> (as-is (do {! (try.with io.monad)}
+ [windows? ..windows?
+ #let [builder (if windows?
+ (..jvm::process-builder ..windows-policy
+ (:: ..windows-policy command command)
+ (list@map (:: ..windows-policy argument) arguments))
+ (..jvm::process-builder ..unix-policy
+ (:: ..unix-policy command command)
+ (list@map (:: ..unix-policy argument) arguments)))]
+ _ (:: ! map (..jvm::load-environment environment)
+ (java/lang/ProcessBuilder::environment builder))
+ process (java/lang/ProcessBuilder::start builder)]
+ (..default-process process)))]
+ (for {@.old (as-is <jvm>)
+ @.jvm (as-is <jvm>)}))))))
+
+(signature: #export (Simulation s)
+ (: (-> s (Try [s Text]))
+ on-read)
+ (: (-> s (Try [s Text]))
+ on-error)
+ (: (-> Text s (Try s))
+ on-write)
+ (: (-> s (Try s))
+ on-destroy)
+ (: (-> s (Try [s Exit]))
+ on-await))
+
+(`` (structure: (mock-process simulation state)
+ (All [s] (-> (Simulation s) (Var s) (Process Promise)))
+
+ (~~ (template [<name> <capability> <simulation>]
+ [(def: <name>
+ (<capability>
+ (function (_ _)
+ (stm.commit
+ (do {! stm.monad}
+ [|state| (stm.read state)]
+ (case (:: simulation <simulation> |state|)
+ (#try.Success [|state| output])
+ (do !
+ [_ (stm.write |state| state)]
+ (wrap (#try.Success output)))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error))))))))]
+
+ [read ..can-read on-read]
+ [error ..can-read on-error]
+ [await ..can-wait on-await]
+ ))
+ (def: write
+ (..can-write
+ (function (_ message)
+ (stm.commit
+ (do {! stm.monad}
+ [|state| (stm.read state)]
+ (case (:: simulation on-write message |state|)
+ (#try.Success |state|)
+ (do !
+ [_ (stm.write |state| state)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error))))))))
+ (def: destroy
+ (..can-destroy
+ (function (_ _)
+ (stm.commit
+ (do {! stm.monad}
+ [|state| (stm.read state)]
+ (case (:: simulation on-destroy |state|)
+ (#try.Success |state|)
+ (do !
+ [_ (stm.write |state| state)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error))))))))))
+
+(structure: #export (mock simulation init)
+ (All [s]
+ (-> (-> [Environment Command (List Argument)]
+ (Try (Simulation s)))
+ s
+ (Shell Promise)))
+
+ (def: execute
+ (..can-execute
+ (function (_ input)
+ (promise@wrap
+ (do try.monad
+ [simulation (simulation input)]
+ (wrap (..mock-process simulation (stm.var init)))))))))
diff --git a/stdlib/source/spec/lux/world/shell.lux b/stdlib/source/spec/lux/world/shell.lux
new file mode 100644
index 000000000..286cc7ce2
--- /dev/null
+++ b/stdlib/source/spec/lux/world/shell.lux
@@ -0,0 +1,97 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ [security
+ ["!" capability]]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [data
+ ["." product]
+ ["." text ("#@." equivalence)
+ ["%" format (#+ format)]]
+ [number
+ ["n" nat]
+ ["i" int]]
+ [format
+ ["." context]]]
+ [math
+ ["." random]]]
+ {1
+ ["." /]})
+
+(template [<name> <command> <type> <prep>]
+ [(def: <name>
+ (-> <type> [/.Environment /.Command (List /.Argument)])
+ (|>> <prep> list [context.empty <command>]))]
+
+ [echo! "echo" Text (|>)]
+ [sleep! "sleep" Nat %.nat]
+ )
+
+(def: (read-test expected process)
+ (-> Text (/.Process Promise) _.Assertion)
+ (do promise.monad
+ [?read (!.use (:: process read) [])
+ ?await (!.use (:: process await) [])]
+ ($_ _.and'
+ (_.claim [/.Can-Read]
+ (case ?read
+ (#try.Success actual)
+ (text@= expected actual)
+
+ (#try.Failure error)
+ false))
+ (_.claim [/.Can-Wait /.Exit /.normal]
+ (case ?await
+ (#try.Success exit)
+ (i.= /.normal exit)
+
+ (#try.Failure error)
+ false))
+ )))
+
+(def: (destroy-test process)
+ (-> (/.Process Promise) _.Assertion)
+ (do promise.monad
+ [?destroy (!.use (:: process destroy) [])
+ ?await (!.use (:: process await) [])]
+ (_.claim [/.Can-Destroy]
+ (and (case ?destroy
+ (#try.Success _)
+ true
+
+ (#try.Failure error)
+ false)
+ (case ?await
+ (#try.Success _)
+ false
+
+ (#try.Failure error)
+ true)))))
+
+(with-expansions [<shell-coverage> (as-is [/.Can-Execute
+ /.Environment /.Command /.Argument])]
+ (def: #export (spec shell)
+ (-> (/.Shell Promise) Test)
+ (<| (_.with-cover [/.Shell /.Process])
+ (do {! random.monad}
+ [message (random.ascii/alpha 10)
+ seconds (:: ! map (|>> (n.% 5) (n.+ 5)) random.nat)]
+ (wrap (do promise.monad
+ [?echo (!.use (:: shell execute) (..echo! message))
+ ?sleep (!.use (:: shell execute) (..sleep! seconds))]
+ (case [?echo ?sleep]
+ [(#try.Success echo) (#try.Success sleep)]
+ ($_ _.and'
+ (_.claim <shell-coverage>
+ true)
+ (..read-test message echo)
+ (..destroy-test sleep))
+
+ _
+ (_.claim <shell-coverage>
+ false))))))))
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index 50e737e98..14d75527f 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -3,14 +3,14 @@
["_" test (#+ Test)]]
["." / #_
["#." concatenative]
- [concurrency
- ["#." actor]
- ["#." atom]
- ["#." frp]
- ["#." process]
- ["#." promise]
- ["#." semaphore]
- ["#." stm]]
+ ["#." concurrency #_
+ ["#/." actor]
+ ["#/." atom]
+ ["#/." frp]
+ ["#/." thread]
+ ["#/." promise]
+ ["#/." semaphore]
+ ["#/." stm]]
["#." continuation]
["#." exception]
["#." function
@@ -44,13 +44,13 @@
(def: concurrency
Test
($_ _.and
- /actor.test
- /atom.test
- /frp.test
- /process.test
- /promise.test
- /semaphore.test
- /stm.test
+ /concurrency/actor.test
+ /concurrency/atom.test
+ /concurrency/frp.test
+ /concurrency/thread.test
+ /concurrency/promise.test
+ /concurrency/semaphore.test
+ /concurrency/stm.test
))
(def: function
diff --git a/stdlib/source/test/lux/control/concurrency/process.lux b/stdlib/source/test/lux/control/concurrency/thread.lux
index 6d59672ca..6d59672ca 100644
--- a/stdlib/source/test/lux/control/concurrency/process.lux
+++ b/stdlib/source/test/lux/control/concurrency/thread.lux
diff --git a/stdlib/source/test/lux/control/security/policy.lux b/stdlib/source/test/lux/control/security/policy.lux
index 4a4f8409a..4885b52eb 100644
--- a/stdlib/source/test/lux/control/security/policy.lux
+++ b/stdlib/source/test/lux/control/security/policy.lux
@@ -20,7 +20,7 @@
[math
["." random]]]
{1
- ["." / (#+ Context Privacy Can-Conceal Can-Reveal Privilege Private with-policy)]})
+ ["." / (#+ Context Privacy Can-Conceal Can-Reveal Privilege Private)]})
(def: (injection can-conceal)
(All [label]
@@ -48,7 +48,7 @@
(def: (policy _)
(Ex [%] (-> Any (Policy %)))
- (with-policy
+ (/.with-policy
(: (Context Privacy Policy)
(function (_ (^@ privilege (^open "%@.")))
(structure
@@ -72,8 +72,7 @@
Test
(<| (_.covering /._)
(_.with-cover [/.Policy
- /.Can-Upgrade /.Can-Downgrade
- /.can-upgrade /.can-downgrade])
+ /.Can-Upgrade /.Can-Downgrade])
(do random.monad
[#let [policy-0 (policy [])]
raw-password (random.ascii 10)
diff --git a/stdlib/source/test/lux/data/collection/queue/priority.lux b/stdlib/source/test/lux/data/collection/queue/priority.lux
index 555214148..073ce2c8d 100644
--- a/stdlib/source/test/lux/data/collection/queue/priority.lux
+++ b/stdlib/source/test/lux/data/collection/queue/priority.lux
@@ -1,56 +1,92 @@
(.module:
[lux #*
- ["%" data/text/format (#+ format)]
["_" test (#+ Test)]
[abstract
["." monad (#+ do)]]
[data
- ["." maybe]
+ ["." maybe ("#@." functor)]
+ ["." bit ("#@." equivalence)]
[number
["n" nat]]]
[math
- ["r" random (#+ Random)]]]
+ ["." random (#+ Random)]]]
{1
["." / (#+ Queue)]})
-(def: #export (queue size)
+(def: #export (random size)
(-> Nat (Random (Queue Nat)))
- (do {! r.monad}
- [inputs (r.list size r.nat)]
+ (do {! random.monad}
+ [inputs (random.list size random.nat)]
(monad.fold ! (function (_ head tail)
(do !
- [priority r.nat]
+ [priority random.nat]
(wrap (/.push priority head tail))))
/.empty
inputs)))
(def: #export test
Test
- (<| (_.context (%.name (name-of /.Queue)))
- (do {! r.monad}
- [size (|> r.nat (:: ! map (n.% 100)))
- sample (..queue size)
- non-member-priority r.nat
- non-member (|> r.nat (r.filter (|>> (/.member? n.equivalence sample) not)))]
+ (<| (_.covering /._)
+ (_.with-cover [/.Queue])
+ (do {! random.monad}
+ [size (:: ! map (n.% 100) random.nat)
+ sample (..random size)
+ non-member-priority random.nat
+ non-member (random.filter (|>> (/.member? n.equivalence sample) not)
+ random.nat)
+
+ max-member random.nat
+ min-member random.nat]
($_ _.and
- (_.test "I can query the size of a queue (and empty queues have size 0)."
- (n.= size (/.size sample)))
- (_.test "Enqueueing and dequeing affects the size of queues."
- (and (n.= (inc size)
- (/.size (/.push non-member-priority non-member sample)))
- (or (n.= 0 (/.size sample))
- (n.= (dec size)
- (/.size (/.pop sample))))))
- (_.test "I can query whether an element belongs to a queue."
- (and (and (not (/.member? n.equivalence sample non-member))
- (/.member? n.equivalence
- (/.push non-member-priority non-member sample)
- non-member))
- (or (n.= 0 (/.size sample))
- (and (/.member? n.equivalence
- sample
- (maybe.assume (/.peek sample)))
- (not (/.member? n.equivalence
- (/.pop sample)
- (maybe.assume (/.peek sample))))))))
+ (_.cover [/.size]
+ (n.= size (/.size sample)))
+ (_.cover [/.empty?]
+ (bit@= (n.= 0 (/.size sample))
+ (/.empty? sample)))
+ (_.cover [/.empty]
+ (/.empty? /.empty))
+ (_.cover [/.peek]
+ (case (/.peek sample)
+ (#.Some first)
+ (n.> 0 (/.size sample))
+
+ #.None
+ (/.empty? sample)))
+ (_.cover [/.member?]
+ (case (/.peek sample)
+ (#.Some first)
+ (/.member? n.equivalence sample first)
+
+ #.None
+ (/.empty? sample)))
+ (_.cover [/.push]
+ (let [sample+ (/.push non-member-priority non-member sample)]
+ (and (not (/.member? n.equivalence sample non-member))
+ (n.= (inc (/.size sample))
+ (/.size sample+))
+ (/.member? n.equivalence sample+ non-member))))
+ (_.cover [/.pop]
+ (let [sample- (/.pop sample)]
+ (or (and (/.empty? sample)
+ (/.empty? sample-))
+ (n.= (dec (/.size sample))
+ (/.size sample-)))))
+ (_.with-cover [/.Priority]
+ ($_ _.and
+ (_.cover [/.max]
+ (|> /.empty
+ (/.push /.min min-member)
+ (/.push /.max max-member)
+ /.peek
+ (maybe@map (n.= max-member))
+ (maybe.default false)))
+ (_.cover [/.min]
+ (|> /.empty
+ (/.push /.max max-member)
+ (/.push /.min min-member)
+ /.pop
+ /.peek
+ (maybe@map (n.= min-member))
+ (maybe.default false)))
+ ))
))))
diff --git a/stdlib/source/test/lux/type/check.lux b/stdlib/source/test/lux/type/check.lux
index ccd44ed89..3936c7a65 100644
--- a/stdlib/source/test/lux/type/check.lux
+++ b/stdlib/source/test/lux/type/check.lux
@@ -36,7 +36,7 @@
(let [(^open "R@.") r.monad
pairG (r.and (type' num-vars)
(type' num-vars))
- quantifiedG (r.and (R@wrap (list)) (type' (n.+ 2 num-vars)))
+ quantifiedG (r.and (R@wrap (list)) (type' (inc num-vars)))
random-pair (r.either (r.either (R@map (|>> #.Sum) pairG)
(R@map (|>> #.Product) pairG))
(r.either (R@map (|>> #.Function) pairG)
@@ -45,7 +45,7 @@
(R@map (|>> #.Ex) r.nat))]
(case num-vars
0 random-id
- _ (r.either (R@map (|>> (n.% num-vars) #.Parameter) r.nat)
+ _ (r.either (R@map (|>> (n.% num-vars) (n.* 2) inc #.Parameter) r.nat)
random-id)))
random-quantified (r.either (R@map (|>> #.UnivQ) quantifiedG)
(R@map (|>> #.ExQ) quantifiedG))]
@@ -108,7 +108,7 @@
(<| (_.context (%.name (name-of /._)))
($_ _.and
(do r.monad
- [sample (|> ..type (r.filter valid-type?))]
+ [sample (r.filter ..valid-type? ..type)]
($_ _.and
(_.test "Any is the super-type of everything."
(/.checks? Any sample))
@@ -159,7 +159,7 @@
nameL gen-short
nameR (|> gen-short (r.filter (|>> (text@= nameL) not)))
paramL ..type
- paramR (|> ..type (r.filter (|>> (/.checks? paramL) not)))]
+ paramR (r.filter (|>> (/.checks? paramL) not) ..type)]
($_ _.and
(_.test "Primitive types match when they have the same name and the same parameters."
(/.checks? (#.Primitive nameL (list paramL))
diff --git a/stdlib/source/test/lux/world.lux b/stdlib/source/test/lux/world.lux
index e46eecda3..c5b0ecc59 100644
--- a/stdlib/source/test/lux/world.lux
+++ b/stdlib/source/test/lux/world.lux
@@ -2,10 +2,12 @@
[lux #*
["_" test (#+ Test)]]
["." / #_
- ["#." file]])
+ ["#." file]
+ ["#." shell]])
(def: #export test
Test
($_ _.and
/file.test
+ /shell.test
))
diff --git a/stdlib/source/test/lux/world/shell.lux b/stdlib/source/test/lux/world/shell.lux
new file mode 100644
index 000000000..f98fc6a17
--- /dev/null
+++ b/stdlib/source/test/lux/world/shell.lux
@@ -0,0 +1,58 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
+ [data
+ [number
+ ["n" nat]
+ ["i" int]]
+ [collection
+ ["." list]]]]
+ {1
+ ["." /]}
+ {[1 #spec]
+ ["$." /]})
+
+(exception: dead)
+
+(def: (simulation [environment command arguments])
+ (-> [/.Environment /.Command (List /.Argument)]
+ (/.Simulation Bit))
+ (structure
+ (def: (on-read dead?)
+ (if dead?
+ (exception.throw ..dead [])
+ (do try.monad
+ [to-echo (try.from-maybe (list.head arguments))]
+ (wrap [dead? to-echo]))))
+
+ (def: (on-error dead?)
+ (if dead?
+ (exception.throw ..dead [])
+ (exception.return [dead? ""])))
+
+ (def: (on-write message dead?)
+ (if dead?
+ (exception.throw ..dead [])
+ (#try.Success dead?)))
+
+ (def: (on-destroy dead?)
+ (if dead?
+ (exception.throw ..dead [])
+ (#try.Success true)))
+
+ (def: (on-await dead?)
+ (if dead?
+ (exception.throw ..dead [])
+ (#try.Success [true /.normal])))))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (_.with-cover [/.mock /.Simulation]
+ ($/.spec (/.mock (|>> ..simulation #try.Success)
+ false)))))