diff options
Diffstat (limited to 'stdlib/source/library/lux/control')
| -rw-r--r-- | stdlib/source/library/lux/control/concurrency/actor.lux | 327 | ||||
| -rw-r--r-- | stdlib/source/library/lux/control/concurrency/async.lux | 114 | ||||
| -rw-r--r-- | stdlib/source/library/lux/control/concurrency/atom.lux | 46 | ||||
| -rw-r--r-- | stdlib/source/library/lux/control/concurrency/semaphore.lux | 234 | ||||
| -rw-r--r-- | stdlib/source/library/lux/control/concurrency/stm.lux | 92 | ||||
| -rw-r--r-- | stdlib/source/library/lux/control/io.lux | 76 | ||||
| -rw-r--r-- | stdlib/source/library/lux/control/lazy.lux | 32 | ||||
| -rw-r--r-- | stdlib/source/library/lux/control/security/capability.lux | 78 | ||||
| -rw-r--r-- | stdlib/source/library/lux/control/security/policy.lux | 146 | ||||
| -rw-r--r-- | stdlib/source/library/lux/control/thread.lux | 66 |
10 files changed, 590 insertions, 621 deletions
diff --git a/stdlib/source/library/lux/control/concurrency/actor.lux b/stdlib/source/library/lux/control/concurrency/actor.lux index d127feec3..27d413c10 100644 --- a/stdlib/source/library/lux/control/concurrency/actor.lux +++ b/stdlib/source/library/lux/control/concurrency/actor.lux @@ -23,12 +23,11 @@ ["[0]" code] [syntax {"+" [syntax:]} ["|[0]|" input] - ["|[0]|" annotations]]] + ["|[0]|" export]]] [math [number ["n" nat]]] - ["[0]" meta {"+" [monad]} - ["[0]" annotation]] + ["[0]" meta {"+" [monad]}] [type {"+" [:sharing]} ["[0]" abstract {"+" [abstract: :representation :abstraction]}]]]] [// @@ -63,138 +62,136 @@ (in #.End)))) (abstract: .public (Actor s) - {} - (Record [#obituary [(Async <Obituary>) (Resolver <Obituary>)] #mailbox (Atom <Mailbox>)]) - (type: .public (Mail s) - <Mail>) - - (type: .public (Obituary s) - <Obituary>) - - (type: .public (Behavior o s) - (Record - [#on_init (-> o s) - #on_mail (-> (Mail s) s (Actor s) (Async (Try s)))])) - - (def: .public (spawn! behavior init) - (All (_ o s) (-> (Behavior o s) o (IO (Actor s)))) - (io (let [[on_init on_mail] behavior - self (:sharing [o s] - (Behavior o s) - behavior - - (Actor s) - (:abstraction [#obituary (async.async []) - #mailbox (atom (async.async []))])) - process (loop [state (on_init init) - [|mailbox| _] (io.run! (atom.read! (value@ #mailbox (:representation self))))] - (do [! async.monad] - [[head tail] |mailbox| - ?state' (on_mail head state self)] - (case ?state' - (#try.Failure error) - (let [[_ resolve] (value@ #obituary (:representation self))] - (exec (io.run! - (do io.monad - [pending (..pending tail)] - (resolve [error state (#.Item head pending)]))) - (in []))) - - (#try.Success state') - (recur state' tail))))] - self))) - - (def: .public (alive? actor) - (All (_ s) (-> (Actor s) (IO Bit))) - (let [[obituary _] (value@ #obituary (:representation actor))] - (|> obituary - async.value - (\ io.functor each - (|>> (case> #.None - bit.yes - - _ - bit.no)))))) - - (def: .public (obituary' actor) - (All (_ s) (-> (Actor s) (IO (Maybe (Obituary s))))) - (let [[obituary _] (value@ #obituary (:representation actor))] - (async.value obituary))) - - (def: .public obituary - (All (_ s) (-> (Actor s) (Async (Obituary s)))) - (|>> :representation - (value@ #obituary) - product.left)) - - (def: .public (mail! mail actor) - (All (_ s) (-> (Mail s) (Actor s) (IO (Try Any)))) - (do [! io.monad] - [alive? (..alive? actor)] - (if alive? - (let [entry [mail (async.async [])]] - (do ! - [|mailbox|&resolve (atom.read! (value@ #mailbox (:representation actor)))] - (loop [[|mailbox| resolve] |mailbox|&resolve] - (do ! - [|mailbox| (async.value |mailbox|)] - (case |mailbox| - #.None - (do ! - [resolved? (resolve entry)] - (if resolved? - (do ! - [_ (atom.write! (product.right entry) (value@ #mailbox (:representation actor)))] - (in (#try.Success []))) - (recur |mailbox|&resolve))) - - (#.Some [_ |mailbox|']) - (recur |mailbox|')))))) - (in (exception.except ..dead []))))) - - (type: .public (Message s o) - (-> s (Actor s) (Async (Try [s o])))) - - (def: (mail message) - (All (_ s o) (-> (Message s o) [(Async (Try o)) (Mail s)])) - (let [[async resolve] (:sharing [s o] - (Message s o) - message - - [(Async (Try o)) - (Resolver (Try o))] - (async.async []))] - [async - (function (_ state self) - (do [! async.monad] - [outcome (message state self)] - (case outcome - (#try.Success [state' return]) - (exec - (io.run! (resolve (#try.Success return))) - (async.resolved (#try.Success state'))) - - (#try.Failure error) - (exec - (io.run! (resolve (#try.Failure error))) - (async.resolved (#try.Failure error))))))])) - - (def: .public (tell! message actor) - (All (_ s o) (-> (Message s o) (Actor s) (Async (Try o)))) - (let [[async mail] (..mail message)] - (do async.monad - [outcome (async.future (..mail! mail actor))] - (case outcome - (#try.Success) - async - - (#try.Failure error) - (in (#try.Failure error)))))) + [(type: .public (Mail s) + <Mail>) + + (type: .public (Obituary s) + <Obituary>) + + (type: .public (Behavior o s) + (Record + [#on_init (-> o s) + #on_mail (-> (Mail s) s (Actor s) (Async (Try s)))])) + + (def: .public (spawn! behavior init) + (All (_ o s) (-> (Behavior o s) o (IO (Actor s)))) + (io (let [[on_init on_mail] behavior + self (:sharing [o s] + (Behavior o s) + behavior + + (Actor s) + (:abstraction [#obituary (async.async []) + #mailbox (atom (async.async []))])) + process (loop [state (on_init init) + [|mailbox| _] (io.run! (atom.read! (value@ #mailbox (:representation self))))] + (do [! async.monad] + [[head tail] |mailbox| + ?state' (on_mail head state self)] + (case ?state' + (#try.Failure error) + (let [[_ resolve] (value@ #obituary (:representation self))] + (exec (io.run! + (do io.monad + [pending (..pending tail)] + (resolve [error state (#.Item head pending)]))) + (in []))) + + (#try.Success state') + (recur state' tail))))] + self))) + + (def: .public (alive? actor) + (All (_ s) (-> (Actor s) (IO Bit))) + (let [[obituary _] (value@ #obituary (:representation actor))] + (|> obituary + async.value + (\ io.functor each + (|>> (case> #.None + bit.yes + + _ + bit.no)))))) + + (def: .public (obituary' actor) + (All (_ s) (-> (Actor s) (IO (Maybe (Obituary s))))) + (let [[obituary _] (value@ #obituary (:representation actor))] + (async.value obituary))) + + (def: .public obituary + (All (_ s) (-> (Actor s) (Async (Obituary s)))) + (|>> :representation + (value@ #obituary) + product.left)) + + (def: .public (mail! mail actor) + (All (_ s) (-> (Mail s) (Actor s) (IO (Try Any)))) + (do [! io.monad] + [alive? (..alive? actor)] + (if alive? + (let [entry [mail (async.async [])]] + (do ! + [|mailbox|&resolve (atom.read! (value@ #mailbox (:representation actor)))] + (loop [[|mailbox| resolve] |mailbox|&resolve] + (do ! + [|mailbox| (async.value |mailbox|)] + (case |mailbox| + #.None + (do ! + [resolved? (resolve entry)] + (if resolved? + (do ! + [_ (atom.write! (product.right entry) (value@ #mailbox (:representation actor)))] + (in (#try.Success []))) + (recur |mailbox|&resolve))) + + (#.Some [_ |mailbox|']) + (recur |mailbox|')))))) + (in (exception.except ..dead []))))) + + (type: .public (Message s o) + (-> s (Actor s) (Async (Try [s o])))) + + (def: (mail message) + (All (_ s o) (-> (Message s o) [(Async (Try o)) (Mail s)])) + (let [[async resolve] (:sharing [s o] + (Message s o) + message + + [(Async (Try o)) + (Resolver (Try o))] + (async.async []))] + [async + (function (_ state self) + (do [! async.monad] + [outcome (message state self)] + (case outcome + (#try.Success [state' return]) + (exec + (io.run! (resolve (#try.Success return))) + (async.resolved (#try.Success state'))) + + (#try.Failure error) + (exec + (io.run! (resolve (#try.Failure error))) + (async.resolved (#try.Failure error))))))])) + + (def: .public (tell! message actor) + (All (_ s o) (-> (Message s o) (Actor s) (Async (Try o)))) + (let [[async mail] (..mail message)] + (do async.monad + [outcome (async.future (..mail! mail actor))] + (case outcome + (#try.Success) + async + + (#try.Failure error) + (in (#try.Failure error))))))] ) ) @@ -228,13 +225,18 @@ (Parser Text) <code>.local_identifier) +(def: on_mail^ + (Parser (Maybe On_MailC)) + (<>.maybe (<code>.form (<>.and (<code>.form (<>.after (<code>.this! (' on_mail)) + ($_ <>.and ..argument ..argument ..argument))) + <code>.any)))) + (def: behavior^ (Parser BehaviorC) - (let [on_mail_args ($_ <>.and ..argument ..argument ..argument)] - ($_ <>.and - (<>.maybe (<code>.form (<>.and (<code>.form (<>.after (<code>.this! (' on_mail)) on_mail_args)) - <code>.any))) - (<>.some <code>.any)))) + (<code>.tuple + ($_ <>.and + ..on_mail^ + (<>.some <code>.any)))) (def: (on_mail g!_ ?on_mail) (-> Code (Maybe On_MailC) Code) @@ -250,37 +252,32 @@ (~ bodyC))))) (def: actorP - (Parser [Code [Text (List Text)] |annotations|.Annotations Code BehaviorC]) - (let [private ($_ <>.and - ..actor_decl^ - |annotations|.parser - <code>.any - behavior^)] - ($_ <>.either - (<>.and <code>.any private) - (<>.and (<>\in (` .private)) private)))) - -(syntax: .public (actor: [[export_policy [name vars] annotations state_type [?on_mail messages]] ..actorP]) + (Parser [Code [Text (List Text)] Code BehaviorC]) + (|export|.parser + ($_ <>.and + ..actor_decl^ + <code>.any + behavior^))) + +(syntax: .public (actor: [[export_policy [name vars] state_type [?on_mail messages]] ..actorP]) (with_identifiers [g!_] (do meta.monad [g!type (macro.identifier (format name "_abstract_type")) .let [g!actor (code.local_identifier name) g!vars (list\each code.local_identifier vars)]] (in (list (` ((~! abstract:) (~ export_policy) ((~ g!type) (~+ g!vars)) - {} - (~ state_type) - (def: (~ export_policy) (~ g!actor) - (All ((~ g!_) (~+ g!vars)) - (..Behavior (~ state_type) ((~ g!type) (~+ g!vars)))) - [#..on_init (|>> ((~! abstract.:abstraction) (~ g!type))) - #..on_mail (~ (..on_mail g!_ ?on_mail))]) + [(def: (~ export_policy) (~ g!actor) + (All ((~ g!_) (~+ g!vars)) + (..Behavior (~ state_type) ((~ g!type) (~+ g!vars)))) + [#..on_init (|>> ((~! abstract.:abstraction) (~ g!type))) + #..on_mail (~ (..on_mail g!_ ?on_mail))]) - (~+ messages)))))))) + (~+ messages)]))))))) (syntax: .public (actor [[state_type init] (<code>.record (<>.and <code>.any <code>.any)) - [?on_mail messages] behavior^]) + ?on_mail on_mail^]) (with_identifiers [g!_] (in (list (` (: ((~! io.IO) (..Actor (~ state_type))) (..spawn! (: (..Behavior (~ state_type) (~ state_type)) @@ -312,17 +309,14 @@ (<>.and <code>.identifier (\ <>.monad in (list))))) (def: messageP - (Parser [Code Signature |annotations|.Annotations Code Code]) - (let [private ($_ <>.and - ..signature^ - (<>.else |annotations|.empty |annotations|.parser) - <code>.any - <code>.any)] - ($_ <>.either - (<>.and <code>.any private) - (<>.and (<>\in (` .private)) private)))) - -(syntax: .public (message: [[export_policy signature annotations output_type body] ..messageP]) + (Parser [Code Signature Code Code]) + (|export|.parser + ($_ <>.and + ..signature^ + <code>.any + <code>.any))) + +(syntax: .public (message: [[export_policy signature output_type body] ..messageP]) (with_identifiers [g!_ g!return] (do meta.monad [actor_scope abstract.current @@ -335,7 +329,6 @@ g!state (|> signature (value@ #state) code.local_identifier) g!self (|> signature (value@ #self) code.local_identifier)]] (in (list (` (def: (~ export_policy) ((~ g!message) (~+ g!inputsC)) - (~ (|annotations|.format annotations)) (All ((~ g!_) (~+ g!all_vars)) (-> (~+ g!inputsT) (..Message (~ (value@ #abstract.abstraction actor_scope)) diff --git a/stdlib/source/library/lux/control/concurrency/async.lux b/stdlib/source/library/lux/control/concurrency/async.lux index aec52dcf9..903ac8bd9 100644 --- a/stdlib/source/library/lux/control/concurrency/async.lux +++ b/stdlib/source/library/lux/control/concurrency/async.lux @@ -18,66 +18,64 @@ ["[0]" atom {"+" [Atom atom]}]]) (abstract: .public (Async a) - {} - (Atom [(Maybe a) (List (-> a (IO Any)))]) - (type: .public (Resolver a) - (-> a (IO Bit))) - - ... Sets an async's value if it has not been done yet. - (def: (resolver async) - (All (_ a) (-> (Async a) (Resolver a))) - (function (resolve value) - (let [async (:representation async)] - (do [! io.monad] - [(^@ old [_value _observers]) (atom.read! async)] - (case _value - (#.Some _) - (in #0) - - #.None - (do ! - [.let [new [(#.Some value) #.None]] - succeeded? (atom.compare_and_swap! old new async)] - (if succeeded? - (do ! - [_ (monad.each ! (function (_ f) (f value)) - _observers)] - (in #1)) - (resolve value)))))))) - - (def: .public (resolved value) - (All (_ a) (-> a (Async a))) - (:abstraction (atom [(#.Some value) (list)]))) - - (def: .public (async _) - (All (_ a) (-> Any [(Async a) (Resolver a)])) - (let [async (:abstraction (atom [#.None (list)]))] - [async (..resolver async)])) - - (def: .public value - (All (_ a) (-> (Async a) (IO (Maybe a)))) - (|>> :representation - atom.read! - (\ io.functor each product.left))) - - (def: .public (upon! f async) - (All (_ a) (-> (-> a (IO Any)) (Async a) (IO Any))) - (do [! io.monad] - [.let [async (:representation async)] - (^@ old [_value _observers]) (atom.read! async)] - (case _value - (#.Some value) - (f value) - - #.None - (let [new [_value (#.Item f _observers)]] - (do ! - [swapped? (atom.compare_and_swap! old new async)] - (if swapped? - (in []) - (upon! f (:abstraction async)))))))) + [(type: .public (Resolver a) + (-> a (IO Bit))) + + ... Sets an async's value if it has not been done yet. + (def: (resolver async) + (All (_ a) (-> (Async a) (Resolver a))) + (function (resolve value) + (let [async (:representation async)] + (do [! io.monad] + [(^@ old [_value _observers]) (atom.read! async)] + (case _value + (#.Some _) + (in #0) + + #.None + (do ! + [.let [new [(#.Some value) #.None]] + succeeded? (atom.compare_and_swap! old new async)] + (if succeeded? + (do ! + [_ (monad.each ! (function (_ f) (f value)) + _observers)] + (in #1)) + (resolve value)))))))) + + (def: .public (resolved value) + (All (_ a) (-> a (Async a))) + (:abstraction (atom [(#.Some value) (list)]))) + + (def: .public (async _) + (All (_ a) (-> Any [(Async a) (Resolver a)])) + (let [async (:abstraction (atom [#.None (list)]))] + [async (..resolver async)])) + + (def: .public value + (All (_ a) (-> (Async a) (IO (Maybe a)))) + (|>> :representation + atom.read! + (\ io.functor each product.left))) + + (def: .public (upon! f async) + (All (_ a) (-> (-> a (IO Any)) (Async a) (IO Any))) + (do [! io.monad] + [.let [async (:representation async)] + (^@ old [_value _observers]) (atom.read! async)] + (case _value + (#.Some value) + (f value) + + #.None + (let [new [_value (#.Item f _observers)]] + (do ! + [swapped? (atom.compare_and_swap! old new async)] + (if swapped? + (in []) + (upon! f (:abstraction async))))))))] ) (def: .public resolved? diff --git a/stdlib/source/library/lux/control/concurrency/atom.lux b/stdlib/source/library/lux/control/concurrency/atom.lux index 802ea9298..6309f4f35 100644 --- a/stdlib/source/library/lux/control/concurrency/atom.lux +++ b/stdlib/source/library/lux/control/concurrency/atom.lux @@ -47,37 +47,35 @@ @.scheme "scheme array read"} (as_is))] (abstract: .public (Atom a) - {} - (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference a)] (for {@.old <jvm> @.jvm <jvm>} (array.Array a))) - (def: .public (atom value) - (All (_ a) (-> a (Atom a))) - (:abstraction (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::new value)] - (for {@.old <jvm> - @.jvm <jvm>} - (<write> 0 value (<new> 1)))))) + [(def: .public (atom value) + (All (_ a) (-> a (Atom a))) + (:abstraction (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::new value)] + (for {@.old <jvm> + @.jvm <jvm>} + (<write> 0 value (<new> 1)))))) - (def: .public (read! atom) - (All (_ a) (-> (Atom a) (IO a))) - (io.io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::get (:representation atom))] - (for {@.old <jvm> - @.jvm <jvm>} - (<read> 0 (:representation atom)))))) + (def: .public (read! atom) + (All (_ a) (-> (Atom a) (IO a))) + (io.io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::get (:representation atom))] + (for {@.old <jvm> + @.jvm <jvm>} + (<read> 0 (:representation atom)))))) - (def: .public (compare_and_swap! current new atom) - (All (_ a) (-> a a (Atom a) (IO Bit))) - (io.io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom))] - (for {@.old <jvm> - @.jvm <jvm>} - (let [old (<read> 0 (:representation atom))] - (if (same? old current) - (exec (<write> 0 new (:representation atom)) - true) - false)))))) + (def: .public (compare_and_swap! current new atom) + (All (_ a) (-> a a (Atom a) (IO Bit))) + (io.io (with_expansions [<jvm> (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom))] + (for {@.old <jvm> + @.jvm <jvm>} + (let [old (<read> 0 (:representation atom))] + (if (same? old current) + (exec (<write> 0 new (:representation atom)) + true) + false))))))] )) (def: .public (update! f atom) diff --git a/stdlib/source/library/lux/control/concurrency/semaphore.lux b/stdlib/source/library/lux/control/concurrency/semaphore.lux index 3b0461579..bcbd71158 100644 --- a/stdlib/source/library/lux/control/concurrency/semaphore.lux +++ b/stdlib/source/library/lux/control/concurrency/semaphore.lux @@ -31,95 +31,91 @@ #waiting_list (Queue (Resolver Any))])) (abstract: .public Semaphore - {} - (Atom State) - (def: most_positions_possible - (.nat (\ i.interval top))) - - (def: .public (semaphore initial_open_positions) - (-> Nat Semaphore) - (let [max_positions (n.min initial_open_positions - ..most_positions_possible)] - (:abstraction (atom.atom [#max_positions max_positions - #open_positions (.int max_positions) - #waiting_list queue.empty])))) - - (def: .public (wait! semaphore) - (Ex (_ k) (-> Semaphore (Async Any))) - (let [semaphore (:representation semaphore) - [signal sink] (: [(Async Any) (Resolver Any)] - (async.async []))] - (exec - (io.run! - (with_expansions [<had_open_position?> (as_is (value@ #open_positions) (i.> -1))] - (do io.monad - [[_ state'] (atom.update! (|>> (revised@ #open_positions --) - (if> [<had_open_position?>] - [] - [(revised@ #waiting_list (queue.end sink))])) - semaphore)] - (with_expansions [<go_ahead> (sink []) - <get_in_line> (in false)] - (if (|> state' <had_open_position?>) - <go_ahead> - <get_in_line>))))) - signal))) - - (exception: .public (semaphore_is_maxed_out {max_positions Nat}) - (exception.report - ["Max Positions" (%.nat max_positions)])) - - (def: .public (signal! semaphore) - (Ex (_ k) (-> Semaphore (Async (Try Int)))) - (let [semaphore (:representation semaphore)] - (async.future - (do [! io.monad] - [[pre post] (atom.update! (function (_ state) - (if (i.= (.int (value@ #max_positions state)) - (value@ #open_positions state)) - state - (|> state - (revised@ #open_positions ++) - (revised@ #waiting_list queue.next)))) - semaphore)] - (if (same? pre post) - (in (exception.except ..semaphore_is_maxed_out [(value@ #max_positions pre)])) - (do ! - [_ (case (queue.front (value@ #waiting_list pre)) - #.None - (in true) - - (#.Some sink) - (sink []))] - (in (#try.Success (value@ #open_positions post))))))))) + [(def: most_positions_possible + (.nat (\ i.interval top))) + + (def: .public (semaphore initial_open_positions) + (-> Nat Semaphore) + (let [max_positions (n.min initial_open_positions + ..most_positions_possible)] + (:abstraction (atom.atom [#max_positions max_positions + #open_positions (.int max_positions) + #waiting_list queue.empty])))) + + (def: .public (wait! semaphore) + (Ex (_ k) (-> Semaphore (Async Any))) + (let [semaphore (:representation semaphore) + [signal sink] (: [(Async Any) (Resolver Any)] + (async.async []))] + (exec + (io.run! + (with_expansions [<had_open_position?> (as_is (value@ #open_positions) (i.> -1))] + (do io.monad + [[_ state'] (atom.update! (|>> (revised@ #open_positions --) + (if> [<had_open_position?>] + [] + [(revised@ #waiting_list (queue.end sink))])) + semaphore)] + (with_expansions [<go_ahead> (sink []) + <get_in_line> (in false)] + (if (|> state' <had_open_position?>) + <go_ahead> + <get_in_line>))))) + signal))) + + (exception: .public (semaphore_is_maxed_out {max_positions Nat}) + (exception.report + ["Max Positions" (%.nat max_positions)])) + + (def: .public (signal! semaphore) + (Ex (_ k) (-> Semaphore (Async (Try Int)))) + (let [semaphore (:representation semaphore)] + (async.future + (do [! io.monad] + [[pre post] (atom.update! (function (_ state) + (if (i.= (.int (value@ #max_positions state)) + (value@ #open_positions state)) + state + (|> state + (revised@ #open_positions ++) + (revised@ #waiting_list queue.next)))) + semaphore)] + (if (same? pre post) + (in (exception.except ..semaphore_is_maxed_out [(value@ #max_positions pre)])) + (do ! + [_ (case (queue.front (value@ #waiting_list pre)) + #.None + (in true) + + (#.Some sink) + (sink []))] + (in (#try.Success (value@ #open_positions post)))))))))] ) (abstract: .public Mutex - {} - Semaphore - (def: .public (mutex _) - (-> Any Mutex) - (:abstraction (semaphore 1))) - - (def: acquire! - (-> Mutex (Async Any)) - (|>> :representation ..wait!)) - - (def: release! - (-> Mutex (Async Any)) - (|>> :representation ..signal!)) - - (def: .public (synchronize! mutex procedure) - (All (_ a) (-> Mutex (IO (Async a)) (Async a))) - (do async.monad - [_ (..acquire! mutex) - output (io.run! procedure) - _ (..release! mutex)] - (in output))) + [(def: .public (mutex _) + (-> Any Mutex) + (:abstraction (semaphore 1))) + + (def: acquire! + (-> Mutex (Async Any)) + (|>> :representation ..wait!)) + + (def: release! + (-> Mutex (Async Any)) + (|>> :representation ..signal!)) + + (def: .public (synchronize! mutex procedure) + (All (_ a) (-> Mutex (IO (Async a)) (Async a))) + (do async.monad + [_ (..acquire! mutex) + output (io.run! procedure) + _ (..release! mutex)] + (in output)))] ) (def: .public limit @@ -129,49 +125,47 @@ (:~ (refinement.type limit))) (abstract: .public Barrier - {} - (Record [#limit Limit #count (Atom Nat) #start_turnstile Semaphore #end_turnstile Semaphore]) - (def: .public (barrier limit) - (-> Limit Barrier) - (:abstraction [#limit limit - #count (atom.atom 0) - #start_turnstile (..semaphore 0) - #end_turnstile (..semaphore 0)])) - - (def: (un_block! times turnstile) - (-> Nat Semaphore (Async Any)) - (loop [step 0] - (if (n.< times step) + [(def: .public (barrier limit) + (-> Limit Barrier) + (:abstraction [#limit limit + #count (atom.atom 0) + #start_turnstile (..semaphore 0) + #end_turnstile (..semaphore 0)])) + + (def: (un_block! times turnstile) + (-> Nat Semaphore (Async Any)) + (loop [step 0] + (if (n.< times step) + (do async.monad + [outcome (..signal! turnstile)] + (recur (++ step))) + (\ async.monad in [])))) + + (template [<phase> <update> <goal> <turnstile>] + [(def: (<phase> (^:representation barrier)) + (-> Barrier (Async Any)) (do async.monad - [outcome (..signal! turnstile)] - (recur (++ step))) - (\ async.monad in [])))) - - (template [<phase> <update> <goal> <turnstile>] - [(def: (<phase> (^:representation barrier)) - (-> Barrier (Async Any)) - (do async.monad - [.let [limit (refinement.value (value@ #limit barrier)) - goal <goal> - [_ count] (io.run! (atom.update! <update> (value@ #count barrier))) - reached? (n.= goal count)]] - (if reached? - (..un_block! (-- limit) (value@ <turnstile> barrier)) - (..wait! (value@ <turnstile> barrier)))))] - - [start! ++ limit #start_turnstile] - [end! -- 0 #end_turnstile] - ) - - (def: .public (block! barrier) - (-> Barrier (Async Any)) - (do async.monad - [_ (..start! barrier)] - (..end! barrier))) + [.let [limit (refinement.value (value@ #limit barrier)) + goal <goal> + [_ count] (io.run! (atom.update! <update> (value@ #count barrier))) + reached? (n.= goal count)]] + (if reached? + (..un_block! (-- limit) (value@ <turnstile> barrier)) + (..wait! (value@ <turnstile> barrier)))))] + + [start! ++ limit #start_turnstile] + [end! -- 0 #end_turnstile] + ) + + (def: .public (block! barrier) + (-> Barrier (Async Any)) + (do async.monad + [_ (..start! barrier)] + (..end! barrier)))] ) diff --git a/stdlib/source/library/lux/control/concurrency/stm.lux b/stdlib/source/library/lux/control/concurrency/stm.lux index c62540890..6b89926ff 100644 --- a/stdlib/source/library/lux/control/concurrency/stm.lux +++ b/stdlib/source/library/lux/control/concurrency/stm.lux @@ -24,55 +24,53 @@ (-> a (IO Any))) (abstract: .public (Var a) - {} - (Atom [a (List (Sink a))]) - (def: .public (var value) - (All (_ a) (-> a (Var a))) - (:abstraction (atom.atom [value (list)]))) - - (def: read! - (All (_ a) (-> (Var a) a)) - (|>> :representation atom.read! io.run! product.left)) - - (def: (un_follow! sink var) - (All (_ a) (-> (Sink a) (Var a) (IO Any))) - (do io.monad - [_ (atom.update! (function (_ [value observers]) - [value (list.only (|>> (same? sink) not) observers)]) - (:representation var))] - (in []))) - - (def: (write! new_value var) - (All (_ a) (-> a (Var a) (IO Any))) - (do [! io.monad] - [.let [var' (:representation var)] - (^@ old [old_value observers]) (atom.read! var') - succeeded? (atom.compare_and_swap! old [new_value observers] var')] - (if succeeded? - (do ! - [_ (monad.each ! (function (_ sink) - (do ! - [result (\ sink feed new_value)] - (case result - (#try.Success _) - (in []) - - (#try.Failure _) - (un_follow! sink var)))) - observers)] - (in [])) - (write! new_value var)))) - - (def: .public (follow! target) - (All (_ a) (-> (Var a) (IO [(Channel a) (Sink a)]))) - (do io.monad - [.let [[channel sink] (frp.channel [])] - _ (atom.update! (function (_ [value observers]) - [value (#.Item sink observers)]) - (:representation target))] - (in [channel sink]))) + [(def: .public (var value) + (All (_ a) (-> a (Var a))) + (:abstraction (atom.atom [value (list)]))) + + (def: read! + (All (_ a) (-> (Var a) a)) + (|>> :representation atom.read! io.run! product.left)) + + (def: (un_follow! sink var) + (All (_ a) (-> (Sink a) (Var a) (IO Any))) + (do io.monad + [_ (atom.update! (function (_ [value observers]) + [value (list.only (|>> (same? sink) not) observers)]) + (:representation var))] + (in []))) + + (def: (write! new_value var) + (All (_ a) (-> a (Var a) (IO Any))) + (do [! io.monad] + [.let [var' (:representation var)] + (^@ old [old_value observers]) (atom.read! var') + succeeded? (atom.compare_and_swap! old [new_value observers] var')] + (if succeeded? + (do ! + [_ (monad.each ! (function (_ sink) + (do ! + [result (\ sink feed new_value)] + (case result + (#try.Success _) + (in []) + + (#try.Failure _) + (un_follow! sink var)))) + observers)] + (in [])) + (write! new_value var)))) + + (def: .public (follow! target) + (All (_ a) (-> (Var a) (IO [(Channel a) (Sink a)]))) + (do io.monad + [.let [[channel sink] (frp.channel [])] + _ (atom.update! (function (_ [value observers]) + [value (#.Item sink observers)]) + (:representation target))] + (in [channel sink])))] ) (type: (Tx_Frame a) diff --git a/stdlib/source/library/lux/control/io.lux b/stdlib/source/library/lux/control/io.lux index 8ff12b40b..654415bd3 100644 --- a/stdlib/source/library/lux/control/io.lux +++ b/stdlib/source/library/lux/control/io.lux @@ -15,54 +15,52 @@ ["[0]" template]]]]) (abstract: .public (IO a) - {} - (-> Any a) - (def: label - (All (_ _ a) (-> (-> Any a) (IO a))) - (|>> :abstraction)) + [(def: label + (All (_ _ a) (-> (-> Any a) (IO a))) + (|>> :abstraction)) - (template: (!io computation) - [(:abstraction (template.with_locals [g!func g!arg] - (function (g!func g!arg) - computation)))]) + (template: (!io computation) + [(:abstraction (template.with_locals [g!func g!arg] + (function (g!func g!arg) + computation)))]) - (template: (run!' io) - ... creatio ex nihilo - [((:representation io) [])]) + (template: (run!' io) + ... creatio ex nihilo + [((:representation io) [])]) - (syntax: .public (io [computation <code>.any]) - (with_identifiers [g!func g!arg] - (in (list (` ((~! ..label) (function ((~ g!func) (~ g!arg)) - (~ computation)))))))) + (syntax: .public (io [computation <code>.any]) + (with_identifiers [g!func g!arg] + (in (list (` ((~! ..label) (function ((~ g!func) (~ g!arg)) + (~ computation)))))))) - (def: .public run! - (All (_ _ a) (-> (IO a) a)) - (|>> ..run!')) + (def: .public run! + (All (_ _ a) (-> (IO a) a)) + (|>> ..run!')) - (implementation: .public functor - (Functor IO) - - (def: (each f) - (|>> ..run!' f !io))) + (implementation: .public functor + (Functor IO) + + (def: (each f) + (|>> ..run!' f !io))) - (implementation: .public apply - (Apply IO) - - (def: &functor ..functor) + (implementation: .public apply + (Apply IO) + + (def: &functor ..functor) - (def: (on fa ff) - (!io ((..run!' ff) (..run!' fa))))) + (def: (on fa ff) + (!io ((..run!' ff) (..run!' fa))))) - (implementation: .public monad - (Monad IO) - - (def: &functor ..functor) + (implementation: .public monad + (Monad IO) + + (def: &functor ..functor) - (def: in - (|>> !io)) - - (def: conjoint - (|>> ..run!' ..run!' !io))) + (def: in + (|>> !io)) + + (def: conjoint + (|>> ..run!' ..run!' !io)))] ) diff --git a/stdlib/source/library/lux/control/lazy.lux b/stdlib/source/library/lux/control/lazy.lux index e38166d14..16b501d9e 100644 --- a/stdlib/source/library/lux/control/lazy.lux +++ b/stdlib/source/library/lux/control/lazy.lux @@ -18,27 +18,25 @@ abstract]]]) (abstract: .public (Lazy a) - {} - (-> [] a) - (def: (lazy' generator) - (All (_ a) (-> (-> [] a) (Lazy a))) - (let [cache (atom.atom #.None)] - (:abstraction (function (_ _) - (case (io.run! (atom.read! cache)) - (#.Some value) - value + [(def: (lazy' generator) + (All (_ a) (-> (-> [] a) (Lazy a))) + (let [cache (atom.atom #.None)] + (:abstraction (function (_ _) + (case (io.run! (atom.read! cache)) + (#.Some value) + value - _ - (let [value (generator [])] - (exec - (io.run! (atom.compare_and_swap! _ (#.Some value) cache)) - value))))))) + _ + (let [value (generator [])] + (exec + (io.run! (atom.compare_and_swap! _ (#.Some value) cache)) + value))))))) - (def: .public (value lazy) - (All (_ a) (-> (Lazy a) a)) - ((:representation lazy) []))) + (def: .public (value lazy) + (All (_ a) (-> (Lazy a) a)) + ((:representation lazy) []))]) (syntax: .public (lazy [expression <code>.any]) (with_identifiers [g!_] diff --git a/stdlib/source/library/lux/control/security/capability.lux b/stdlib/source/library/lux/control/security/capability.lux index 49b19e07f..5d7ff9ebb 100644 --- a/stdlib/source/library/lux/control/security/capability.lux +++ b/stdlib/source/library/lux/control/security/capability.lux @@ -25,49 +25,47 @@ ["|[0]|" annotations]]]]]) (abstract: .public (Capability brand input output) - {} - (-> input output) - (def: capability - (All (_ brand input output) - (-> (-> input output) - (Capability brand input output))) - (|>> :abstraction)) + [(def: capability + (All (_ brand input output) + (-> (-> input output) + (Capability brand input output))) + (|>> :abstraction)) - (def: .public (use capability input) - (All (_ brand input output) - (-> (Capability brand input output) - input - output)) - ((:representation capability) input)) + (def: .public (use capability input) + (All (_ brand input output) + (-> (Capability brand input output) + input + output)) + ((:representation capability) input)) - (syntax: .public (capability: [[export_policy declaration annotations [forger input output]] - (|export|.parser - ($_ <>.and - |declaration|.parser - (<>.maybe |annotations|.parser) - (<c>.form ($_ <>.and <c>.local_identifier <c>.any <c>.any))))]) - (macro.with_identifiers [g!_] - (do [! meta.monad] - [this_module meta.current_module_name - .let [[name vars] declaration] - g!brand (\ ! each (|>> %.code code.text) - (macro.identifier (format (%.name [this_module name])))) - .let [capability (` (..Capability (.primitive (~ g!brand)) (~ input) (~ output)))]] - (in (list (` (type: (~ export_policy) - (~ (|declaration|.format declaration)) - (~ capability))) - (` (def: (~ (code.local_identifier forger)) - (All ((~ g!_) (~+ (list\each code.local_identifier vars))) - (-> (-> (~ input) (~ output)) - (~ capability))) - (~! ..capability))) - ))))) + (syntax: .public (capability: [[export_policy declaration annotations [forger input output]] + (|export|.parser + ($_ <>.and + |declaration|.parser + (<>.maybe |annotations|.parser) + (<c>.form ($_ <>.and <c>.local_identifier <c>.any <c>.any))))]) + (macro.with_identifiers [g!_] + (do [! meta.monad] + [this_module meta.current_module_name + .let [[name vars] declaration] + g!brand (\ ! each (|>> %.code code.text) + (macro.identifier (format (%.name [this_module name])))) + .let [capability (` (..Capability (.primitive (~ g!brand)) (~ input) (~ output)))]] + (in (list (` (type: (~ export_policy) + (~ (|declaration|.format declaration)) + (~ capability))) + (` (def: (~ (code.local_identifier forger)) + (All ((~ g!_) (~+ (list\each code.local_identifier vars))) + (-> (-> (~ input) (~ output)) + (~ capability))) + (~! ..capability))) + ))))) - (def: .public (async capability) - (All (_ brand input output) - (-> (Capability brand input (IO output)) - (Capability brand input (Async output)))) - (..capability (|>> ((:representation capability)) async.future))) + (def: .public (async capability) + (All (_ brand input output) + (-> (Capability brand input (IO output)) + (Capability brand input (Async output)))) + (..capability (|>> ((:representation capability)) async.future)))] ) diff --git a/stdlib/source/library/lux/control/security/policy.lux b/stdlib/source/library/lux/control/security/policy.lux index 498469d63..f0a55bdd4 100644 --- a/stdlib/source/library/lux/control/security/policy.lux +++ b/stdlib/source/library/lux/control/security/policy.lux @@ -9,89 +9,85 @@ abstract]]]) (abstract: .public (Policy brand value label) - {} - value - (type: .public (Can_Upgrade brand label value) - (-> value (Policy brand value label))) - - (type: .public (Can_Downgrade brand label value) - (-> (Policy brand value label) value)) - - (type: .public (Privilege brand label) - (Record - [#can_upgrade (Can_Upgrade brand label) - #can_downgrade (Can_Downgrade brand label)])) - - (type: .public (Delegation brand from to) - (All (_ value) - (-> (Policy brand value from) - (Policy brand value to)))) - - (def: .public (delegation downgrade upgrade) - (All (_ brand from to) - (-> (Can_Downgrade brand from) (Can_Upgrade brand to) - (Delegation brand from to))) - (|>> downgrade upgrade)) - - (type: .public (Context brand scope label) - (-> (Privilege brand label) - (scope label))) - - (def: privilege - Privilege - [#can_upgrade (|>> :abstraction) - #can_downgrade (|>> :representation)]) - - (def: .public (with_policy context) - (All (_ brand scope) - (Ex (_ label) - (-> (Context brand scope label) - (scope label)))) - (context ..privilege)) - - (def: (of_policy constructor) - (-> Type Type) - (type (All (_ brand label) - (constructor (All (_ value) (Policy brand value label)))))) - - (implementation: .public functor - (:~ (..of_policy Functor)) - - (def: (each f fa) - (|> fa :representation f :abstraction))) - - (implementation: .public apply - (:~ (..of_policy Apply)) - - (def: &functor ..functor) - - (def: (on fa ff) - (:abstraction ((:representation ff) (:representation fa))))) - - (implementation: .public monad - (:~ (..of_policy Monad)) - - (def: &functor ..functor) - (def: in (|>> :abstraction)) - (def: conjoint (|>> :representation))) + [(type: .public (Can_Upgrade brand label value) + (-> value (Policy brand value label))) + + (type: .public (Can_Downgrade brand label value) + (-> (Policy brand value label) value)) + + (type: .public (Privilege brand label) + (Record + [#can_upgrade (Can_Upgrade brand label) + #can_downgrade (Can_Downgrade brand label)])) + + (type: .public (Delegation brand from to) + (All (_ value) + (-> (Policy brand value from) + (Policy brand value to)))) + + (def: .public (delegation downgrade upgrade) + (All (_ brand from to) + (-> (Can_Downgrade brand from) (Can_Upgrade brand to) + (Delegation brand from to))) + (|>> downgrade upgrade)) + + (type: .public (Context brand scope label) + (-> (Privilege brand label) + (scope label))) + + (def: privilege + Privilege + [#can_upgrade (|>> :abstraction) + #can_downgrade (|>> :representation)]) + + (def: .public (with_policy context) + (All (_ brand scope) + (Ex (_ label) + (-> (Context brand scope label) + (scope label)))) + (context ..privilege)) + + (def: (of_policy constructor) + (-> Type Type) + (type (All (_ brand label) + (constructor (All (_ value) (Policy brand value label)))))) + + (implementation: .public functor + (:~ (..of_policy Functor)) + + (def: (each f fa) + (|> fa :representation f :abstraction))) + + (implementation: .public apply + (:~ (..of_policy Apply)) + + (def: &functor ..functor) + + (def: (on fa ff) + (:abstraction ((:representation ff) (:representation fa))))) + + (implementation: .public monad + (:~ (..of_policy Monad)) + + (def: &functor ..functor) + (def: in (|>> :abstraction)) + (def: conjoint (|>> :representation)))] ) (template [<brand> <value> <upgrade> <downgrade>] [(abstract: .public <brand> - {} - Any - (type: .public <value> - (Policy <brand>)) - - (type: .public <upgrade> - (Can_Upgrade <brand>)) - - (type: .public <downgrade> - (Can_Downgrade <brand>)) + [(type: .public <value> + (Policy <brand>)) + + (type: .public <upgrade> + (Can_Upgrade <brand>)) + + (type: .public <downgrade> + (Can_Downgrade <brand>))] )] [Privacy Private Can_Conceal Can_Reveal] diff --git a/stdlib/source/library/lux/control/thread.lux b/stdlib/source/library/lux/control/thread.lux index c583a4709..b2945a7a0 100644 --- a/stdlib/source/library/lux/control/thread.lux +++ b/stdlib/source/library/lux/control/thread.lux @@ -18,42 +18,40 @@ (-> ! a)) (abstract: .public (Box t v) - {} - (Array v) - (def: .public (box init) - (All (_ a) (-> a (All (_ !) (Thread ! (Box ! a))))) - (function (_ !) - (|> (array.empty 1) - (array.write! 0 init) - :abstraction))) - - (def: .public (read! box) - (All (_ ! a) (-> (Box ! a) (Thread ! a))) - (function (_ !) - (for {@.old - ("jvm aaload" (:representation box) 0) - - @.jvm - ("jvm array read object" - (|> 0 - (:as (primitive "java.lang.Long")) - "jvm object cast" - "jvm conversion long-to-int") - (:representation box)) - - @.js ("js array read" 0 (:representation box)) - @.python ("python array read" 0 (:representation box)) - @.lua ("lua array read" 0 (:representation box)) - @.ruby ("ruby array read" 0 (:representation box)) - @.php ("php array read" 0 (:representation box)) - @.scheme ("scheme array read" 0 (:representation box))}))) - - (def: .public (write! value box) - (All (_ a) (-> a (All (_ !) (-> (Box ! a) (Thread ! Any))))) - (function (_ !) - (|> box :representation (array.write! 0 value) :abstraction))) + [(def: .public (box init) + (All (_ a) (-> a (All (_ !) (Thread ! (Box ! a))))) + (function (_ !) + (|> (array.empty 1) + (array.write! 0 init) + :abstraction))) + + (def: .public (read! box) + (All (_ ! a) (-> (Box ! a) (Thread ! a))) + (function (_ !) + (for {@.old + ("jvm aaload" (:representation box) 0) + + @.jvm + ("jvm array read object" + (|> 0 + (:as (primitive "java.lang.Long")) + "jvm object cast" + "jvm conversion long-to-int") + (:representation box)) + + @.js ("js array read" 0 (:representation box)) + @.python ("python array read" 0 (:representation box)) + @.lua ("lua array read" 0 (:representation box)) + @.ruby ("ruby array read" 0 (:representation box)) + @.php ("php array read" 0 (:representation box)) + @.scheme ("scheme array read" 0 (:representation box))}))) + + (def: .public (write! value box) + (All (_ a) (-> a (All (_ !) (-> (Box ! a) (Thread ! Any))))) + (function (_ !) + (|> box :representation (array.write! 0 value) :abstraction)))] ) (def: .public (result thread) |