aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux.lux21
-rw-r--r--stdlib/source/lux/control/concurrency/actor.lux31
-rw-r--r--stdlib/source/lux/control/concurrency/atom.lux2
-rw-r--r--stdlib/source/lux/control/concurrency/frp.lux17
-rw-r--r--stdlib/source/lux/data/collection/dictionary.lux4
-rw-r--r--stdlib/source/lux/data/collection/set.lux4
-rw-r--r--stdlib/source/lux/data/collection/set/multi.lux165
-rw-r--r--stdlib/source/lux/world/console.lux114
-rw-r--r--stdlib/source/spec/lux/world/console.lux49
-rw-r--r--stdlib/source/test/lux/control/concurrency/actor.lux54
-rw-r--r--stdlib/source/test/lux/control/concurrency/frp.lux21
-rw-r--r--stdlib/source/test/lux/data/collection.lux2
-rw-r--r--stdlib/source/test/lux/data/collection/array.lux24
-rw-r--r--stdlib/source/test/lux/data/collection/set/multi.lux216
-rw-r--r--stdlib/source/test/lux/target/jvm.lux4
-rw-r--r--stdlib/source/test/lux/world.lux4
-rw-r--r--stdlib/source/test/lux/world/console.lux43
17 files changed, 627 insertions, 148 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index 9365e0cda..3e373be35 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -2909,18 +2909,15 @@
#None))
(#Some g!name head tail body)
(let [g!blank (local-identifier$ "")
- g!name (local-identifier$ g!name)
- body+ (list@fold (: (-> Code Code Code)
- (function' [arg body']
- (if (identifier? arg)
- (` ([(~ g!blank) (~ arg)] (~ body')))
- (` ([(~ g!blank) (~ g!blank)]
- (case (~ g!blank) (~ arg) (~ body')))))))
- body
- (list@reverse tail))]
- (return (list (if (identifier? head)
- (` ([(~ g!name) (~ head)] (~ body+)))
- (` ([(~ g!name) (~ g!blank)] (case (~ g!blank) (~ head) (~ body+))))))))
+ nest (: (-> Code (-> Code Code Code))
+ (function' [g!name]
+ (function' [arg body']
+ (if (identifier? arg)
+ (` ([(~ g!name) (~ arg)] (~ body')))
+ (` ([(~ g!name) (~ g!blank)]
+ (.case (~ g!blank) (~ arg) (~ body'))))))))]
+ (return (list (nest (..local-identifier$ g!name) head
+ (list@fold (nest g!blank) body (list@reverse tail))))))
#None
(fail "Wrong syntax for function")))
diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux
index c5f6ca6c7..aa30efa76 100644
--- a/stdlib/source/lux/control/concurrency/actor.lux
+++ b/stdlib/source/lux/control/concurrency/actor.lux
@@ -30,7 +30,8 @@
["." abstract (#+ abstract: :representation :abstraction)]]]
[//
["." atom (#+ Atom atom)]
- ["." promise (#+ Promise Resolver) ("#@." monad)]])
+ ["." promise (#+ Promise Resolver) ("#@." monad)]
+ ["." frp (#+ Channel)]])
(exception: #export poisoned)
(exception: #export dead)
@@ -122,6 +123,12 @@
(let [[obituary _] (get@ #obituary (:representation actor))]
(promise.poll obituary)))
+ (def: #export await
+ (All [s] (-> (Actor s) (Promise (Obituary s))))
+ (|>> :representation
+ (get@ #obituary)
+ product.left))
+
(def: #export (mail! mail actor)
{#.doc "Send mail to an actor.."}
(All [s] (-> (Mail s) (Actor s) (IO (Try Any))))
@@ -389,3 +396,25 @@
(:coerce ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.abstraction actor-scope))
(~ (get@ #output signature))]))))))))
))))))
+
+(type: #export Stop
+ (IO Any))
+
+(def: continue! true)
+(def: stop! false)
+
+(def: #export (observe action channel actor)
+ (All [e s] (-> (-> e Stop (Mail s)) (Channel e) (Actor s) (IO Any)))
+ (let [signal (: (Atom Bit)
+ (atom.atom ..continue!))
+ stop (: Stop
+ (atom.write ..stop! signal))]
+ (frp.subscribe (function (_ event)
+ (do {! io.monad}
+ [continue? (atom.read signal)]
+ (if continue?
+ (do !
+ [outcome (..mail! (action event stop) actor)]
+ (wrap (try.to-maybe outcome)))
+ (wrap #.None))))
+ channel)))
diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux
index 9ebd54bb8..54be96d76 100644
--- a/stdlib/source/lux/control/concurrency/atom.lux
+++ b/stdlib/source/lux/control/concurrency/atom.lux
@@ -98,4 +98,4 @@
(def: #export (write value atom)
(All [a] (-> a (Atom a) (IO Any)))
- (update (function.constant value) atom))
+ (..update (function.constant value) atom))
diff --git a/stdlib/source/lux/control/concurrency/frp.lux b/stdlib/source/lux/control/concurrency/frp.lux
index 50c26e769..fdec66a61 100644
--- a/stdlib/source/lux/control/concurrency/frp.lux
+++ b/stdlib/source/lux/control/concurrency/frp.lux
@@ -110,7 +110,9 @@
_
(wrap #.None)))))
-(def: empty Channel (promise.resolved #.None))
+(def: empty
+ Channel
+ (promise.resolved #.None))
(structure: #export monad
(Monad Channel)
@@ -145,15 +147,22 @@
(wrap (: Any (io.run (:: sink close))))))))
output))))
-(def: #export (listen listener channel)
- (All [a] (-> (-> a (IO Any)) (Channel a) (IO Any)))
+(type: #export (Subscriber a)
+ (-> a (IO (Maybe Any))))
+
+(def: #export (subscribe subscriber channel)
+ (All [a] (-> (Subscriber a) (Channel a) (IO Any)))
(io (exec (: (Promise Any)
(loop [channel channel]
(do promise.monad
[cons channel]
(case cons
(#.Some [head tail])
- (exec (io.run (listener head))
+ (case (io.run (subscriber head))
+ (#.Some _)
+ (recur tail)
+
+ #.None
(recur tail))
#.None
diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux
index 9244ebe84..f56d314a8 100644
--- a/stdlib/source/lux/data/collection/dictionary.lux
+++ b/stdlib/source/lux/data/collection/dictionary.lux
@@ -550,6 +550,10 @@
{#hash (Hash k)
#root (Node k v)})
+(def: #export key-hash
+ (All [k v] (-> (Dictionary k v) (Hash k)))
+ (get@ #..hash))
+
(def: #export (new Hash<k>)
(All [k v] (-> (Hash k) (Dictionary k v)))
{#hash Hash<k>
diff --git a/stdlib/source/lux/data/collection/set.lux b/stdlib/source/lux/data/collection/set.lux
index 9321723c3..d874785b5 100644
--- a/stdlib/source/lux/data/collection/set.lux
+++ b/stdlib/source/lux/data/collection/set.lux
@@ -15,6 +15,10 @@
(type: #export (Set a)
(Dictionary a Any))
+(def: #export member-hash
+ (All [a] (-> (Set a) (Hash a)))
+ //.key-hash)
+
(def: #export new
(All [a] (-> (Hash a) (Set a)))
//.new)
diff --git a/stdlib/source/lux/data/collection/set/multi.lux b/stdlib/source/lux/data/collection/set/multi.lux
index 9cfd9e4b1..fb9925e98 100644
--- a/stdlib/source/lux/data/collection/set/multi.lux
+++ b/stdlib/source/lux/data/collection/set/multi.lux
@@ -4,12 +4,13 @@
[abstract
[equivalence (#+ Equivalence)]
[hash (#+ Hash)]]
- ["." function]
- [type (#+ :share)
- abstract]]
+ [control
+ ["." function]]
+ [type
+ [abstract (#+ abstract: :abstraction :representation ^:representation)]]]
["." //
[//
- ["." list ("#;." fold)]
+ ["." list ("#@." fold monoid)]
["." dictionary (#+ Dictionary)]
[//
["." maybe]
@@ -25,75 +26,69 @@
(def: #export size
(All [a] (-> (Set a) Nat))
- (|>> :representation dictionary.values (list;fold n.+ 0)))
+ (|>> :representation dictionary.values (list@fold n.+ 0)))
- (def: #export (add/* count elem set)
+ (def: #export (add multiplicity elem set)
(All [a] (-> Nat a (Set a) (Set a)))
- (|> set :representation (dictionary.update~ elem 0 (n.+ count)) :abstraction))
-
- (def: #export add/1
- (All [a] (-> a (Set a) (Set a)))
- (add/* 1))
-
- (def: #export (remove/* count elem set)
+ (case multiplicity
+ 0 set
+ _ (|> set
+ :representation
+ (dictionary.upsert elem 0 (n.+ multiplicity))
+ :abstraction)))
+
+ (def: #export (remove multiplicity elem set)
(All [a] (-> Nat a (Set a) (Set a)))
- (case (dictionary.get elem (:representation set))
- (#.Some current)
- (let [transform (:share [a]
- {(Set a)
- set}
- {(-> (Dictionary a Nat) (Dictionary a Nat))
- (if (n.> count current)
- (dictionary.update elem (n.- count))
- (dictionary.remove elem))})]
- (|> set :representation transform :abstraction))
-
- #.None
- set))
-
- (def: #export remove/1
- (All [a] (-> a (Set a) (Set a)))
- (remove/* 1))
-
- (def: #export (multiplicity elem set)
- (All [a] (-> a (Set a) Nat))
+ (case multiplicity
+ 0 set
+ _ (case (dictionary.get elem (:representation set))
+ (#.Some current)
+ (:abstraction
+ (if (n.> multiplicity current)
+ (dictionary.update elem (n.- multiplicity) (:representation set))
+ (dictionary.remove elem (:representation set))))
+
+ #.None
+ set)))
+
+ (def: #export (multiplicity set elem)
+ (All [a] (-> (Set a) a Nat))
(|> set :representation (dictionary.get elem) (maybe.default 0)))
(def: #export to-list
(All [a] (-> (Set a) (List a)))
- (let [append (: (All [a] (-> a Nat (List a) (List a)))
- (function (append elem count output)
- (case count
- 0 output
- _ (|> output (#.Cons elem) (append elem (dec count))))))]
- (|>> :representation
- dictionary.entries
- (list;fold (function (_ [elem count] output)
- (append elem count output))
- #.Nil))))
-
- (def: #export (union parameter subject)
+ (|>> :representation
+ dictionary.entries
+ (list@fold (function (_ [elem multiplicity] output)
+ (list@compose (list.repeat multiplicity elem) output))
+ #.Nil)))
+
+ (template [<name> <compose>]
+ [(def: #export (<name> parameter subject)
+ (All [a] (-> (Set a) (Set a) (Set a)))
+ (:abstraction (dictionary.merge-with <compose> (:representation parameter) (:representation subject))))]
+
+ [union n.max]
+ [sum n.+]
+ )
+
+ (def: #export (intersection parameter (^:representation subject))
(All [a] (-> (Set a) (Set a) (Set a)))
- (:abstraction (dictionary.merge-with n.+ (:representation parameter) (:representation subject))))
+ (list@fold (function (_ [elem multiplicity] output)
+ (..add (n.min (..multiplicity parameter elem)
+ multiplicity)
+ elem
+ output))
+ (..new (dictionary.key-hash subject))
+ (dictionary.entries subject)))
(def: #export (difference parameter subject)
(All [a] (-> (Set a) (Set a) (Set a)))
(|> parameter
:representation
dictionary.entries
- (list;fold (function (_ [elem count] output)
- (remove/* count elem output))
- subject)))
-
- (def: #export (intersection parameter subject)
- (All [a] (-> (Set a) (Set a) (Set a)))
- (|> parameter
- :representation
- dictionary.entries
- (list;fold (function (_ [elem count] (^:representation output))
- (:abstraction (if (dictionary.contains? elem output)
- (dictionary.update elem (n.min count) output)
- output)))
+ (list@fold (function (_ [elem multiplicity] output)
+ (..remove multiplicity elem output))
subject)))
(def: #export (sub? reference subject)
@@ -101,54 +96,60 @@
(|> subject
:representation
dictionary.entries
- (list.every? (function (_ [elem count])
- (|> reference
- :representation
- (dictionary.get elem)
- (maybe.default 0)
- (n.>= count))))))
+ (list.every? (function (_ [elem multiplicity])
+ (|> elem
+ (..multiplicity reference)
+ (n.>= multiplicity))))))
(def: #export (support set)
(All [a] (-> (Set a) (//.Set a)))
- (let [(^@ set [Hash<a> _]) (:representation set)]
+ (let [(^@ set [hash _]) (:representation set)]
(|> set
dictionary.keys
- (//.from-list Hash<a>))))
+ (//.from-list hash))))
- (structure: #export equivalence (All [a] (Equivalence (Set a)))
- (def: (= (^:representation reference) (^:representation sample))
+ (structure: #export equivalence
+ (All [a] (Equivalence (Set a)))
+
+ (def: (= (^:representation reference) sample)
(and (n.= (dictionary.size reference)
- (dictionary.size sample))
+ (dictionary.size (:representation sample)))
(|> reference
dictionary.entries
- (list.every? (function (_ [elem count])
- (|> sample
- (dictionary.get elem)
- (maybe.default 0)
- (n.= count))))))))
+ (list.every? (function (_ [elem multiplicity])
+ (|> elem
+ (..multiplicity sample)
+ (n.= multiplicity))))))))
- (structure: #export hash (All [a] (Hash (Set a)))
+ (structure: #export hash
+ (All [a] (Hash (Set a)))
+
(def: &equivalence ..equivalence)
(def: (hash (^:representation set))
- (let [[Hash<a> _] set]
- (list;fold (function (_ [elem count] acc)
- (|> elem (:: Hash<a> hash) (n.* count) (n.+ acc)))
+ (let [[hash _] set]
+ (list@fold (function (_ [elem multiplicity] acc)
+ (|> elem (:: hash hash) (n.+ multiplicity) (n.+ acc)))
0
(dictionary.entries set)))))
)
(def: #export (member? set elem)
(All [a] (-> (Set a) a Bit))
- (|> set (..multiplicity elem) (n.> 0)))
+ (|> elem (..multiplicity set) (n.> 0)))
(def: #export empty?
(All [a] (-> (Set a) Bit))
(|>> ..size (n.= 0)))
-(def: #export (from-list Hash<a> subject)
+(def: #export (from-list hash subject)
(All [a] (-> (Hash a) (List a) (Set a)))
- (list;fold ..add/1 (..new Hash<a>) subject))
+ (list@fold (..add 1) (..new hash) subject))
+
+(def: #export (from-set subject)
+ (All [a] (-> (//.Set a) (Set a)))
+ (..from-list (//.member-hash subject)
+ (//.to-list subject)))
(def: #export super?
(All [a] (-> (Set a) (Set a) Bit))
diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux
index c1ad4e7e5..7498b3665 100644
--- a/stdlib/source/lux/world/console.lux
+++ b/stdlib/source/lux/world/console.lux
@@ -6,14 +6,15 @@
[monad (#+ do)]]
[control
["." try (#+ Try)]
- ["ex" exception (#+ exception:)]
+ ["." exception (#+ exception:)]
["." io (#+ IO io)]
[concurrency
- ["." promise (#+ Promise)]]
+ ["." promise (#+ Promise)]
+ ["." stm]]
[security
["!" capability (#+ capability:)]]]
[data
- ["." text
+ ["." text (#+ Char)
["%" format (#+ format)]]]])
(template [<name>]
@@ -34,14 +35,14 @@
(can-close [] (! (Try Any))))
(signature: #export (Console !)
- (: (Can-Read ! Nat)
- can-read)
+ (: (Can-Read ! Char)
+ read)
(: (Can-Read ! Text)
- can-read-line)
+ read-line)
(: (Can-Write ! Text)
- can-write)
+ write)
(: (Can-Close !)
- can-close))
+ close))
(def: #export (async console)
(-> (Console IO) (Console Promise))
@@ -50,10 +51,10 @@
(<forge>
(|>> (!.use (:: console <capability>)) promise.future)))]
- [can-read ..can-read]
- [can-read-line ..can-read]
- [can-write ..can-write]
- [can-close ..can-close])))))
+ [read ..can-read]
+ [read-line ..can-read]
+ [write ..can-write]
+ [close ..can-close])))))
(with-expansions [<jvm> (as-is (import: java/lang/String)
@@ -77,42 +78,103 @@
[?jvm-console (java/lang/System::console)]
(case ?jvm-console
#.None
- (wrap (ex.throw cannot-open []))
+ (wrap (exception.throw ..cannot-open []))
(#.Some jvm-console)
(let [jvm-input (java/lang/System::in)
jvm-output (java/lang/System::out)]
(<| wrap
- ex.return
+ exception.return
(: (Console IO)) ## TODO: Remove ASAP
(structure
- (def: can-read
+ (def: read
(..can-read
(function (_ _)
(|> jvm-input
java/io/InputStream::read
(:: (try.with io.monad) map .nat)))))
- (def: can-read-line
+ (def: read-line
(..can-read
(function (_ _)
(java/io/Console::readLine jvm-console))))
- (def: can-write
+ (def: write
(..can-write
(function (_ message)
(java/io/PrintStream::print message jvm-output))))
- (def: can-close
+ (def: close
(..can-close
- (|>> (ex.throw cannot-close) wrap))))))))))]
- (for {@.old
- (as-is <jvm>)
-
- @.jvm
- (as-is <jvm>)
- }))
+ (|>> (exception.throw ..cannot-close) wrap))))))))))]
+ (for {@.old (as-is <jvm>)
+ @.jvm (as-is <jvm>)}))
(def: #export (write-line message console)
(All [!] (-> Text (Console !) (! Any)))
- (!.use (:: console can-write) (format message text.new-line)))
+ (!.use (:: console write) (format message text.new-line)))
+
+(signature: #export (Simulation s)
+ (: (-> s (Try [s Char]))
+ on-read)
+ (: (-> s (Try [s Text]))
+ on-read-line)
+ (: (-> Text s (Try s))
+ on-write)
+ (: (-> s (Try s))
+ on-close))
+
+(def: #export (mock simulation init)
+ (All [s] (-> (Simulation s) s (Console Promise)))
+ (let [state (stm.var init)]
+ (`` (structure
+ (~~ (template [<method> <simulation>]
+ [(def: <method>
+ (..can-read
+ (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 on-read]
+ [read-line on-read-line]
+ ))
+
+ (def: write
+ (..can-write
+ (function (_ input)
+ (stm.commit
+ (do {! stm.monad}
+ [|state| (stm.read state)]
+ (case (:: simulation on-write input |state|)
+ (#try.Success |state|)
+ (do !
+ [_ (stm.write |state| state)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error))))))))
+
+ (def: close
+ (..can-close
+ (function (_ _)
+ (stm.commit
+ (do {! stm.monad}
+ [|state| (stm.read state)]
+ (case (:: simulation on-close |state|)
+ (#try.Success |state|)
+ (do !
+ [_ (stm.write |state| state)]
+ (wrap (#try.Success [])))
+
+ (#try.Failure error)
+ (wrap (#try.Failure error))))))))
+ ))))
diff --git a/stdlib/source/spec/lux/world/console.lux b/stdlib/source/spec/lux/world/console.lux
new file mode 100644
index 000000000..b9e1c0720
--- /dev/null
+++ b/stdlib/source/spec/lux/world/console.lux
@@ -0,0 +1,49 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try]
+ [security
+ ["!" capability]]
+ [concurrency
+ ["." promise (#+ Promise)]]]
+ [math
+ ["." random]]]
+ {1
+ ["." /]})
+
+(def: #export (spec console)
+ (-> (/.Console Promise) Test)
+ (<| (_.with-cover [/.Console])
+ (do {! random.monad}
+ [message (random.ascii/alpha 10)]
+ (wrap (do promise.monad
+ [?read (!.use (:: console read) [])
+ ?read-line (!.use (:: console read-line) [])
+ ?write (!.use (:: console write) [message])
+ ?close/good (!.use (:: console close) [])
+ ?close/bad (!.use (:: console close) [])]
+ ($_ _.and'
+ (_.claim [/.Can-Read]
+ (case [?read ?read-line]
+ [(#try.Success _) (#try.Success _)]
+ true
+
+ _
+ false))
+ (_.claim [/.Can-Write]
+ (case ?write
+ (#try.Success _)
+ true
+
+ _
+ false))
+ (_.claim [/.Can-Close]
+ (case [?close/good ?close/bad]
+ [(#try.Success _) (#try.Failure _)]
+ true
+
+ _
+ false))))))))
diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux
index 1b1a01242..7ab561360 100644
--- a/stdlib/source/test/lux/control/concurrency/actor.lux
+++ b/stdlib/source/test/lux/control/concurrency/actor.lux
@@ -11,13 +11,18 @@
[number
["n" nat]]
[text
- ["%" format (#+ format)]]]
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]
+ ["." row (#+ Row)]]]
[math
["." random]]]
{1
["." / (#+ actor: message:)
[//
- ["." promise (#+ Promise Resolver) ("#@." monad)]]]})
+ ["." atom (#+ Atom)]
+ ["." promise (#+ Promise Resolver) ("#@." monad)]
+ ["." frp]]]})
(exception: got-wrecked)
@@ -43,7 +48,7 @@
(def: #export test
Test
- (do random.monad
+ (do {! random.monad}
[initial-state random.nat
#let [as-mail (: (All [a] (-> (-> a a) (/.Mail a)))
(function (_ transform)
@@ -189,4 +194,47 @@
false)))))]
(_.claim [/.actor]
verdict)))
+ (do !
+ [num-events (:: ! map (|>> (n.% 10) inc) random.nat)
+ events (random.list num-events random.nat)
+ num-observations (:: ! map (n.% num-events) random.nat)
+ #let [expected (list.take num-observations events)
+ sink (: (Atom (Row Nat))
+ (atom.atom row.empty))
+ [signal signal!] (: [(Promise Any) (Resolver Any)]
+ (promise.promise []))]]
+ (wrap (do promise.monad
+ [agent (promise.future
+ (do {! io.monad}
+ [agent (/.actor {Nat 0})
+ _ (/.observe (function (_ event stop)
+ (function (_ events-seen self)
+ (promise.future
+ (cond (n.< num-observations events-seen)
+ (do !
+ [_ (atom.update (row.add event) sink)]
+ (wrap (#try.Success (inc events-seen))))
+
+ (n.= num-observations events-seen)
+ (do !
+ [_ stop
+ _ (signal! [])]
+ (wrap (#try.Success (inc events-seen))))
+
+ (wrap (#try.Failure "YOLO"))))))
+ (frp.sequential 0 events)
+ agent)]
+ (wrap agent)))
+ _ signal
+ actual (promise.future (atom.read sink))
+ died? (promise.time-out 1,000 (/.await agent))
+ #let [died? (case died?
+ (#.Some _)
+ true
+
+ #.None
+ false)]]
+ (_.claim [/.observe]
+ (and (:: (list.equivalence n.equivalence) = expected (row.to-list actual))
+ (not died?))))))
))))
diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux
index 43198ff5b..e7d418bf7 100644
--- a/stdlib/source/test/lux/control/concurrency/frp.lux
+++ b/stdlib/source/test/lux/control/concurrency/frp.lux
@@ -16,7 +16,7 @@
[number
["n" nat]]
[collection
- ["." list ("#@." functor fold)]
+ ["." list ("#@." functor fold monoid)]
["." row (#+ Row)]]]
[math
["." random]]]
@@ -124,18 +124,23 @@
(wrap (do {! promise.monad}
[#let [sink (: (Atom (Row Nat))
(atom.atom row.empty))
- channel (/.sequential 0 inputs)]
- _ (promise.future (/.listen (function (_ value)
- (do io.monad
- [_ (atom.update (row.add value) sink)]
- (wrap [])))
- channel))
+ channel (/.sequential 0 (list@compose inputs inputs))]
+ _ (promise.future (/.subscribe (function (_ value)
+ (do {! io.monad}
+ [current (atom.read sink)]
+ (if (n.< (list.size inputs)
+ (row.size current))
+ (do !
+ [_ (atom.update (row.add value) sink)]
+ (wrap (#.Some [])))
+ (wrap (#.Some [])))))
+ channel))
output (/.consume channel)
listened (|> sink
atom.read
promise.future
(:: ! map row.to-list))]
- (_.claim [/.listen]
+ (_.claim [/.Subscriber /.subscribe]
(and (list@= inputs
output)
(list@= output
diff --git a/stdlib/source/test/lux/data/collection.lux b/stdlib/source/test/lux/data/collection.lux
index 82643dfde..497123614 100644
--- a/stdlib/source/test/lux/data/collection.lux
+++ b/stdlib/source/test/lux/data/collection.lux
@@ -14,6 +14,7 @@
["#." queue
["#/." priority]]
["#." set
+ ["#/." multi]
["#/." ordered]]
["#." tree
["#/." zipper]]])
@@ -37,6 +38,7 @@
Test
($_ _.and
/set.test
+ /set/multi.test
/set/ordered.test
))
diff --git a/stdlib/source/test/lux/data/collection/array.lux b/stdlib/source/test/lux/data/collection/array.lux
index e09e502bc..7a5e686ac 100644
--- a/stdlib/source/test/lux/data/collection/array.lux
+++ b/stdlib/source/test/lux/data/collection/array.lux
@@ -31,6 +31,21 @@
(:: random.monad map (|>> (n.% 100) (n.+ 1))
random.nat))
+(def: structures
+ Test
+ (do {! random.monad}
+ [size ..bounded-size]
+ ($_ _.and
+ (_.with-cover [/.equivalence]
+ ($equivalence.spec (/.equivalence n.equivalence) (random.array size random.nat)))
+ (_.with-cover [/.monoid]
+ ($monoid.spec (/.equivalence n.equivalence) /.monoid (random.array size random.nat)))
+ (_.with-cover [/.functor]
+ ($functor.spec ..injection /.equivalence /.functor))
+ (_.with-cover [/.fold]
+ ($fold.spec ..injection /.equivalence /.fold))
+ )))
+
(def: #export test
Test
(<| (_.covering /._)
@@ -43,14 +58,7 @@
#let [expected (n.+ base shift)]
the-array (random.array size random.nat)]
($_ _.and
- (_.with-cover [/.equivalence]
- ($equivalence.spec (/.equivalence n.equivalence) (random.array size random.nat)))
- (_.with-cover [/.monoid]
- ($monoid.spec (/.equivalence n.equivalence) /.monoid (random.array size random.nat)))
- (_.with-cover [/.functor]
- ($functor.spec ..injection /.equivalence /.functor))
- (_.with-cover [/.fold]
- ($fold.spec ..injection /.equivalence /.fold))
+ ..structures
(_.cover [/.new /.size]
(n.= size (/.size (: (Array Nat)
diff --git a/stdlib/source/test/lux/data/collection/set/multi.lux b/stdlib/source/test/lux/data/collection/set/multi.lux
new file mode 100644
index 000000000..039f67200
--- /dev/null
+++ b/stdlib/source/test/lux/data/collection/set/multi.lux
@@ -0,0 +1,216 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [hash (#+ Hash)]
+ [monad (#+ do)]
+ ["." predicate]
+ {[0 #spec]
+ [/
+ ["$." equivalence]]}]
+ [data
+ ["." bit ("#@." equivalence)]
+ [number
+ ["n" nat]]
+ [collection
+ ["." set]
+ ["." list ("#@." fold)]]]
+ [math
+ ["." random (#+ Random)]]]
+ {1
+ ["." /]})
+
+(def: count
+ (Random Nat)
+ (:: random.monad map (|>> (n.% 10) inc) random.nat))
+
+(def: #export (random size hash count element)
+ (All [a] (-> Nat (Hash a) (Random Nat) (Random a) (Random (/.Set a))))
+ (do {! random.monad}
+ [elements (random.set hash size element)
+ element-counts (random.list size ..count)]
+ (wrap (list@fold (function (_ [count element] set)
+ (/.add count element set))
+ (/.new hash)
+ (list.zip/2 element-counts
+ (set.to-list elements))))))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (_.with-cover [/.Set])
+ (do {! random.monad}
+ [diversity (:: ! map (n.% 10) random.nat)
+ sample (..random diversity n.hash ..count random.nat)
+ non-member (random.filter (predicate.complement (set.member? (/.support sample)))
+ random.nat)
+ addition-count ..count
+ partial-removal-count (:: ! map (n.% addition-count) random.nat)
+ another (..random diversity n.hash ..count random.nat)]
+ (`` ($_ _.and
+ (_.with-cover [/.equivalence]
+ ($equivalence.spec /.equivalence (..random diversity n.hash ..count random.nat)))
+
+ (_.cover [/.to-list /.from-list]
+ (|> sample
+ /.to-list
+ (/.from-list n.hash)
+ (:: /.equivalence = sample)))
+ (_.cover [/.size]
+ (n.= (list.size (/.to-list sample))
+ (/.size sample)))
+ (_.cover [/.empty?]
+ (bit@= (/.empty? sample)
+ (n.= 0 (/.size sample))))
+ (_.cover [/.new]
+ (/.empty? (/.new n.hash)))
+ (_.cover [/.support]
+ (list.every? (set.member? (/.support sample))
+ (/.to-list sample)))
+ (_.cover [/.member?]
+ (let [non-member-is-not-identified!
+ (not (/.member? sample non-member))
+
+ all-members-are-identified!
+ (list.every? (/.member? sample)
+ (/.to-list sample))]
+ (and non-member-is-not-identified!
+ all-members-are-identified!)))
+ (_.cover [/.multiplicity]
+ (let [non-members-have-0-multiplicity!
+ (n.= 0 (/.multiplicity sample non-member))
+
+ every-member-has-positive-multiplicity!
+ (list.every? (|>> (/.multiplicity sample) (n.> 0))
+ (/.to-list sample))]
+ (and non-members-have-0-multiplicity!
+ every-member-has-positive-multiplicity!)))
+ (_.cover [/.add]
+ (let [null-scenario!
+ (|> sample
+ (/.add 0 non-member)
+ (:: /.equivalence = sample))
+
+ normal-scenario!
+ (let [sample+ (/.add addition-count non-member sample)]
+ (and (not (/.member? sample non-member))
+ (/.member? sample+ non-member)
+ (n.= addition-count (/.multiplicity sample+ non-member))))]
+ (and null-scenario!
+ normal-scenario!)))
+ (_.cover [/.remove]
+ (let [null-scenario!
+ (:: /.equivalence =
+ (|> sample
+ (/.add addition-count non-member))
+ (|> sample
+ (/.add addition-count non-member)
+ (/.remove 0 non-member)))
+
+ partial-scenario!
+ (let [sample* (|> sample
+ (/.add addition-count non-member)
+ (/.remove partial-removal-count non-member))]
+ (and (/.member? sample* non-member)
+ (n.= (n.- partial-removal-count
+ addition-count)
+ (/.multiplicity sample* non-member))))
+
+ total-scenario!
+ (|> sample
+ (/.add addition-count non-member)
+ (/.remove addition-count non-member)
+ (:: /.equivalence = sample))]
+ (and null-scenario!
+ partial-scenario!
+ total-scenario!)))
+ (_.cover [/.from-set]
+ (let [unary (|> sample /.support /.from-set)]
+ (list.every? (|>> (/.multiplicity unary) (n.= 1))
+ (/.to-list unary))))
+ (_.cover [/.sub?]
+ (let [unary (|> sample /.support /.from-set)]
+ (and (/.sub? sample unary)
+ (or (not (/.sub? unary sample))
+ (:: /.equivalence = sample unary)))))
+ (_.cover [/.super?]
+ (let [unary (|> sample /.support /.from-set)]
+ (and (/.super? unary sample)
+ (or (not (/.super? sample unary))
+ (:: /.equivalence = sample unary)))))
+ (~~ (template [<name> <composition>]
+ [(_.cover [<name>]
+ (let [|sample| (/.support sample)
+ |another| (/.support another)
+ sample-only (set.difference |another| |sample|)
+ another-only (set.difference |sample| |another|)
+ common (set.intersection |sample| |another|)
+ composed (<name> sample another)
+
+ no-left-changes! (list.every? (function (_ member)
+ (n.= (/.multiplicity sample member)
+ (/.multiplicity composed member)))
+ (set.to-list sample-only))
+ no-right-changes! (list.every? (function (_ member)
+ (n.= (/.multiplicity another member)
+ (/.multiplicity composed member)))
+ (set.to-list another-only))
+ common-changes! (list.every? (function (_ member)
+ (n.= (<composition> (/.multiplicity sample member)
+ (/.multiplicity another member))
+ (/.multiplicity composed member)))
+ (set.to-list common))]
+ (and no-left-changes!
+ no-right-changes!
+ common-changes!)))]
+
+ [/.sum n.+]
+ [/.union n.max]
+ ))
+ (_.cover [/.intersection]
+ (let [|sample| (/.support sample)
+ |another| (/.support another)
+ sample-only (set.difference |another| |sample|)
+ another-only (set.difference |sample| |another|)
+ common (set.intersection |sample| |another|)
+ composed (/.intersection sample another)
+
+ left-removals! (list.every? (|>> (/.member? composed) not)
+ (set.to-list sample-only))
+ right-removals! (list.every? (|>> (/.member? composed) not)
+ (set.to-list another-only))
+ common-changes! (list.every? (function (_ member)
+ (n.= (n.min (/.multiplicity sample member)
+ (/.multiplicity another member))
+ (/.multiplicity composed member)))
+ (set.to-list common))]
+ (and left-removals!
+ right-removals!
+ common-changes!)))
+ (_.cover [/.difference]
+ (let [|sample| (/.support sample)
+ |another| (/.support another)
+ sample-only (set.difference |another| |sample|)
+ another-only (set.difference |sample| |another|)
+ common (set.intersection |sample| |another|)
+ composed (/.difference sample another)
+
+ ommissions! (list.every? (|>> (/.member? composed) not)
+ (set.to-list sample-only))
+ intact! (list.every? (function (_ member)
+ (n.= (/.multiplicity another member)
+ (/.multiplicity composed member)))
+ (set.to-list another-only))
+ subtractions! (list.every? (function (_ member)
+ (let [sample-multiplicity (/.multiplicity sample member)
+ another-multiplicity (/.multiplicity another member)]
+ (n.= (if (n.> another-multiplicity sample-multiplicity)
+ 0
+ (n.- sample-multiplicity
+ another-multiplicity))
+ (/.multiplicity composed member))))
+ (set.to-list common))]
+ (and ommissions!
+ intact!
+ subtractions!)))
+ )))))
diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux
index 3a98b5380..2fbfc92b9 100644
--- a/stdlib/source/test/lux/target/jvm.lux
+++ b/stdlib/source/test/lux/target/jvm.lux
@@ -1010,11 +1010,11 @@
(function (_ expected) (|>> (:coerce Text) (text@= (:coerce Text expected))))))
(<| (_.context "multi")
(do {! random.monad}
- [#let [size (:: ! map (|>> (n.% 10) (n.+ 1))
+ [#let [size (:: ! map (|>> (n.% 5) (n.+ 1))
random.nat)]
dimensions size
sizesH size
- sizesT (monad.seq ! (list.repeat (dec dimensions) size))
+ sizesT (random.list (dec dimensions) size)
#let [type (loop [dimensions dimensions
type (: (Type Object)
..$Object)]
diff --git a/stdlib/source/test/lux/world.lux b/stdlib/source/test/lux/world.lux
index c5b0ecc59..a01bdb929 100644
--- a/stdlib/source/test/lux/world.lux
+++ b/stdlib/source/test/lux/world.lux
@@ -3,11 +3,13 @@
["_" test (#+ Test)]]
["." / #_
["#." file]
- ["#." shell]])
+ ["#." shell]
+ ["#." console]])
(def: #export test
Test
($_ _.and
/file.test
/shell.test
+ /console.test
))
diff --git a/stdlib/source/test/lux/world/console.lux b/stdlib/source/test/lux/world/console.lux
new file mode 100644
index 000000000..d17559cec
--- /dev/null
+++ b/stdlib/source/test/lux/world/console.lux
@@ -0,0 +1,43 @@
+(.module:
+ [lux #*
+ ["_" test (#+ Test)]
+ [abstract
+ [monad (#+ do)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]]
+ {1
+ ["." /]}
+ {[1 #spec]
+ ["$." /]})
+
+(exception: dead)
+
+(def: simulation
+ (/.Simulation Bit)
+ (structure
+ (def: (on-read dead?)
+ (if dead?
+ (exception.throw ..dead [])
+ (#try.Success [dead? (char "a")])))
+
+ (def: (on-read-line dead?)
+ (if dead?
+ (exception.throw ..dead [])
+ (#try.Success [dead? "YOLO"])))
+
+ (def: (on-write message dead?)
+ (if dead?
+ (exception.throw ..dead [])
+ (#try.Success dead?)))
+
+ (def: (on-close dead?)
+ (if dead?
+ (exception.throw ..dead [])
+ (#try.Success true)))))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ (_.with-cover [/.mock /.Simulation]
+ ($/.spec (/.mock ..simulation false)))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 18:27:22 +0000