From 11cc4a67001162d689eb827f755424a07b99fccb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 5 Nov 2020 02:31:55 -0400 Subject: Lightweight machinery for agent-oriented programming. --- stdlib/source/lux.lux | 21 +- stdlib/source/lux/control/concurrency/actor.lux | 31 ++- stdlib/source/lux/control/concurrency/atom.lux | 2 +- stdlib/source/lux/control/concurrency/frp.lux | 17 +- stdlib/source/lux/data/collection/dictionary.lux | 4 + stdlib/source/lux/data/collection/set.lux | 4 + stdlib/source/lux/data/collection/set/multi.lux | 165 ++++++++-------- stdlib/source/lux/world/console.lux | 114 ++++++++--- stdlib/source/spec/lux/world/console.lux | 49 +++++ .../source/test/lux/control/concurrency/actor.lux | 54 +++++- stdlib/source/test/lux/control/concurrency/frp.lux | 21 +- stdlib/source/test/lux/data/collection.lux | 2 + stdlib/source/test/lux/data/collection/array.lux | 24 ++- .../source/test/lux/data/collection/set/multi.lux | 216 +++++++++++++++++++++ stdlib/source/test/lux/target/jvm.lux | 4 +- stdlib/source/test/lux/world.lux | 4 +- stdlib/source/test/lux/world/console.lux | 43 ++++ 17 files changed, 627 insertions(+), 148 deletions(-) create mode 100644 stdlib/source/spec/lux/world/console.lux create mode 100644 stdlib/source/test/lux/data/collection/set/multi.lux create mode 100644 stdlib/source/test/lux/world/console.lux (limited to 'stdlib') 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) (All [k v] (-> (Hash k) (Dictionary k v))) {#hash Hash 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 [ ] + [(def: #export ( parameter subject) + (All [a] (-> (Set a) (Set a) (Set a))) + (:abstraction (dictionary.merge-with (: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 _]) (:representation set)] + (let [(^@ set [hash _]) (:representation set)] (|> set dictionary.keys - (//.from-list Hash)))) + (//.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 _] set] - (list;fold (function (_ [elem count] acc) - (|> elem (:: Hash 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 subject) +(def: #export (from-list hash subject) (All [a] (-> (Hash a) (List a) (Set a))) - (list;fold ..add/1 (..new Hash) 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 [] @@ -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 @@ ( (|>> (!.use (:: console )) 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 [ (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 - (as-is ) - })) + (|>> (exception.throw ..cannot-close) wrap))))))))))] + (for {@.old (as-is ) + @.jvm (as-is )})) (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 [ ] + [(def: + (..can-read + (function (_ _) + (stm.commit + (do {! stm.monad} + [|state| (stm.read state)] + (case (:: 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 [ ] + [(_.cover [] + (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 ( 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.= ( (/.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))))) -- cgit v1.2.3