aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2020-05-16 20:19:34 -0400
committerEduardo Julian2020-05-16 20:19:34 -0400
commit9965c551e7ccd6de8c47c7b1b78f804801810dac (patch)
tree05538c6ede048898f375ce3a333a2c4dd6b6f4a7 /stdlib/source
parent65d0beab4cb53a9ba8574e1133d105420f0b23aa (diff)
Parallel compilation for the new compiler(s).
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux.lux56
-rw-r--r--stdlib/source/lux/control/concurrency/semaphore.lux148
-rw-r--r--stdlib/source/lux/data/collection/queue.lux8
-rw-r--r--stdlib/source/lux/tool/compiler/default/platform.lux319
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux26
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/generation.lux5
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux8
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux32
-rw-r--r--stdlib/source/lux/type.lux11
-rw-r--r--stdlib/source/lux/type/refinement.lux15
-rw-r--r--stdlib/source/program/compositor.lux56
-rw-r--r--stdlib/source/program/compositor/cli.lux31
-rw-r--r--stdlib/source/program/compositor/static.lux11
-rw-r--r--stdlib/source/test/lux/abstract/equivalence.lux25
-rw-r--r--stdlib/source/test/lux/control.lux5
-rw-r--r--stdlib/source/test/lux/control/concurrency/semaphore.lux277
16 files changed, 633 insertions, 400 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux
index cabbb1154..bda5f60d9 100644
--- a/stdlib/source/lux.lux
+++ b/stdlib/source/lux.lux
@@ -2702,7 +2702,11 @@
(let' [[left right] pair]
(list left right)))
-(def:' (%code code)
+(def:' (text@encode original)
+ (-> Text Text)
+ ($_ text@compose ..double-quote original ..double-quote))
+
+(def:' (code@encode code)
(-> Code Text)
({[_ (#Bit value)]
(bit@encode value)
@@ -2720,7 +2724,7 @@
(frac@encode value)
[_ (#Text value)]
- ($_ text@compose ..double-quote value ..double-quote)
+ (text@encode value)
[_ (#Identifier [prefix name])]
(if (text@= "" prefix)
@@ -2734,21 +2738,21 @@
[_ (#Form xs)]
($_ text@compose "(" (|> xs
- (list@map %code)
+ (list@map code@encode)
(interpose " ")
list@reverse
(list@fold text@compose "")) ")")
[_ (#Tuple xs)]
($_ text@compose "[" (|> xs
- (list@map %code)
+ (list@map code@encode)
(interpose " ")
list@reverse
(list@fold text@compose "")) "]")
[_ (#Record kvs)]
($_ text@compose "{" (|> kvs
- (list@map (function' [kv] ({[k v] ($_ text@compose (%code k) " " (%code v))}
+ (list@map (function' [kv] ({[k v] ($_ text@compose (code@encode k) " " (code@encode v))}
kv)))
(interpose " ")
list@reverse
@@ -2782,7 +2786,7 @@
_
(fail ($_ text@compose "'lux.case' expects an even number of tokens: " (|> branches
- (list@map %code)
+ (list@map code@encode)
(interpose " ")
list@reverse
(list@fold text@compose ""))))}
@@ -2991,13 +2995,13 @@
_
(` (#.Cons [[(~ cursor-code) (#.Tag ["lux" "func-args"])]
[(~ cursor-code) (#.Tuple (.list (~+ (list@map (function (_ arg)
- (` [(~ cursor-code) (#.Text (~ (text$ (%code arg))))]))
+ (` [(~ cursor-code) (#.Text (~ (text$ (code@encode arg))))]))
args))))]]
(~ meta)))))
(def:' (with-type-args args)
(-> (List Code) Code)
- (` {#.type-args [(~+ (list@map (function (_ arg) (text$ (%code arg)))
+ (` {#.type-args [(~+ (list@map (function (_ arg) (text$ (code@encode arg)))
args))]}))
(def:' (export^ tokens)
@@ -3987,18 +3991,18 @@
[current-module current-module-name]
(fail ($_ text@compose
"Wrong syntax for import @ " current-module
- ..new-line (%code token)))))))
+ ..new-line (code@encode token)))))))
imports)]
(wrap (list@join imports'))))
(def: (exported-definitions module state)
(-> Text (Meta (List Text)))
- (let [modules (case state
- {#info info #source source #current-module _ #modules modules
- #scopes scopes #type-context types #host host
- #seed seed #expected expected #cursor cursor #extensions extensions
- #scope-type-vars scope-type-vars}
- modules)]
+ (let [[current-module modules] (case state
+ {#info info #source source #current-module current-module #modules modules
+ #scopes scopes #type-context types #host host
+ #seed seed #expected expected #cursor cursor #extensions extensions
+ #scope-type-vars scope-type-vars}
+ [current-module modules])]
(case (get module modules)
(#Some =module)
(let [to-alias (list@map (: (-> [Text Global]
@@ -4017,7 +4021,19 @@
(#Right state (list@join to-alias)))
#None
- (#Left ($_ text@compose "Unknown module: " module)))
+ (#Left ($_ text@compose
+ "Unknown module: " (text@encode module) ..new-line
+ "Current module: " (case current-module
+ (#Some current-module)
+ (text@encode current-module)
+
+ #None
+ "???") ..new-line
+ "Known modules: " (|> modules
+ (list@map (function (_ [name module])
+ (text$ name)))
+ tuple$
+ code@encode))))
))
(def: (filter p xs)
@@ -4484,7 +4500,7 @@
_
(fail ($_ text@compose "Wrong syntax for refer @ " current-module
..new-line (|> options
- (list@map %code)
+ (list@map code@encode)
(interpose " ")
(list@fold text@compose "")))))))
@@ -4892,10 +4908,6 @@
_
(#Doc-Example code)))
-(def: (text@encode original)
- (-> Text Text)
- ($_ text@compose ..double-quote original ..double-quote))
-
(template [<name> <extension> <doc>]
[(def: #export <name>
{#.doc <doc>}
@@ -5547,7 +5559,7 @@
(undefined)))}
(case tokens
#Nil
- (return (list (` (error! "Undefined behavior."))))
+ (return (list (` (..error! "Undefined behavior."))))
_
(fail (..wrong-syntax-error (name-of ..undefined)))))
diff --git a/stdlib/source/lux/control/concurrency/semaphore.lux b/stdlib/source/lux/control/concurrency/semaphore.lux
index ade45984e..39bac32a1 100644
--- a/stdlib/source/lux/control/concurrency/semaphore.lux
+++ b/stdlib/source/lux/control/concurrency/semaphore.lux
@@ -2,79 +2,115 @@
[lux #*
[abstract
[monad (#+ do)]]
+ [control
+ ["." io (#+ IO)]
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
[data
+ [text
+ ["%" format (#+ format)]]
[number
- ["n" nat]]]
- [control
- ["." io (#+ IO)]]
+ ["n" nat]
+ ["i" int]]
+ [collection
+ ["." queue (#+ Queue)]]]
[type
abstract
- ["." refinement]]]
+ ["." refinement]]
+ ["." macro]]
[//
["." atom (#+ Atom)]
- ["." promise (#+ Promise)]])
+ ["." promise (#+ Promise Resolver)]])
(type: State
- {#open-positions Nat
- #waiting-list (List (Promise Any))})
+ {#max-positions Nat
+ #open-positions Int
+ #waiting-list (Queue (Resolver Any))})
(abstract: #export Semaphore
{#.doc "A tool for controlling access to resources by multiple concurrent processes."}
(Atom State)
- (def: #export (semaphore init-open-positions)
+ (def: most-positions-possible
+ (.nat (:: i.interval top)))
+
+ (def: #export (semaphore initial-open-positions)
(-> Nat Semaphore)
- (:abstraction (atom.atom {#open-positions init-open-positions
- #waiting-list (list)})))
+ (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: #export (wait semaphore)
(Ex [k] (-> Semaphore (Promise Any)))
- (let [semaphore (:representation semaphore)]
- (io.run
- (loop [signal (: (Promise Any)
- (promise.promise #.None))]
- (do io.monad
- [state (atom.read semaphore)
- #let [[ready? state'] (: [Bit State]
- (case (get@ #open-positions state)
- 0 [#0 (update@ #waiting-list (|>> (#.Cons signal))
- state)]
- _ [#1 (update@ #open-positions dec
- state)]))]
- success? (atom.compare-and-swap state state' semaphore)
- _ (if ready?
- (promise.resolve [] signal)
- (wrap #0))]
- (if success?
- (wrap signal)
- (recur signal)))))))
+ (let [semaphore (:representation semaphore)
+ [signal sink] (: [(Promise Any) (Resolver Any)]
+ (promise.promise []))]
+ (exec (promise.future
+ (loop [_ []]
+ (do io.monad
+ [state (atom.read semaphore)
+ #let [[ready? state'] (: [Bit State]
+ (if (i.> +0 (get@ #open-positions state))
+ [true (|> state
+ (update@ #open-positions dec))]
+ [false (|> state
+ (update@ #open-positions dec)
+ (update@ #waiting-list (queue.push sink)))]))]
+ success? (atom.compare-and-swap state state' semaphore)]
+ (if success?
+ (if ready?
+ (sink [])
+ (wrap false))
+ (recur [])))))
+ signal)))
+
+ (exception: #export (semaphore-is-maxed-out {max-positions Nat})
+ (exception.report
+ ["Max Positions" (%.nat max-positions)]))
(def: #export (signal semaphore)
- (Ex [k] (-> Semaphore (Promise Any)))
+ (Ex [k] (-> Semaphore (Promise (Try Int))))
(let [semaphore (:representation semaphore)]
(promise.future
(loop [_ []]
(do io.monad
[state (atom.read semaphore)
- #let [[?signal state'] (: [(Maybe (Promise Any)) State]
- (case (get@ #waiting-list state)
- #.Nil
- [#.None (update@ #open-positions inc state)]
-
- (#.Cons head tail)
- [(#.Some head) (set@ #waiting-list tail state)]))]
- success? (atom.compare-and-swap state state' semaphore)]
- (if success?
+ #let [[?sink state' maxed-out?] (: [(Maybe (Resolver Any)) State Bit]
+ (case (queue.peek (get@ #waiting-list state))
+ #.None
+ (if (n.= (get@ #max-positions state)
+ (.nat (get@ #open-positions state)))
+ [#.None
+ state
+ true]
+ [#.None
+ (update@ #open-positions inc state)
+ false])
+
+ (#.Some head)
+ [(#.Some head)
+ (|> state
+ (update@ #open-positions inc)
+ (update@ #waiting-list queue.pop))
+ false]))]]
+ (if maxed-out?
+ (wrap (exception.throw ..semaphore-is-maxed-out [(get@ #max-positions state)]))
(do @
- [_ (case ?signal
- #.None
- (wrap #1)
-
- (#.Some signal)
- (promise.resolve [] signal))]
- (wrap []))
- (recur [])))))))
+ [#let [open-positions (get@ #open-positions state')]
+ success? (atom.compare-and-swap state state' semaphore)]
+ (if success?
+ (do @
+ [_ (case ?sink
+ #.None
+ (wrap true)
+
+ (#.Some sink)
+ (sink []))]
+ (wrap (#try.Success open-positions)))
+ (recur [])))))))))
)
(abstract: #export Mutex
@@ -104,7 +140,7 @@
)
(def: #export limit (refinement.refinement (n.> 0)))
-(`` (type: #export Limit (~~ (refinement.type limit))))
+(type: #export Limit (:~ (refinement.type limit)))
(abstract: #export Barrier
{#.doc "A barrier that blocks all processes from proceeding until a given number of processes are parked at the barrier."}
@@ -126,7 +162,7 @@
(loop [step 0]
(if (n.< times step)
(do promise.monad
- [_ (signal turnstile)]
+ [_ (..signal turnstile)]
(recur (inc step)))
(:: promise.monad wrap []))))
@@ -136,11 +172,11 @@
(do promise.monad
[#let [limit (refinement.un-refine (get@ #limit barrier))
goal <goal>
- count (io.run (atom.update <update> (get@ #count barrier)))]
- _ (if (n.= goal count)
- (un-block limit (get@ <turnstile> barrier))
- (wrap []))]
- (wait (get@ <turnstile> barrier))))]
+ count (io.run (atom.update <update> (get@ #count barrier)))
+ reached? (n.= goal count)]]
+ (if reached?
+ (un-block limit (get@ <turnstile> barrier))
+ (wait (get@ <turnstile> barrier)))))]
[start inc limit #start-turnstile]
[end dec 0 #end-turnstile]
@@ -149,6 +185,6 @@
(def: #export (block barrier)
(-> Barrier (Promise Any))
(do promise.monad
- [_ (start barrier)]
- (end barrier)))
+ [_ (..start barrier)]
+ (..end barrier)))
)
diff --git a/stdlib/source/lux/data/collection/queue.lux b/stdlib/source/lux/data/collection/queue.lux
index 9bf4dcf81..c0e16ee29 100644
--- a/stdlib/source/lux/data/collection/queue.lux
+++ b/stdlib/source/lux/data/collection/queue.lux
@@ -7,7 +7,7 @@
[number
["n" nat]]
[collection
- ["." list ("#;." monoid functor)]]]])
+ ["." list ("#@." monoid functor)]]]])
(type: #export (Queue a)
{#front (List a)
@@ -26,7 +26,7 @@
(def: #export (to-list queue)
(All [a] (-> (Queue a) (List a)))
(let [(^slots [#front #rear]) queue]
- (list;compose front (list.reverse rear))))
+ (list@compose front (list.reverse rear))))
(def: #export peek
(All [a] (-> (Queue a) (Maybe a)))
@@ -79,5 +79,5 @@
(structure: #export functor (Functor Queue)
(def: (map f fa)
- {#front (|> fa (get@ #front) (list;map f))
- #rear (|> fa (get@ #rear) (list;map f))}))
+ {#front (|> fa (get@ #front) (list@map f))
+ #rear (|> fa (get@ #rear) (list@map f))}))
diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux
index 76939bb08..f562e762a 100644
--- a/stdlib/source/lux/tool/compiler/default/platform.lux
+++ b/stdlib/source/lux/tool/compiler/default/platform.lux
@@ -7,7 +7,8 @@
[control
["." try (#+ Try)]
[concurrency
- ["." promise (#+ Promise) ("#@." monad)]]]
+ ["." promise (#+ Promise Resolver) ("#@." monad)]
+ ["." stm (#+ Var STM)]]]
[data
["." binary (#+ Binary)]
["." bit]
@@ -15,10 +16,10 @@
["." text
["%" format (#+ format)]]
[collection
- [dictionary (#+ Dictionary)]
- ["." row ("#@." fold)]
+ ["." dictionary (#+ Dictionary)]
+ ["." row (#+ Row) ("#@." fold)]
["." set]
- ["." list ("#@." monoid)]]
+ ["." list ("#@." monoid functor fold)]]
[format
["_" binary (#+ Writer)]]]
[world
@@ -51,7 +52,8 @@
["ioW" archive]]]]]
[program
[compositor
- ["." cli (#+ Configuration)]]])
+ ["." cli (#+ Configuration)]
+ ["." static (#+ Static)]]])
(type: #export (Platform anchor expression directive)
{#&file-system (file.System Promise)
@@ -79,23 +81,23 @@
(_.and descriptor.writer
(document.writer $.writer)))
- (def: (cache-module platform host target-dir module-id extension [[descriptor document] output])
+ (def: (cache-module static platform module-id [[descriptor document] output])
(All [<type-vars>]
- (-> <Platform> Host Path archive.ID Text [[Descriptor (Document Any)] Output]
+ (-> Static <Platform> archive.ID [[Descriptor (Document Any)] Output]
(Promise (Try Any))))
(let [system (get@ #&file-system platform)
write-artifact! (: (-> [Text Binary] (Action Any))
(function (_ [name content])
- (ioW.write system host target-dir module-id name extension content)))]
+ (ioW.write system (get@ #static.host static) (get@ #static.target static) module-id name (get@ #static.artifact-extension static) content)))]
(do ..monad
- [_ (ioW.prepare system host target-dir module-id)
+ [_ (ioW.prepare system (get@ #static.host static) (get@ #static.target static) module-id)
_ (|> output
row.to-list
(monad.map ..monad write-artifact!)
(: (Action (List Any))))
document (:: promise.monad wrap
(document.check $.key document))]
- (ioW.cache system host target-dir module-id
+ (ioW.cache system (get@ #static.host static) (get@ #static.target static) module-id
(_.run ..writer [descriptor document])))))
## TODO: Inline ASAP
@@ -173,11 +175,9 @@
(///phase.run' state)
(:: try.monad map product.left)))
- (def: #export (initialize extension target host module expander host-analysis platform generation-bundle host-directive-bundle program extender)
+ (def: #export (initialize static module expander host-analysis platform generation-bundle host-directive-bundle program extender)
(All [<type-vars>]
- (-> Text
- Path
- Host
+ (-> Static
Module
Expander
///analysis.Bundle
@@ -188,7 +188,7 @@
Extender
(Promise (Try [<State+> Archive]))))
(do (try.with promise.monad)
- [#let [state (//init.state host
+ [#let [state (//init.state (get@ #static.host static)
module
expander
host-analysis
@@ -198,8 +198,8 @@
host-directive-bundle
program
extender)]
- _ (ioW.enable (get@ #&file-system platform) host target)
- [archive analysis-state bundles] (ioW.thaw extension (get@ #host platform) (get@ #&file-system platform) host target)
+ _ (ioW.enable (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static))
+ [archive analysis-state bundles] (ioW.thaw (get@ #static.artifact-extension static) (get@ #host platform) (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static))
state (promise@wrap (initialize-state extender bundles analysis-state state))]
(if (archive.archived? archive archive.runtime-module)
(wrap [state archive])
@@ -207,7 +207,7 @@
[[state [archive payload]] (|> (..process-runtime archive platform)
(///phase.run' state)
promise@wrap)
- _ (..cache-module platform host target 0 extension payload)]
+ _ (..cache-module static platform 0 payload)]
(wrap [state archive])))))
(def: module-compilation-log
@@ -232,83 +232,212 @@
#///generation.log]
row.empty))
- (def: #export (compile target partial-host-extension expander platform host configuration archive extension state)
- (All [<type-vars>]
- (-> Text Text Expander <Platform> Host Configuration Archive Text <State+> (Promise (Try [Archive <State+>]))))
- (let [source-module (get@ #cli.module configuration)
- compiler (:share [<type-vars>]
- {<State+>
- state}
- {(///.Compiler <State+> .Module Any)
- ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list))})]
- (loop [module source-module
- [archive state] [archive state]]
- (if (archive.archived? archive module)
- (promise@wrap (#try.Success [archive state]))
- (let [import! (:share [<type-vars>]
- {<Platform>
- platform}
- {(-> Module [Archive <State+>]
- (Action [Archive <State+>]))
- recur})]
- (do (try.with promise.monad)
- [[module-id archive] (promise@wrap (archive.reserve module archive))
- input (context.read (get@ #&file-system platform)
- (get@ #cli.sources configuration)
- partial-host-extension
- module)]
- (loop [archive archive
- state state
- compilation (compiler (:coerce ///.Input input))
- all-dependencies (: (List Module)
- (list))]
- (do @
- [#let [new-dependencies (get@ #///.dependencies compilation)
- all-dependencies (list@compose new-dependencies all-dependencies)]
- [archive state] (:share [<type-vars>]
- {<Platform>
- platform}
- {(Action [Archive <State+>])
- (monad.fold ..monad import! [archive state] new-dependencies)})
- #let [continue! (:share [<type-vars>]
- {<Platform>
- platform}
- {(-> Archive <State+> (///.Compilation <State+> .Module Any) (List Module)
- (Action [Archive <State+>]))
- recur})]]
- (case ((get@ #///.process compilation)
- (case new-dependencies
- #.Nil
- state
+ (with-expansions [<Context> (as-is [Archive <State+>])
+ <Result> (as-is (Try <Context>))
+ <Return> (as-is (Promise <Result>))
+ <Signal> (as-is (Resolver <Result>))
+ <Pending> (as-is [<Return> <Signal>])
+ <Importer> (as-is (-> Module <Return>))
+ <Compiler> (as-is (-> <Importer> archive.ID <Context> Module <Return>))]
+ (def: (parallel initial)
+ (All [<type-vars>]
+ (-> <Context>
+ (-> <Compiler> <Importer>)))
+ (let [current (:share [<type-vars>]
+ {<Context>
+ initial}
+ {(Var <Context>)
+ (stm.var initial)})
+ pending (:share [<type-vars>]
+ {<Context>
+ initial}
+ {(Var (Dictionary Module <Pending>))
+ (stm.var (dictionary.new text.hash))})]
+ (function (_ compile)
+ (function (import! module)
+ (do promise.monad
+ [[return signal] (:share [<type-vars>]
+ {<Context>
+ initial}
+ {(Promise [<Return> (Maybe [<Context>
+ archive.ID
+ <Signal>])])
+ (stm.commit
+ (do stm.monad
+ [[archive state] (stm.read current)]
+ (if (archive.archived? archive module)
+ (wrap [(promise@wrap (#try.Success [archive state]))
+ #.None])
+ (do @
+ [@pending (stm.read pending)]
+ (case (dictionary.get module @pending)
+ (#.Some [return signal])
+ (wrap [return
+ #.None])
+
+ #.None
+ (case (archive.reserve module archive)
+ (#try.Success [module-id archive])
+ (do @
+ [_ (stm.write [archive state] current)
+ #let [[return signal] (:share [<type-vars>]
+ {<Context>
+ initial}
+ {<Pending>
+ (promise.promise [])})]
+ _ (stm.update (dictionary.put module [return signal]) pending)]
+ (wrap [return
+ (#.Some [[archive state]
+ module-id
+ signal])]))
+
+ (#try.Failure error)
+ (wrap [(promise@wrap (#try.Failure error))
+ #.None])))))))})
+ _ (case signal
+ #.None
+ (wrap [])
+
+ (#.Some [context module-id resolver])
+ (do @
+ [result (compile import! module-id context module)
+ result (case result
+ (#try.Failure error)
+ (wrap result)
+
+ (#try.Success [resulting-archive resulting-state])
+ (stm.commit (do stm.monad
+ [[_ [merged-archive _]] (stm.update (function (_ [archive state])
+ [(archive.merge resulting-archive archive)
+ state])
+ current)]
+ (wrap (#try.Success [merged-archive resulting-state])))))
+ _ (promise.future (resolver result))]
+ (wrap [])))]
+ return)))))
+
+ ## TODO: Find a better way, as this only works for the Lux compiler.
+ (def: (updated-state archive state)
+ (All [<type-vars>]
+ (-> Archive <State+> (Try <State+>)))
+ (do try.monad
+ [modules (monad.map @ (function (_ module)
+ (do @
+ [[descriptor document] (archive.find module archive)
+ lux-module (document.read $.key document)]
+ (wrap [module lux-module])))
+ (archive.archived archive))
+ #let [additions (|> modules
+ (list@map product.left)
+ (set.from-list text.hash))]]
+ (wrap (update@ [#extension.state
+ #///directive.analysis
+ #///directive.state
+ #extension.state]
+ (function (_ analysis-state)
+ (|> analysis-state
+ (:coerce .Lux)
+ (update@ #.modules (function (_ current)
+ (list@compose (list.filter (|>> product.left
+ (set.member? additions)
+ not)
+ current)
+ modules)))
+ :assume))
+ state))))
+
+ (def: (set-current-module module state)
+ (All [<type-vars>]
+ (-> Module <State+> <State+>))
+ (|> (///directive.set-current-module module)
+ (///phase.run' state)
+ try.assume
+ product.left))
+
+ (def: #export (compile static expander platform configuration context)
+ (All [<type-vars>]
+ (-> Static Expander <Platform> Configuration <Context> <Return>))
+ (let [base-compiler (:share [<type-vars>]
+ {<Context>
+ context}
+ {(///.Compiler <State+> .Module Any)
+ ((//init.compiler expander syntax.prelude (get@ #write platform)) $.key (list))})
+ parallel-compiler (..parallel
+ context
+ (function (_ import! module-id [archive state] module)
+ (do (try.with promise.monad)
+ [#let [state (..set-current-module module state)]
+ input (context.read (get@ #&file-system platform)
+ (get@ #cli.sources configuration)
+ (get@ #static.host-module-extension static)
+ module)]
+ (loop [[archive state] [archive state]
+ compilation (base-compiler (:coerce ///.Input input))
+ all-dependencies (: (List Module)
+ (list))]
+ (do (try.with promise.monad)
+ [#let [new-dependencies (get@ #///.dependencies compilation)
+ all-dependencies (list@compose new-dependencies all-dependencies)
+ continue! (:share [<type-vars>]
+ {<Platform>
+ platform}
+ {(-> <Context> (///.Compilation <State+> .Module Any) (List Module)
+ (Action [Archive <State+>]))
+ recur})]
+ archive,document+ (|> new-dependencies
+ (list@map import!)
+ (monad.seq ..monad))
+ #let [archive (case archive,document+
+ #.Nil
+ archive
+
+ archive,document+
+ (|> archive,document+
+ (list@map product.left)
+ (list@fold archive.merge archive)))
+ state (case archive,document+
+ #.Nil
+ state
- _
- ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
- ## TODO: The context shouldn't need to be re-set either.
- (|> (///directive.set-current-module module)
- (///phase.run' state)
- try.assume
- product.left))
- archive)
- (#try.Success [state more|done])
- (case more|done
- (#.Left more)
- (continue! archive state more all-dependencies)
+ archive,document+
+ (try.assume
+ (:share [|state|]
+ {|state|
+ state}
+ {(Try |state|)
+ (..updated-state archive state)})))]]
+ (case ((get@ #///.process compilation)
+ ## TODO: The "///directive.set-current-module" below shouldn't be necessary. Remove it ASAP.
+ ## TODO: The context shouldn't need to be re-set either.
+ (|> (///directive.set-current-module module)
+ (///phase.run' state)
+ try.assume
+ product.left)
+ archive)
+ (#try.Success [state more|done])
+ (case more|done
+ (#.Left more)
+ (continue! [archive state] more all-dependencies)
- (#.Right [[descriptor document] output])
- (do (try.with promise.monad)
- [#let [_ (log! (..module-compilation-log state))
- descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
- _ (..cache-module platform host target module-id extension [[descriptor document] output])]
- (case (archive.add module [descriptor document] archive)
- (#try.Success archive)
- (wrap [archive
- (..with-reset-log state)])
-
- (#try.Failure error)
- (promise@wrap (#try.Failure error)))))
+ (#.Right [[descriptor document] output])
+ (do (try.with promise.monad)
+ [#let [_ (log! (..module-compilation-log state))
+ descriptor (set@ #descriptor.references (set.from-list text.hash all-dependencies) descriptor)]
+ _ (..cache-module static platform module-id [[descriptor document] output])]
+ (case (archive.add module [descriptor document] archive)
+ (#try.Success archive)
+ (wrap [archive
+ (..with-reset-log state)])
+
+ (#try.Failure error)
+ (promise@wrap (#try.Failure error)))))
- (#try.Failure error)
- (do (try.with promise.monad)
- [_ (ioW.freeze (get@ #&file-system platform) host target archive)]
- (promise@wrap (#try.Failure error))))))))))))
- )
+ (#try.Failure error)
+ (do (try.with promise.monad)
+ [_ (ioW.freeze (get@ #&file-system platform) (get@ #static.host static) (get@ #static.target static) archive)]
+ (promise@wrap (#try.Failure error))))
+ ))
+ )))]
+ (parallel-compiler (get@ #cli.module configuration))
+ ))
+ ))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux
index 66efb1dde..2e42e2c45 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/analysis/evaluation.lux
@@ -1,16 +1,18 @@
(.module:
- [lux #*
+ [lux (#- Module)
[abstract
[monad (#+ do)]]
[control
["." try]]
[data
- [text
- ["%" format (#+ format)]]]]
+ ["." text
+ ["%" format (#+ format)]]]
+ ["." macro]]
[// (#+ Operation)
[macro (#+ Expander)]
[//
[phase
+ [".P" extension]
[".P" synthesis]
[".P" analysis
["." type]]
@@ -20,11 +22,20 @@
[///
["." phase]
[meta
- [archive (#+ Archive)]]]]]]])
+ [archive (#+ Archive)
+ [descriptor (#+ Module)]]]]]]]])
(type: #export Eval
(-> Archive Nat Type Code (Operation Any)))
+(def: #export (id prefix module count)
+ (-> Text Module Nat Text)
+ (format prefix
+ "$"
+ (text.replace-all "/" "$" module)
+ "$"
+ (%.nat count)))
+
(def: #export (evaluator expander synthesis-state generation-state generate)
(All [anchor expression artifact]
(-> Expander
@@ -36,10 +47,13 @@
(function (eval archive count type exprC)
(do phase.monad
[exprA (type.with-type type
- (analyze archive exprC))]
+ (analyze archive exprC))
+ module (extensionP.lift
+ macro.current-module-name)]
(phase.lift (do try.monad
[exprS (|> exprA (synthesisP.phase archive) (phase.run synthesis-state))]
(phase.run generation-state
(do phase.monad
[exprO (generate archive exprS)]
- (generation.evaluate! (format "eval" (%.nat count)) exprO)))))))))
+ (generation.evaluate! (..id "analysis" module count)
+ exprO)))))))))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/generation.lux b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
index 41dcdd990..7196d13f1 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/generation.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/generation.lux
@@ -177,6 +177,11 @@
(-> Module (Operation anchor expression directive Any)))
(extension.update (set@ #module module)))
+(def: #export module
+ (All [anchor expression directive]
+ (Operation anchor expression directive Module))
+ (extension.read (get@ #module)))
+
(template [<name> <inputT>]
[(def: #export (<name> label code)
(All [anchor expression directive]
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
index 24d059031..96eb95f41 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/extension/directive/lux.lux
@@ -11,7 +11,7 @@
[data
["." product]
["." maybe]
- [text
+ ["." text
["%" format (#+ format)]]
[collection
["." dictionary]]]
@@ -65,9 +65,11 @@
(Operation anchor expression directive [Type expression Any])))
(/////directive.lift-generation
(do phase.monad
- [codeG (generate archive codeS)
+ [module /////generation.module
id /////generation.next
- codeV (/////generation.evaluate! (format "evaluate" (%.nat id)) codeG)]
+ codeG (generate archive codeS)
+ codeV (/////generation.evaluate! (/////analysis/evaluation.id "directive" module id)
+ codeG)]
(wrap [code//type codeG codeV]))))
(def: #export (evaluate! archive type codeC)
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux
index 37b47777d..3756e257a 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive.lux
@@ -173,22 +173,22 @@
[module id]))))
(def: #export (merge additions archive)
- (-> Archive Archive (Try Archive))
- (|> additions
- :representation
- (get@ #resolver)
- dictionary.entries
- (monad.fold try.monad
- (function (_ [module' [id descriptor+document']] archive')
- (case descriptor+document'
- (#.Some descriptor+document')
- (if (archived? archive' module')
- (#try.Success archive')
- (..add module' descriptor+document' archive'))
-
- #.None
- (#try.Success archive')))
- archive)))
+ (-> Archive Archive Archive)
+ (let [[+next +resolver] (:representation additions)]
+ (|> archive
+ :representation
+ (update@ #next (n.max +next))
+ (update@ #resolver (function (_ resolver)
+ (list@fold (function (_ [module [id entry]] resolver)
+ (case entry
+ (#.Some _)
+ (dictionary.put module [id entry] resolver)
+
+ #.None
+ resolver))
+ resolver
+ (dictionary.entries +resolver))))
+ :abstraction)))
(type: Reservation [Module ID])
(type: Frozen [Version ID (List Reservation)])
diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux
index 247f2db15..c3a17f34a 100644
--- a/stdlib/source/lux/type.lux
+++ b/stdlib/source/lux/type.lux
@@ -410,11 +410,12 @@
(syntax: #export (:by-example {type-vars type-parameters}
{exemplar typed}
{extraction s.any})
- (wrap (list (` (:of (:share [(~+ (list@map code.local-identifier type-vars))]
- {(~ (get@ #type exemplar))
- (~ (get@ #expression exemplar))}
- {(~ extraction)
- (:assume [])}))))))
+ (wrap (list (` (:of ((~! :share)
+ [(~+ (list@map code.local-identifier type-vars))]
+ {(~ (get@ #type exemplar))
+ (~ (get@ #expression exemplar))}
+ {(~ extraction)
+ (:assume [])}))))))
(exception: #export (hole-type {location Cursor} {type Type})
(exception.report
diff --git a/stdlib/source/lux/type/refinement.lux b/stdlib/source/lux/type/refinement.lux
index 1c428fc23..3a9b8cfd2 100644
--- a/stdlib/source/lux/type/refinement.lux
+++ b/stdlib/source/lux/type/refinement.lux
@@ -2,7 +2,9 @@
[lux (#- type)
[abstract
[predicate (#+ Predicate)]]
- [type (#+ :by-example) ("#;." equivalence)
+ ["." macro
+ [syntax (#+ syntax:)]]
+ [type (#+ :by-example)
abstract]])
(abstract: #export (Refined t r)
@@ -77,8 +79,9 @@
[yes
(#.Cons head no)]))))
-(template: #export (type <refiner>)
- (:by-example [t r]
- {(..Refiner t r)
- <refiner>}
- (..Refined t r)))
+(syntax: #export (type refiner)
+ (macro.with-gensyms [g!t g!r]
+ (wrap (list (` ((~! :by-example) [(~ g!t) (~ g!r)]
+ {(..Refiner (~ g!t) (~ g!r))
+ (~ refiner)}
+ (..Refined (~ g!t) (~ g!r))))))))
diff --git a/stdlib/source/program/compositor.lux b/stdlib/source/program/compositor.lux
index fcf05f164..43bc084c5 100644
--- a/stdlib/source/program/compositor.lux
+++ b/stdlib/source/program/compositor.lux
@@ -49,7 +49,8 @@
## ["." interpreter]
]]
["." / #_
- ["#." cli (#+ Service)]])
+ ["#." cli (#+ Configuration)]
+ ["#." static (#+ Static)]])
(def: (or-crash! failure-description action)
(All [a]
@@ -67,48 +68,20 @@
(wrap output))))
(with-expansions [<parameters> (as-is anchor expression artifact)]
- ## TODO: Clean-up ASAP.
- ## (def: (save-artifacts! system state [packager package])
- ## (All [<parameters>]
- ## (-> (file.System Promise)
- ## (directive.State+ <parameters>)
- ## [(-> (Row [Module (generation.Buffer artifact)]) Binary) Path]
- ## (Promise (Try Any))))
- ## (let [?outcome (phase.run' state
- ## (:share [<parameters>]
- ## {(directive.State+ <parameters>)
- ## state}
- ## {(directive.Operation <parameters>
- ## (generation.Output artifact))
- ## (directive.lift-generation generation.output)}))]
- ## (case ?outcome
- ## (#try.Success [state output])
- ## (do (try.with promise.monad)
- ## [file (: (Promise (Try (File Promise)))
- ## (file.get-file promise.monad system package))]
- ## (!.use (:: file over-write) (packager output)))
-
- ## (#try.Failure error)
- ## (promise@wrap (#try.Failure error)))))
-
- (def: #export (compiler target partial-host-extension
- expander host-analysis platform host generation-bundle host-directive-bundle program extender
- service
- extension
+ (def: #export (compiler static
+ expander host-analysis platform generation-bundle host-directive-bundle program extender
+ configuration
packager,package)
(All [<parameters>]
- (-> Path
- Text
+ (-> Static
Expander
analysis.Bundle
(IO (Platform <parameters>))
- Host
(generation.Bundle <parameters>)
(directive.Bundle <parameters>)
(-> expression artifact)
Extender
- Service
- Text
+ Configuration
[(-> (Row [Module (generation.Buffer artifact)]) Binary) Path]
(Promise Any)))
(do promise.monad
@@ -116,8 +89,8 @@
console (|> console.system
promise.future
(:: @ map (|>> try.assume console.async)))]
- (case service
- (#/cli.Compilation configuration)
+ (case (get@ #/cli.service configuration)
+ #/cli.Compilation
(<| (or-crash! "Compilation failed:")
(do (try.with promise.monad)
[[state archive] (:share [<parameters>]
@@ -125,19 +98,16 @@
platform}
{(Promise (Try [(directive.State+ <parameters>)
Archive]))
- (platform.initialize extension target host (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)})
+ (platform.initialize static (get@ #/cli.module configuration) expander host-analysis platform generation-bundle host-directive-bundle program extender)})
[archive state] (:share [<parameters>]
{(Platform <parameters>)
platform}
{(Promise (Try [Archive (directive.State+ <parameters>)]))
- (platform.compile target partial-host-extension expander platform host configuration archive extension state)})
- _ (ioW.freeze (get@ #platform.&file-system platform) host target archive)
- ## _ (save-artifacts! (get@ #platform.&file-system platform) state packager,package)
- ## _ (cache/io.clean target ...)
- ]
+ (platform.compile static expander platform configuration [archive state])})
+ _ (ioW.freeze (get@ #platform.&file-system platform) (get@ #/static.host static) (get@ #/static.target static) archive)]
(wrap (log! "Compilation complete!"))))
- (#/cli.Interpretation configuration)
+ #/cli.Interpretation
## TODO: Fix the interpreter...
(undefined)
## (<| (or-crash! "Interpretation failed:")
diff --git a/stdlib/source/program/compositor/cli.lux b/stdlib/source/program/compositor/cli.lux
index 4453d5d36..0c20257ed 100644
--- a/stdlib/source/program/compositor/cli.lux
+++ b/stdlib/source/program/compositor/cli.lux
@@ -4,23 +4,20 @@
["p" parser
["." cli (#+ Parser)]]]
[world
- [file (#+ Path)]]]
- ## [///
- ## [importer (#+ Source)]]
- )
+ [file (#+ Path)]]])
+
+(type: #export Service
+ #Compilation
+ #Interpretation)
(type: #export Configuration
- {## #sources (List Source)
+ {#service Service
#sources (List Path)
#target Path
#module Text})
-(type: #export Service
- (#Compilation Configuration)
- (#Interpretation Configuration))
-
(template [<name> <long>]
- [(def: #export <name>
+ [(def: <name>
(Parser Text)
(cli.named <long> cli.any))]
@@ -29,15 +26,17 @@
[module "--module"]
)
+
+(def: service
+ (Parser Service)
+ ($_ p.or
+ (cli.this "build")
+ (cli.this "repl")))
+
(def: #export configuration
(Parser Configuration)
($_ p.and
+ ..service
(p.some ..source)
..target
..module))
-
-(def: #export service
- (Parser Service)
- ($_ p.or
- (p.after (cli.this "build") ..configuration)
- (p.after (cli.this "repl") ..configuration)))
diff --git a/stdlib/source/program/compositor/static.lux b/stdlib/source/program/compositor/static.lux
new file mode 100644
index 000000000..3fdd8727e
--- /dev/null
+++ b/stdlib/source/program/compositor/static.lux
@@ -0,0 +1,11 @@
+(.module:
+ [lux #*
+ [target (#+ Host)]
+ [world
+ [file (#+ Path)]]])
+
+(type: #export Static
+ {#host Host
+ #host-module-extension Text
+ #target Path
+ #artifact-extension Text})
diff --git a/stdlib/source/test/lux/abstract/equivalence.lux b/stdlib/source/test/lux/abstract/equivalence.lux
index b7db2ee70..7cc5c95f9 100644
--- a/stdlib/source/test/lux/abstract/equivalence.lux
+++ b/stdlib/source/test/lux/abstract/equivalence.lux
@@ -18,7 +18,9 @@
[leftN random.nat
rightN random.nat
leftI random.int
- rightI random.int]
+ rightI random.int
+ sample random.nat
+ different (|> random.nat (random.filter (|>> (n.= sample) not)))]
(<| (_.covering /._)
($_ _.and
(_.cover [/.sum]
@@ -38,7 +40,26 @@
(:: equivalence = [leftN leftI] [leftN leftI]))
(bit@= (and (:: n.equivalence = leftN rightN)
(:: i.equivalence = leftI rightI))
- (:: equivalence = [leftN leftI] [rightN rightI])))))))))
+ (:: equivalence = [leftN leftI] [rightN rightI])))))
+ (_.cover [/.rec]
+ (let [equivalence (: (Equivalence (List Nat))
+ (/.rec (function (_ equivalence)
+ (structure
+ (def: (= left right)
+ (case [left right]
+ [#.Nil #.Nil]
+ true
+
+ [(#.Cons leftH lefT) (#.Cons rightH rightT)]
+ (and (n.= leftH rightH)
+ (:: equivalence = lefT rightT))
+
+ _
+ false))))))]
+ (and (:: equivalence = (list sample sample) (list sample sample))
+ (not (:: equivalence = (list sample sample) (list sample)))
+ (not (:: equivalence = (list sample sample) (list different different))))))
+ ))))
(def: #export (spec (^open "_@.") generator)
(All [a] (-> (Equivalence a) (Random a) Test))
diff --git a/stdlib/source/test/lux/control.lux b/stdlib/source/test/lux/control.lux
index b393e1325..dbfb5b4a4 100644
--- a/stdlib/source/test/lux/control.lux
+++ b/stdlib/source/test/lux/control.lux
@@ -22,6 +22,7 @@
["#." frp]
["#." process]
["#." promise]
+ ["#." semaphore]
["#." stm]]
["#." parser #_
["#/." text]
@@ -29,8 +30,7 @@
[security
["#." policy]]
[function
- ["#." memo]]
- ])
+ ["#." memo]]])
(def: concurrency
Test
@@ -40,6 +40,7 @@
/frp.test
/process.test
/promise.test
+ /semaphore.test
/stm.test
))
diff --git a/stdlib/source/test/lux/control/concurrency/semaphore.lux b/stdlib/source/test/lux/control/concurrency/semaphore.lux
index bd5d72d43..e26c1a0f2 100644
--- a/stdlib/source/test/lux/control/concurrency/semaphore.lux
+++ b/stdlib/source/test/lux/control/concurrency/semaphore.lux
@@ -1,146 +1,175 @@
(.module:
[lux #*
+ ["_" test (#+ Test)]
[abstract
["." monad (#+ do)]]
[control
["." io]
+ ["." try]
+ ["." exception (#+ exception:)]
[concurrency
- ["/" semaphore]
["." promise (#+ Promise)]
["." atom (#+ Atom)]]]
[data
["." maybe]
[number
["n" nat]]
- ["." text ("#;." equivalence monoid)
+ ["." text ("#@." equivalence)
["%" format (#+ format)]]
[collection
- ["." list ("#;." functor)]]]
+ ["." list ("#@." functor)]]]
+ [type
+ ["." refinement]]
[math
- ["r" random]]]
- lux/test)
+ ["." random]]]
+ {1
+ ["." /]})
-## (def: (wait-many-times times semaphore)
-## (-> Nat /.Semaphore (Promise Any))
-## (loop [steps times]
-## (if (n.> 0 steps)
-## (do promise.monad
-## [_ (/.wait semaphore)]
-## (recur (dec steps)))
-## (:: promise.monad wrap []))))
+(def: semaphore
+ Test
+ (_.with-cover [/.Semaphore]
+ ($_ _.and
+ (do random.monad
+ [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1))))
+ #let [semaphore (/.semaphore initial-open-positions)]]
+ (wrap (do promise.monad
+ [result (promise.time-out 10 (/.wait semaphore))]
+ (_.claim [/.semaphore]
+ (case result
+ (#.Some _)
+ true
-## (context: "Semaphore."
-## (<| (times 100)
-## (do @
-## [open-positions (|> r.nat (:: @ map (|>> (n.% 10) (n.max 1))))]
-## ($_ seq
-## (let [semaphore (/.semaphore open-positions)]
-## (wrap (do promise.monad
-## [_ (wait-many-times open-positions semaphore)]
-## (assert "Can wait on a semaphore up to the number of open positions without blocking."
-## true))))
-## (let [semaphore (/.semaphore open-positions)]
-## (wrap (do promise.monad
-## [result (<| (promise.time-out 100)
-## (wait-many-times (inc open-positions) semaphore))]
-## (assert "Waiting on a semaphore more than the number of open positions blocks the process."
-## (case result
-## (#.Some _)
-## false
+ #.None
+ false)))))
+ (do random.monad
+ [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1))))
+ #let [semaphore (/.semaphore initial-open-positions)]]
+ (wrap (do promise.monad
+ [_ (monad.map @ /.wait (list.repeat initial-open-positions semaphore))
+ result (promise.time-out 10 (/.wait semaphore))]
+ (_.claim [/.wait]
+ (case result
+ (#.Some _)
+ false
-## #.None
-## true)))))
-## (let [semaphore (/.semaphore open-positions)]
-## (wrap (do promise.monad
-## [_ (: (Promise Any)
-## (loop [steps (n.* 2 open-positions)]
-## (if (n.> 0 steps)
-## (do @
-## [_ (/.wait semaphore)
-## _ (/.signal semaphore)]
-## (recur (dec steps)))
-## (wrap []))))]
-## (assert "Signaling a semaphore replenishes its open positions."
-## true))))
-## (let [semaphore (/.semaphore open-positions)]
-## (wrap (do promise.monad
-## [#let [resource (atom.atom "")
-## blocked (do @
-## [_ (wait-many-times open-positions semaphore)
-## _ (/.wait semaphore)
-## #let [_ (io.run (atom.update (|>> (format "B"))
-## resource))]]
-## (wrap []))]
-## _ (promise.wait 100)
-## _ (exec (io.run (atom.update (|>> (format "A"))
-## resource))
-## (/.signal semaphore))
-## _ blocked]
-## (assert "A blocked process can be un-blocked by a signal somewhere else."
-## (text;= "BA"
-## (io.run (atom.read resource)))))))
-## ))))
+ #.None
+ true)))))
+ (do random.monad
+ [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1))))
+ #let [semaphore (/.semaphore initial-open-positions)]]
+ (wrap (do promise.monad
+ [_ (monad.map @ /.wait (list.repeat initial-open-positions semaphore))
+ #let [block (/.wait semaphore)]
+ result/0 (promise.time-out 10 block)
+ open-positions (/.signal semaphore)
+ result/1 (promise.time-out 10 block)]
+ (_.claim [/.signal]
+ (case [result/0 result/1 open-positions]
+ [#.None (#.Some _) (#try.Success +0)]
+ true
-## (context: "Mutex."
-## (<| (times 100)
-## (do @
-## [repetitions (|> r.nat (:: @ map (|>> (n.% 100) (n.max 10))))]
-## ($_ seq
-## (let [mutex (/.mutex [])]
-## (wrap (do promise.monad
-## [#let [resource (atom.atom "")
-## expected-As (text.join-with "" (list.repeat repetitions "A"))
-## expected-Bs (text.join-with "" (list.repeat repetitions "B"))
-## processA (<| (/.synchronize mutex)
-## io.io
-## promise.future
-## (do io.monad
-## [_ (<| (monad.seq @)
-## (list.repeat repetitions)
-## (atom.update (|>> (format "A")) resource))]
-## (wrap [])))
-## processB (<| (/.synchronize mutex)
-## io.io
-## promise.future
-## (do io.monad
-## [_ (<| (monad.seq @)
-## (list.repeat repetitions)
-## (atom.update (|>> (format "B")) resource))]
-## (wrap [])))]
-## _ processA
-## _ processB
-## #let [outcome (io.run (atom.read resource))]]
-## (assert "Mutexes only allow one process to execute at a time."
-## (or (text;= (format expected-As expected-Bs)
-## outcome)
-## (text;= (format expected-Bs expected-As)
-## outcome))))))
-## ))))
+ _
+ false)))))
+ (do random.monad
+ [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1))))
+ #let [semaphore (/.semaphore initial-open-positions)]]
+ (wrap (do promise.monad
+ [outcome (/.signal semaphore)]
+ (_.claim [/.semaphore-is-maxed-out]
+ (case outcome
+ (#try.Failure error)
+ (exception.match? /.semaphore-is-maxed-out error)
-## (def: (waiter resource barrier id)
-## (-> (Atom Text) /.Barrier Nat (Promise Any))
-## (do promise.monad
-## [_ (/.block barrier)
-## #let [_ (io.run (atom.update (|>> (format (%.nat id))) resource))]]
-## (wrap [])))
+ _
+ false)))))
+ )))
-## (context: "Barrier."
-## (let [limit 10
-## barrier (/.barrier (maybe.assume (/.limit limit)))
-## resource (atom.atom "")]
-## ($_ seq
-## (wrap (do promise.monad
-## [#let [ids (list.n/range 0 (dec limit))
-## waiters (list;map (function (_ id)
-## (let [process (waiter resource barrier id)]
-## (exec (io.run (atom.update (|>> (format "_")) resource))
-## process)))
-## ids)]
-## _ (monad.seq @ waiters)
-## #let [outcome (io.run (atom.read resource))]]
-## (assert "A barrier can stop all processes from acting, until an amount of waiting processes is reached, and then the barrier is un-blocked for all."
-## (and (text.ends-with? "__________" outcome)
-## (list.every? (function (_ id)
-## (text.contains? (%.nat id) outcome))
-## ids)
-## )))))))
+(def: mutex
+ Test
+ (_.with-cover [/.Mutex]
+ ($_ _.and
+ (do random.monad
+ [repetitions (|> random.nat (:: @ map (|>> (n.% 100) (n.max 10))))
+ #let [resource (atom.atom "")
+ expected-As (text.join-with "" (list.repeat repetitions "A"))
+ expected-Bs (text.join-with "" (list.repeat repetitions "B"))
+ mutex (/.mutex [])
+ processA (<| (/.synchronize mutex)
+ io.io
+ promise.future
+ (do io.monad
+ [_ (<| (monad.seq @)
+ (list.repeat repetitions)
+ (atom.update (|>> (format "A")) resource))]
+ (wrap [])))
+ processB (<| (/.synchronize mutex)
+ io.io
+ promise.future
+ (do io.monad
+ [_ (<| (monad.seq @)
+ (list.repeat repetitions)
+ (atom.update (|>> (format "B")) resource))]
+ (wrap [])))]]
+ (wrap (do promise.monad
+ [_ processA
+ _ processB
+ #let [outcome (io.run (atom.read resource))]]
+ (_.claim [/.mutex /.synchronize]
+ (or (text@= (format expected-As expected-Bs)
+ outcome)
+ (text@= (format expected-Bs expected-As)
+ outcome))))))
+ )))
+
+(def: (waiter resource barrier id)
+ (-> (Atom Text) /.Barrier Nat (Promise Any))
+ (do promise.monad
+ [_ (/.block barrier)
+ _ (promise.future (atom.update (|>> (format (%.nat id))) resource))]
+ (wrap [])))
+
+(def: barrier
+ Test
+ (_.with-cover [/.Barrier]
+ ($_ _.and
+ (do random.monad
+ [raw random.nat]
+ (_.cover [/.Limit /.limit]
+ (case [raw (/.limit raw)]
+ [0 #.None]
+ true
+
+ [_ (#.Some limit)]
+ (and (n.> 0 raw)
+ (n.= raw (refinement.un-refine limit))))))
+ (do random.monad
+ [limit (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1))))
+ #let [barrier (/.barrier (maybe.assume (/.limit limit)))
+ resource (atom.atom "")]]
+ (wrap (do promise.monad
+ [#let [ending (|> "_"
+ (list.repeat limit)
+ (text.join-with ""))
+ ids (list.n/range 0 (dec limit))
+ waiters (list@map (function (_ id)
+ (exec (io.run (atom.update (|>> (format "_")) resource))
+ (waiter resource barrier id)))
+ ids)]
+ _ (monad.seq @ waiters)
+ #let [outcome (io.run (atom.read resource))]]
+ (_.claim [/.barrier /.block]
+ (and (text.ends-with? ending outcome)
+ (list.every? (function (_ id)
+ (text.contains? (%.nat id) outcome))
+ ids)
+ )))))
+ )))
+
+(def: #export test
+ Test
+ (<| (_.covering /._)
+ ($_ _.and
+ ..semaphore
+ ..mutex
+ ..barrier
+ )))