diff options
34 files changed, 840 insertions, 747 deletions
diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux index 3c423692a..320dc4207 100644 --- a/stdlib/source/lux/control/concurrency/actor.lux +++ b/stdlib/source/lux/control/concurrency/actor.lux @@ -26,26 +26,21 @@ ["csw" writer]]]] ["." meta (#+ with-gensyms monad) ["." annotation]] - [type - abstract]] + [type (#+ :share) + ["." abstract (#+ abstract: :representation :abstraction)]]] [// ["." atom (#+ Atom atom)] ["." promise (#+ Promise Resolver) ("#@." monad)]]) (exception: #export poisoned) - -(exception: #export (dead {actor-name Text} - {message-name Text}) - (exception.report - ["Actor" actor-name] - ["Message" message-name])) +(exception: #export dead) (with-expansions - [<Message> (as-is (-> s (Actor s) (Promise (Try s)))) - <Obituary> (as-is [Text s (List <Message>)]) + [<Mail> (as-is (-> s (Actor s) (Promise (Try s)))) + <Obituary> (as-is [Text s (List <Mail>)]) <Mailbox> (as-is (Rec Mailbox - [(Promise [<Message> Mailbox]) - (Resolver [<Message> Mailbox])]))] + [(Promise [<Mail> Mailbox]) + (Resolver [<Mail> Mailbox])]))] (def: (pending [read write]) (All [a] @@ -68,44 +63,37 @@ (Resolver <Obituary>)] #mailbox (Atom <Mailbox>)} - {#.doc "An actor, defined as all the necessities it requires."} - - ## TODO: Delete after new-luxc becomes the new standard compiler. - (def: (actor mailbox obituary) - (All [s] - (-> (Atom <Mailbox>) - [(Promise <Obituary>) - (Resolver <Obituary>)] - (Actor s))) - (:abstraction {#obituary obituary - #mailbox mailbox})) - - (type: #export (Message s) - <Message>) + (type: #export (Mail s) + <Mail>) (type: #export (Obituary s) <Obituary>) - (type: #export (Behavior s) - {#.doc "An actor's behavior when messages are received."} - {#handle (-> (Message s) s (Actor s) (Promise (Try s))) - #end (-> Text s (Promise Any))}) + (type: #export (Behavior o s) + {#.doc "An actor's behavior when mail is received and when a fatal error occurs."} + {#on-init (-> o s) + #on-mail (-> (Mail s) s (Actor s) (Promise (Try s))) + #on-stop (-> Text s (Promise Any))}) - (def: #export (spawn behavior init) + (def: #export (spawn! behavior init) {#.doc "Given a behavior and initial state, spawns an actor and returns it."} - (All [s] (-> (Behavior s) s (IO (Actor s)))) - (io (let [[handle end] behavior - self (actor (atom (promise.promise [])) - (promise.promise [])) - process (loop [state init + (All [o s] (-> (Behavior o s) o (IO (Actor s)))) + (io (let [[on-init on-mail on-stop] behavior + self (:share [o s] + {(Behavior o s) + behavior} + {(Actor s) + (:abstraction {#obituary (promise.promise []) + #mailbox (atom (promise.promise []))})}) + process (loop [state (on-init init) [|mailbox| _] (io.run (atom.read (get@ #mailbox (:representation self))))] (do {! promise.monad} [[head tail] |mailbox| - ?state' (handle head state self)] + ?state' (on-mail head state self)] (case ?state' (#try.Failure error) (do ! - [_ (end error state)] + [_ (on-stop error state)] (let [[_ resolve] (get@ #obituary (:representation self))] (exec (io.run (do io.monad @@ -134,13 +122,13 @@ (let [[obituary _] (get@ #obituary (:representation actor))] (promise.poll obituary))) - (def: #export (send message actor) - {#.doc "Communicate with an actor through message passing."} - (All [s] (-> (Message s) (Actor s) (IO Bit))) + (def: #export (mail! mail actor) + {#.doc "Send mail to an actor.."} + (All [s] (-> (Mail s) (Actor s) (IO (Try Any)))) (do {! io.monad} [alive? (..alive? actor)] (if alive? - (let [entry [message (promise.promise [])]] + (let [entry [mail (promise.promise [])]] (do ! [|mailbox|&resolve (atom.read (get@ #mailbox (:representation actor)))] (loop [[|mailbox| resolve] |mailbox|&resolve] @@ -153,272 +141,239 @@ (if resolved? (do ! [_ (atom.write (product.right entry) (get@ #mailbox (:representation actor)))] - (wrap true)) + (wrap (exception.return []))) (recur |mailbox|&resolve))) (#.Some [_ |mailbox|']) (recur |mailbox|')))))) - (wrap false)))) + (wrap (exception.throw ..dead []))))) + + (type: #export (Message s o) + (-> s (Actor s) (Promise (Try [s o])))) + + (def: (mail message) + (All [s o] (-> (Message s o) [(Promise (Try o)) (Mail s)])) + (let [[promise resolve] (:share [s o] + {(Message s o) + message} + {[(Promise (Try o)) + (Resolver (Try o))] + (promise.promise [])})] + [promise + (function (_ state self) + (do {! promise.monad} + [outcome (message state self)] + (case outcome + (#try.Success [state' return]) + (exec (io.run (resolve (#try.Success return))) + (promise.resolved (#try.Success state'))) + + (#try.Failure error) + (exec (io.run (resolve (#try.Failure error))) + (promise.resolved (#try.Failure error))))))])) + + (def: #export (tell! message actor) + {#.doc "Communicate with an actor through message passing."} + (All [s o] (-> (Message s o) (Actor s) (Promise (Try o)))) + (let [[promise mail] (..mail message)] + (do promise.monad + [outcome (promise.future (..mail! mail actor))] + (case outcome + (#try.Success) + promise + + (#try.Failure error) + (wrap (#try.Failure error)))))) ) ) -(def: (default-handle message state self) - (All [s] (-> (Message s) s (Actor s) (Promise (Try s)))) - (message state self)) +(def: (default-on-mail mail state self) + (All [s] (-> (Mail s) s (Actor s) (Promise (Try s)))) + (mail state self)) -(def: (default-end cause state) +(def: (default-on-stop cause state) (All [s] (-> Text s (Promise Any))) (promise@wrap [])) -(def: #export default-behavior - (All [s] (Behavior s)) - {#handle default-handle - #end default-end}) - -(def: #export (poison actor) - {#.doc (doc "Kills the actor by sending a message that will kill it upon processing," - "but allows the actor to handle previous messages.")} - (All [s] (-> (Actor s) (IO Bit))) - (send (function (_ state self) - (promise.resolved (exception.throw ..poisoned []))) - actor)) - -(template [<with> <resolve> <tag> <desc>] - [(def: (<with> name) - (-> Name cs.Annotations cs.Annotations) - (|>> (#.Cons [(name-of <tag>) - (code.tag name)]))) - - (def: (<resolve> name) - (-> Name (Meta Name)) - (do meta.monad - [constant (meta.find-def name)] - (case constant - (#.Left de-aliased) - (<resolve> de-aliased) - - (#.Right [_ _ annotations _]) - (case (annotation.tag (name-of <tag>) annotations) - (#.Some actor-name) - (wrap actor-name) - - _ - (meta.fail (format "Definition is not " <desc> "."))))))] - - [with-actor resolve-actor #..actor "an actor"] - [with-message resolve-message #..message "a message"] - ) +(def: #export default + (All [s] (Behavior s s)) + {#on-init function.identity + #on-mail ..default-on-mail + #on-stop ..default-on-stop}) + +(def: #export (poison! actor) + {#.doc (doc "Kills the actor by sending mail that will kill it upon processing," + "but allows the actor to handle previous mail.")} + (All [s] (-> (Actor s) (IO (Try Any)))) + (..mail! (function (_ state self) + (promise.resolved (exception.throw ..poisoned []))) + actor)) (def: actor-decl^ (Parser [Text (List Text)]) (<>.either (<c>.form (<>.and <c>.local-identifier (<>.some <c>.local-identifier))) (<>.and <c>.local-identifier (:: <>.monad wrap (list))))) -(template [<name> <desc>] - [(def: <name> - (-> Text Text) - (|>> (format <desc> "@")))] - - [state-name "State"] - [behavior-name "Behavior"] - [new-name "new"] - ) - -(type: HandleC +(type: On-MailC [[Text Text Text] Code]) -(type: StopC +(type: On-StopC [[Text Text] Code]) (type: BehaviorC - [(Maybe HandleC) (Maybe StopC)]) + [(Maybe On-MailC) (Maybe On-StopC) (List Code)]) + +(def: argument + (Parser Text) + <c>.local-identifier) (def: behavior^ (Parser BehaviorC) - (let [handle-args (<c>.tuple ($_ <>.and <c>.local-identifier <c>.local-identifier <c>.local-identifier)) - stop-args (<c>.tuple ($_ <>.and <c>.local-identifier <c>.local-identifier))] - (<>.and (<>.maybe (<c>.form (<>.and (<c>.form (<>.after (<c>.this! (' handle)) handle-args)) - <c>.any))) - (<>.maybe (<c>.form (<>.and (<c>.form (<>.after (<c>.this! (' stop)) stop-args)) - <c>.any)))))) - -(syntax: #export (actor: - {export csr.export} - {[_name _vars] actor-decl^} - {annotations (<>.default cs.empty-annotations csr.annotations)} - state-type - {[?handle ?stop] behavior^}) - {#.doc (doc "Defines an actor, with its behavior and internal state." - (actor: #export Counter - Nat - - ((stop cause state) - (:: promise.monad wrap - (log! (if (exception.match? ..poisoned cause) - (format "Counter was poisoned: " (%.nat state)) - cause))))) - - (actor: #export (Stack a) - (List a) - - ((handle message state self) - (do (try.with promise.monad) - [#let [_ (log! "BEFORE")] - output (message state self) - #let [_ (log! "AFTER")]] - (wrap output)))))} - (with-gensyms [g!_ g!init] - (do meta.monad - [module meta.current-module-name - #let [g!type (code.local-identifier (state-name _name)) - g!behavior (code.local-identifier (behavior-name _name)) - g!actor (code.local-identifier _name) - g!new (code.local-identifier (new-name _name)) - g!vars (list@map code.local-identifier _vars)]] - (wrap (list (` (type: (~+ (csw.export export)) ((~ g!type) (~+ g!vars)) - (~ state-type))) - (` (type: (~+ (csw.export export)) ((~ g!actor) (~+ g!vars)) - (~ (|> annotations - (with-actor [module _name]) - csw.annotations)) - (..Actor ((~ g!type) (~+ g!vars))))) - (` (def: (~+ (csw.export export)) (~ g!behavior) - (All [(~+ g!vars)] - (..Behavior ((~ g!type) (~+ g!vars)))) - {#..handle (~ (case ?handle - #.None - (` (~! ..default-handle)) - - (#.Some [[messageN stateN selfN] bodyC]) - (` (function ((~ g!_) - (~ (code.local-identifier messageN)) - (~ (code.local-identifier stateN)) - (~ (code.local-identifier selfN))) - ((~! do) ((~! try.with) (~! promise.monad)) - [] - (~ bodyC)))))) - #..end (~ (case ?stop - #.None - (` (~! ..default-end)) - - (#.Some [[causeN stateN] bodyC]) - (` (function ((~ g!_) - (~ (code.local-identifier causeN)) - (~ (code.local-identifier stateN))) - ((~! do) (~! promise.monad) - [] - (~ bodyC))))))})) - (` (def: (~+ (csw.export export)) ((~ g!new) (~ g!init)) - (All [(~+ g!vars)] - (-> ((~ g!type) (~+ g!vars)) (io.IO ((~ g!actor) (~+ g!vars))))) - (..spawn (~ g!behavior) (~ g!init)))))) - ))) - -(type: Signature - {#vars (List Text) - #name Text - #inputs (List cs.Typed-Input) - #state Text - #self Text - #output Code}) - -(def: signature^ - (Parser Signature) - (<c>.form ($_ <>.and - (<>.default (list) (<c>.tuple (<>.some <c>.local-identifier))) - <c>.local-identifier - (<>.some csr.typed-input) - <c>.local-identifier - <c>.local-identifier - <c>.any))) - -(def: reference^ - (Parser [Name (List Text)]) - (<>.either (<c>.form (<>.and <c>.identifier (<>.some <c>.local-identifier))) - (<>.and <c>.identifier (:: <>.monad wrap (list))))) - -(syntax: #export (message: - {export csr.export} - {[actor-name actor-vars] reference^} - {signature signature^} - {annotations (<>.default cs.empty-annotations csr.annotations)} - body) - {#.doc (doc "A message can access the actor's state through the state parameter." - "A message can also access the actor itself through the self parameter." - "A message's output must be a task containing a 2-tuple with the updated state and a return value." - "A message may succeed or fail (in case of failure, the actor dies)." - - (message: #export Counter - (count! [increment Nat] state self Nat) - (let [state' (n.+ increment state)] - (promise.resolved (#try.Success [state' state'])))) - - (message: #export (Stack a) - (push [value a] state self (List a)) - (let [state' (#.Cons value state)] - (promise.resolved (#try.Success [state' state'])))))} - (with-gensyms [g!_ g!return g!error g!task g!sent? g!resolve] - (do meta.monad - [current-module meta.current-module-name - actor-name (resolve-actor actor-name) - #let [message-name [current-module (get@ #name signature)] - g!type (code.identifier (product.both function.identity state-name actor-name)) - g!message (code.local-identifier (get@ #name signature)) - g!actor-vars (list@map code.local-identifier actor-vars) - actorC (` ((~ (code.identifier actor-name)) (~+ g!actor-vars))) - g!all-vars (|> (get@ #vars signature) (list@map code.local-identifier) (list@compose g!actor-vars)) - g!inputsC (|> (get@ #inputs signature) (list@map product.left)) - g!inputsT (|> (get@ #inputs signature) (list@map product.right)) - g!state (|> signature (get@ #state) code.local-identifier) - g!self (|> signature (get@ #self) code.local-identifier) - g!actor-refs (: (List Code) - (if (list.empty? actor-vars) - (list) - (|> actor-vars list.size list.indices (list@map (|>> code.nat (~) ($) (`)))))) - ref-replacements (|> (if (list.empty? actor-vars) - (list) - (|> actor-vars list.size list.indices (list@map (|>> code.nat (~) ($) (`))))) - (: (List Code)) - (list.zip/2 g!all-vars) - (: (List [Code Code]))) - g!outputT (list@fold (function (_ [g!var g!ref] outputT) - (code.replace g!var g!ref outputT)) - (get@ #output signature) - ref-replacements)]] - (wrap (list (` (def: (~+ (csw.export export)) ((~ g!message) (~+ g!inputsC) (~ g!self)) - (~ (|> annotations - (with-message actor-name) - csw.annotations)) - (All [(~+ g!all-vars)] - (-> (~+ g!inputsT) - (~ actorC) - ((~! promise.Promise) ((~! try.Try) (~ (get@ #output signature)))))) - (let [[(~ g!task) (~ g!resolve)] (: [((~! promise.Promise) ((~! try.Try) (~ g!outputT))) - ((~! promise.Resolver) ((~! try.Try) (~ g!outputT)))] - (promise.promise []))] - ((~! io.run) ((~! do) (~! io.monad) - [(~ g!sent?) (..send (function ((~ g!_) (~ g!state) (~ g!self)) - ((~! do) (~! promise.monad) - [(~ g!return) (: ((~! promise.Promise) - ((~! try.Try) - [((~ g!type) (~+ g!actor-refs)) - (~ g!outputT)])) - ((~! do) ((~! try.with) (~! promise.monad)) - [] - (~ body)))] - (case (~ g!return) - (#try.Success [(~ g!state) (~ g!return)]) - (exec ((~! io.run) ((~ g!resolve) (#try.Success (~ g!return)))) - ((~! promise.resolved) (#try.Success (~ g!state)))) - - (#try.Failure (~ g!error)) - (exec ((~! io.run) ((~ g!resolve) (#try.Failure (~ g!error)))) - ((~! promise.resolved) (#try.Failure (~ g!error))))) - )) - (~ g!self))] - (if (~ g!sent?) - ((~' wrap) (~ g!task)) - ((~' wrap) ((~! promise.resolved) - ((~! exception.throw) ..dead [(~ (code.text (%.name actor-name))) - (~ (code.text (%.name message-name)))]))))))))) - ))))) + (let [on-mail-args ($_ <>.and ..argument ..argument ..argument) + on-stop-args ($_ <>.and ..argument ..argument)] + ($_ <>.and + (<>.maybe (<c>.form (<>.and (<c>.form (<>.after (<c>.this! (' on-mail)) on-mail-args)) + <c>.any))) + (<>.maybe (<c>.form (<>.and (<c>.form (<>.after (<c>.this! (' on-stop)) on-stop-args)) + <c>.any))) + (<>.some <c>.any)))) + +(def: (on-mail g!_ ?on-mail) + (-> Code (Maybe On-MailC) Code) + (case ?on-mail + #.None + (` (~! ..default-on-mail)) + + (#.Some [[mailN stateN selfN] bodyC]) + (` (function ((~ g!_) + (~ (code.local-identifier mailN)) + (~ (code.local-identifier stateN)) + (~ (code.local-identifier selfN))) + (~ bodyC))))) + +(def: (on-stop g!_ ?on-stop) + (-> Code (Maybe On-StopC) Code) + (case ?on-stop + #.None + (` (~! ..default-on-stop)) + + (#.Some [[causeN stateN] bodyC]) + (` (function ((~ g!_) + (~ (code.local-identifier causeN)) + (~ (code.local-identifier stateN))) + (~ bodyC))))) + +(with-expansions [<examples> (as-is (actor: #export (Stack a) + (List a) + + ((on-mail mail state self) + (do (try.with promise.monad) + [#let [_ (log! "BEFORE")] + output (mail state self) + #let [_ (log! "AFTER")]] + (wrap output))) + + (message: #export (push {value a} state self (List a)) + (let [state' (#.Cons value state)] + (promise.resolved (#try.Success [state' state']))))) + + (actor: #export Counter + Nat + + ((on-stop cause state) + (:: promise.monad wrap + (log! (if (exception.match? ..poisoned cause) + (format "Counter was poisoned: " (%.nat state)) + cause)))) + + (message: #export (count! {increment Nat} state self Any) + (let [state' (n.+ increment state)] + (promise.resolved (#try.Success [state' state'])))) + + (message: #export (read! state self Nat) + (promise.resolved (#try.Success [state state])))))] + (syntax: #export (actor: + {export csr.export} + {[name vars] actor-decl^} + {annotations (<>.default cs.empty-annotations csr.annotations)} + state-type + {[?on-mail ?on-stop messages] behavior^}) + {#.doc (doc "Defines an actor, with its behavior and internal state." + "Messages for the actor must be defined after the on-mail and on-stop handlers." + <examples>)} + (with-gensyms [g!_ g!init] + (do meta.monad + [g!type (meta.gensym (format name "-abstract-type")) + #let [g!actor (code.local-identifier name) + g!vars (list@map code.local-identifier vars)]] + (wrap (list (` ((~! abstract:) (~+ (csw.export export)) ((~ g!type) (~+ g!vars)) + (~ state-type) + + (def: (~+ (csw.export export)) (~ g!actor) + (All [(~+ g!vars)] + (..Behavior (~ state-type) ((~ g!type) (~+ g!vars)))) + {#..on-init (|>> ((~! abstract.:abstraction) (~ g!type))) + #..on-mail (~ (on-mail g!_ ?on-mail)) + #..on-stop (~ (on-stop g!_ ?on-stop))}) + + (~+ messages)))))))) + + (type: Signature + {#vars (List Text) + #name Text + #inputs (List cs.Typed-Input) + #state Text + #self Text + #output Code}) + + (def: signature^ + (Parser Signature) + (<c>.form ($_ <>.and + (<>.default (list) (<c>.tuple (<>.some <c>.local-identifier))) + <c>.local-identifier + (<>.some csr.typed-input) + <c>.local-identifier + <c>.local-identifier + <c>.any))) + + (def: reference^ + (Parser [Name (List Text)]) + (<>.either (<c>.form (<>.and <c>.identifier (<>.some <c>.local-identifier))) + (<>.and <c>.identifier (:: <>.monad wrap (list))))) + + (syntax: #export (message: + {export csr.export} + {signature signature^} + {annotations (<>.default cs.empty-annotations csr.annotations)} + body) + {#.doc (doc "A message can access the actor's state through the state parameter." + "A message can also access the actor itself through the self parameter." + "A message's output must be a promise containing a 2-tuple with the updated state and a return value." + "A message may succeed or fail (in case of failure, the actor dies)." + + <examples>)} + (with-gensyms [g!_ g!return] + (do meta.monad + [[actor-name actor-vars] abstract.current + #let [g!type (code.local-identifier actor-name) + g!message (code.local-identifier (get@ #name signature)) + g!actor-vars (list@map code.local-identifier actor-vars) + g!all-vars (|> (get@ #vars signature) (list@map code.local-identifier) (list@compose g!actor-vars)) + g!inputsC (|> (get@ #inputs signature) (list@map product.left)) + g!inputsT (|> (get@ #inputs signature) (list@map product.right)) + g!state (|> signature (get@ #state) code.local-identifier) + g!self (|> signature (get@ #self) code.local-identifier)]] + (wrap (list (` (def: (~+ (csw.export export)) ((~ g!message) (~+ g!inputsC)) + (~ (csw.annotations annotations)) + (All [(~+ g!all-vars)] + (-> (~+ g!inputsT) + (..Message ((~ g!type) (~+ g!actor-vars)) (~ (get@ #output signature))))) + (function ((~ g!_) (~ g!state) (~ g!self)) + (let [(~ g!state) ((~! abstract.:representation) (~ g!type) (~ g!state))] + ((~! do) (~! promise.monad) + [(~ g!return) (~ body)] + ((~' wrap) ((~! do) (~! try.monad) + [[(~ g!state) (~ g!return)] (~ g!return)] + ((~' wrap) [((~! abstract.:abstraction) (~ g!type) (~ g!state)) + (~ g!return)])))))))) + )))))) diff --git a/stdlib/source/lux/data/collection/tree.lux b/stdlib/source/lux/data/collection/tree.lux index aab50c4f3..375732b1b 100644 --- a/stdlib/source/lux/data/collection/tree.lux +++ b/stdlib/source/lux/data/collection/tree.lux @@ -2,9 +2,9 @@ [lux #* [abstract [functor (#+ Functor)] - [monad (#+ Monad do)] [equivalence (#+ Equivalence)] - [fold (#+ Fold)]] + [fold (#+ Fold)] + [monad (#+ do)]] [control ["<>" parser ["<c>" code (#+ Parser)]]] @@ -39,10 +39,13 @@ (def: tree^ (Parser Tree-Code) - (|> (|>> <>.some <c>.record (<>.and <c>.any)) + (|> (|>> <>.some + <c>.record + (<>.and <c>.any)) <>.rec <>.some <c>.record + (<>.default (list)) (<>.and <c>.any))) (syntax: #export (tree {root tree^}) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index f38a0c571..8f2ef6006 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -86,6 +86,18 @@ (wrap sample) (filter pred gen)))) +(def: #export (one check random) + (All [a b] + (-> (-> a (Maybe b)) (Random a) (Random b))) + (do ..monad + [sample random] + (case (check sample) + (#.Some output) + (wrap output) + + #.None + (one check random)))) + (def: #export (refine refiner gen) {#.doc "Retries the generator until the output can be refined."} (All [t r] (-> (Refiner t r) (Random t) (Random (Refined t r)))) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index 639f58137..22a21cc9c 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -91,6 +91,18 @@ #.None (exception.throw ..no-active-scopes []))))) +(def: #export current + (Meta [Text (List Text)]) + (do meta.monad + [[name type-vars abstraction representation] (..peek! #.None)] + (wrap [name (list@map code.format type-vars)]))) + +(def: #export (specific name) + (-> Text (Meta (List Text))) + (do meta.monad + [[name type-vars abstraction representation] (..peek! (#.Some name))] + (wrap (list@map code.format type-vars)))) + (template: (!push <source> <reference> <then>) (loop [entries <source>] (case entries @@ -167,7 +179,7 @@ (<>.and (<>@wrap #.None) <c>.any))) (template [<name> <from> <to>] - [(syntax: #export (<name> {[scope value] cast}) + [(syntax: #export (<name> {[scope value] ..cast}) (do meta.monad [[name type-vars abstraction representation] (peek! scope)] (wrap (list (` ((~! :cast) [(~+ type-vars)] (~ <from>) (~ <to>) diff --git a/stdlib/source/program/aedifex/artifact/extension.lux b/stdlib/source/program/aedifex/artifact/extension.lux index 412bf699a..78939260a 100644 --- a/stdlib/source/program/aedifex/artifact/extension.lux +++ b/stdlib/source/program/aedifex/artifact/extension.lux @@ -26,6 +26,6 @@ [lux-library] [jvm-library] [pom] - [sha1] + [sha-1] [md5] ) diff --git a/stdlib/source/program/aedifex/artifact/type.lux b/stdlib/source/program/aedifex/artifact/type.lux index 35035ebc4..5e5772ea2 100644 --- a/stdlib/source/program/aedifex/artifact/type.lux +++ b/stdlib/source/program/aedifex/artifact/type.lux @@ -13,6 +13,6 @@ ["tar" lux-library] ["jar" jvm-library] ["pom" pom] - ["sha1" sha1] + ["sha1" sha-1] ["md5" md5] ) diff --git a/stdlib/source/program/aedifex/command/deploy.lux b/stdlib/source/program/aedifex/command/deploy.lux index 25b1a15aa..3041c53f1 100644 --- a/stdlib/source/program/aedifex/command/deploy.lux +++ b/stdlib/source/program/aedifex/command/deploy.lux @@ -70,6 +70,6 @@ pom (promise@wrap (///pom.write profile)) _ (deploy! ///artifact/type.pom (|> pom (:: xml.codec encode) encoding.to-utf8)) _ (deploy! ///artifact/type.lux-library library) - _ (deploy! ///artifact/type.sha1 (///hash.data (///hash.sha1 library))) + _ (deploy! ///artifact/type.sha-1 (///hash.data (///hash.sha-1 library))) _ (deploy! ///artifact/type.md5 (///hash.data (///hash.md5 library)))] (wrap []))))) diff --git a/stdlib/source/program/aedifex/dependency/resolution.lux b/stdlib/source/program/aedifex/dependency/resolution.lux index 46d32a4f7..7e48610e3 100644 --- a/stdlib/source/program/aedifex/dependency/resolution.lux +++ b/stdlib/source/program/aedifex/dependency/resolution.lux @@ -33,6 +33,7 @@ ["/" profile] ["#." hash] ["#." pom] + ["#." package (#+ Package)] ["#." artifact ["#/." extension]]]]) @@ -85,23 +86,16 @@ ["Type" (%.text type)] ["Hash" (%.text hash)])))] - [sha1-does-not-match] + [sha-1-does-not-match] [md5-does-not-match] ) -(type: #export Package - {#library Binary - #pom XML - #dependencies (List Dependency) - #sha1 Text - #md5 Text}) - (def: (verified-hash dependency library url hash codec exception) (All [h] (-> Dependency Binary URL (-> Binary (///hash.Hash h)) (Codec Text (///hash.Hash h)) (Exception [Dependency Text]) - (IO (Try Text)))) + (IO (Try (///hash.Hash h))))) (do (try.with io.monad) [#let [expected (hash library)] actual (..download url)] @@ -111,7 +105,7 @@ actual (:: codec decode output) _ (exception.assert exception [dependency output] (:: ///hash.equivalence = expected actual))] - (wrap output))))) + (wrap actual))))) (def: #export (resolve repository dependency) (-> Repository Dependency (IO (Try Package))) @@ -119,7 +113,7 @@ prefix (format repository uri.separator (///artifact.uri artifact))] (do (try.with io.monad) [library (..download (format prefix (///artifact/extension.extension type))) - sha1 (..verified-hash dependency library (format prefix ///artifact/extension.sha1) ///hash.sha1 ///hash.sha1-codec ..sha1-does-not-match) + sha-1 (..verified-hash dependency library (format prefix ///artifact/extension.sha-1) ///hash.sha-1 ///hash.sha-1-codec ..sha-1-does-not-match) md5 (..verified-hash dependency library (format prefix ///artifact/extension.md5) ///hash.md5 ///hash.md5-codec ..md5-does-not-match) pom (..download (format prefix ///artifact/extension.pom))] (:: io.monad wrap @@ -127,11 +121,10 @@ [pom (encoding.from-utf8 pom) pom (:: xml.codec decode pom) profile (<xml>.run ///pom.parser pom)] - (wrap {#library library - #pom pom - #dependencies (set.to-list (get@ #/.dependencies profile)) - #sha1 sha1 - #md5 md5})))))) + (wrap {#///package.library library + #///package.pom pom + #///package.sha-1 sha-1 + #///package.md5 md5})))))) (type: #export Resolution (Dictionary Dependency Package)) @@ -179,6 +172,8 @@ #.None (..resolve-any repositories head)) - #let [resolution (dictionary.put head package resolution)] - resolution (resolve-all repositories (get@ #dependencies package) resolution)] + sub-dependencies (:: io.monad wrap (///package.dependencies package)) + resolution (|> resolution + (dictionary.put head package) + (resolve-all repositories (set.to-list sub-dependencies)))] (resolve-all repositories tail resolution)))) diff --git a/stdlib/source/program/aedifex/hash.lux b/stdlib/source/program/aedifex/hash.lux index 2f63d0edd..e5e4e020f 100644 --- a/stdlib/source/program/aedifex/hash.lux +++ b/stdlib/source/program/aedifex/hash.lux @@ -45,7 +45,7 @@ (java/security/MessageDigest::digest [value]) :abstraction))] - [sha1 ..SHA-1 "SHA-1"] + [sha-1 ..SHA-1 "SHA-1"] [md5 ..MD5 "MD5"] ) @@ -64,7 +64,7 @@ Nat <factor>)] - [20 sha1::size] + [20 sha-1::size] [16 md5::size] ) @@ -87,7 +87,7 @@ ["Expected size" (%.nat <size>)] ["Actual size" (%.nat (binary.size data))]))] - [not-a-sha1 ..sha1::size] + [not-a-sha-1 ..sha-1::size] [not-a-md5 ..md5::size] ) @@ -98,7 +98,7 @@ (#try.Success (:abstraction data)) (exception.throw <exception> [data])))] - [as-sha1 SHA-1 ..sha1::size ..not-a-sha1] + [as-sha-1 SHA-1 ..sha-1::size ..not-a-sha-1] [as-md5 MD5 ..md5::size ..not-a-md5] ) @@ -149,7 +149,7 @@ (def: encode (|>> :representation ..encode)) (def: decode (..decode <nat> <constructor>)))] - [sha1-codec SHA-1 ..sha1::size ..as-sha1] + [sha-1-codec SHA-1 ..sha-1::size ..as-sha-1] [md5-codec MD5 ..md5::size ..as-md5] ) diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux index 3c06f0222..dc769bcc1 100644 --- a/stdlib/source/program/aedifex/local.lux +++ b/stdlib/source/program/aedifex/local.lux @@ -34,11 +34,12 @@ ["/" profile (#+ Profile)] ["#." pom] ["#." hash] + ["#." package (#+ Package)] ["#." artifact (#+ Artifact) ["#/." type] ["#/." extension]] ["#." dependency (#+ Dependency) - ["#/." resolution (#+ Package Resolution)]]]) + ["#/." resolution (#+ Resolution)]]]) (def: #export (repository system) (All [a] (-> (file.System a) Path)) @@ -67,16 +68,22 @@ directory (: (Promise (Try (Directory Promise))) (file.get-directory promise.monad system directory)) _ (..save! system - (get@ #//dependency/resolution.library package) + (get@ #//package.library package) (format prefix (//artifact/extension.extension type))) _ (..save! system - (encoding.to-utf8 (get@ #//dependency/resolution.sha1 package)) - (format prefix //artifact/extension.sha1)) + (|> package + (get@ #//package.sha-1) + (:: //hash.sha-1-codec encode) + encoding.to-utf8) + (format prefix //artifact/extension.sha-1)) _ (..save! system - (encoding.to-utf8 (get@ #//dependency/resolution.md5 package)) + (|> package + (get@ #//package.md5) + (:: //hash.md5-codec encode) + encoding.to-utf8) (format prefix //artifact/extension.md5)) _ (..save! system - (|> package (get@ #//dependency/resolution.pom) (:: xml.codec encode) encoding.to-utf8) + (|> package (get@ #//package.pom) (:: xml.codec encode) encoding.to-utf8) (format prefix //artifact/extension.pom))] (wrap []))) @@ -102,24 +109,19 @@ (file.make-directories promise.monad system (..path system artifact))) #let [prefix (format directory (:: system separator) (//artifact.identity artifact))] pom (..read! system (format prefix //artifact/extension.pom)) - [pom dependencies] (:: promise.monad wrap - (do try.monad - [pom (encoding.from-utf8 pom) - pom (:: xml.codec decode pom) - profile (<xml>.run //pom.parser pom)] - (wrap [pom (get@ #/.dependencies profile)]))) library (..read! system (format prefix (//artifact/extension.extension type))) - sha1 (..read! system (format prefix //artifact/extension.sha1)) + sha-1 (..read! system (format prefix //artifact/extension.sha-1)) md5 (..read! system (format prefix //artifact/extension.md5))] - (wrap {#//dependency/resolution.library library - #//dependency/resolution.pom pom - #//dependency/resolution.dependencies (set.to-list dependencies) - #//dependency/resolution.sha1 (|> sha1 - (:coerce (//hash.Hash //hash.SHA-1)) - (:: //hash.sha1-codec encode)) - #//dependency/resolution.md5 (|> md5 - (:coerce (//hash.Hash //hash.MD5)) - (:: //hash.md5-codec encode))}))) + (:: promise.monad wrap + (do try.monad + [pom (encoding.from-utf8 pom) + pom (:: xml.codec decode pom) + sha-1 (//hash.as-sha-1 sha-1) + md5 (//hash.as-md5 md5)] + (wrap {#//package.library library + #//package.pom pom + #//package.sha-1 sha-1 + #//package.md5 md5}))))) (def: #export (all-cached system dependencies resolution) (-> (file.System Promise) (List Dependency) Resolution (Promise (Try Resolution))) @@ -138,10 +140,14 @@ (with-expansions [<next> (as-is (all-cached system tail resolution))] (case package (#try.Success package) - (let [resolution (dictionary.put head package resolution)] - (do (try.with promise.monad) - [resolution (all-cached system (get@ #//dependency/resolution.dependencies package) resolution)] - <next>)) + (do (try.with promise.monad) + [sub-dependencies (|> package + //package.dependencies + (:: promise.monad wrap)) + resolution (|> resolution + (dictionary.put head package) + (all-cached system (set.to-list sub-dependencies)))] + <next>) (#try.Failure error) <next>))))) diff --git a/stdlib/source/program/aedifex/package.lux b/stdlib/source/program/aedifex/package.lux new file mode 100644 index 000000000..757f116e6 --- /dev/null +++ b/stdlib/source/program/aedifex/package.lux @@ -0,0 +1,36 @@ +(.module: + [lux #* + [control + ["." try (#+ Try) ("#@." functor)] + [parser + ["<.>" xml]]] + [data + [binary (#+ Binary)] + [format + [xml (#+ XML)]] + [collection + [set (#+ Set)]]]] + ["." // #_ + [dependency (#+ Dependency)] + ["/" profile] + ["#." hash (#+ Hash SHA-1 MD5)] + ["#." pom]]) + +(type: #export Package + {#library Binary + #pom XML + #sha-1 (Hash SHA-1) + #md5 (Hash MD5)}) + +(def: #export (local pom library) + (-> XML Binary Package) + {#library library + #pom pom + #sha-1 (//hash.sha-1 library) + #md5 (//hash.md5 library)}) + +(def: #export dependencies + (-> Package (Try (Set Dependency))) + (|>> (get@ #pom) + (<xml>.run //pom.parser) + (try@map (get@ #/.dependencies)))) diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux index dec078509..c1aa9ae9b 100644 --- a/stdlib/source/test/aedifex.lux +++ b/stdlib/source/test/aedifex.lux @@ -13,6 +13,7 @@ ["#/." install]] ["#." local] ["#." dependency] + ["#." package] ["#." profile] ["#." project] ["#." cli] @@ -29,6 +30,7 @@ /command/install.test /local.test /dependency.test + /package.test /profile.test /project.test /cli.test diff --git a/stdlib/source/test/aedifex/artifact/extension.lux b/stdlib/source/test/aedifex/artifact/extension.lux index e65dd567a..c3da8465c 100644 --- a/stdlib/source/test/aedifex/artifact/extension.lux +++ b/stdlib/source/test/aedifex/artifact/extension.lux @@ -23,8 +23,8 @@ (_.with-cover [/.Extension] ($_ _.and (_.cover [/.lux-library /.jvm-library /.pom - /.sha1 /.md5] - (let [options (list /.lux-library /.jvm-library /.pom /.sha1 /.md5) + /.sha-1 /.md5] + (let [options (list /.lux-library /.jvm-library /.pom /.sha-1 /.md5) uniques (set.from-list text.hash options)] (n.= (list.size options) (set.size uniques)))) diff --git a/stdlib/source/test/aedifex/artifact/type.lux b/stdlib/source/test/aedifex/artifact/type.lux index cbc6f681b..0d8284d7c 100644 --- a/stdlib/source/test/aedifex/artifact/type.lux +++ b/stdlib/source/test/aedifex/artifact/type.lux @@ -21,9 +21,9 @@ (_.with-cover [/.Type] ($_ _.and (_.cover [/.lux-library /.jvm-library - /.pom /.md5 /.sha1] + /.pom /.md5 /.sha-1] (let [options (list /.lux-library /.jvm-library - /.pom /.md5 /.sha1) + /.pom /.md5 /.sha-1) uniques (set.from-list text.hash options)] (n.= (list.size options) (set.size uniques)))) diff --git a/stdlib/source/test/aedifex/hash.lux b/stdlib/source/test/aedifex/hash.lux index 21e318be6..bc6bb1b4b 100644 --- a/stdlib/source/test/aedifex/hash.lux +++ b/stdlib/source/test/aedifex/hash.lux @@ -40,7 +40,7 @@ (`` ($_ _.and (_.with-cover [/.equivalence] ($_ _.and - ($equivalence.spec /.equivalence (..random /.sha1)) + ($equivalence.spec /.equivalence (..random /.sha-1)) ($equivalence.spec /.equivalence (..random /.md5)) )) (_.with-cover [/.data] @@ -64,14 +64,14 @@ (#try.Failure error) (exception.match? <exception> error)))))] - [/.sha1 /.as-sha1 /.not-a-sha1] + [/.sha-1 /.as-sha-1 /.not-a-sha-1] [/.md5 /.as-md5 /.not-a-md5] )))) (~~ (template [<codec> <hash>] [(_.with-cover [<codec>] ($codec.spec /.equivalence <codec> (..random <hash>)))] - [/.sha1-codec /.sha1] + [/.sha-1-codec /.sha-1] [/.md5-codec /.md5] )) (_.with-cover [/.not-a-hash] @@ -89,7 +89,7 @@ (#try.Failure error) (exception.match? /.not-a-hash error))))] - [/.sha1-codec /.sha1] + [/.sha-1-codec /.sha-1] [/.md5-codec /.md5] )))) )))) diff --git a/stdlib/source/test/aedifex/package.lux b/stdlib/source/test/aedifex/package.lux new file mode 100644 index 000000000..b85f6ce4a --- /dev/null +++ b/stdlib/source/test/aedifex/package.lux @@ -0,0 +1,64 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try] + [concurrency + [promise (#+ Promise)]]] + [data + ["." text] + [collection + ["." set (#+ Set)]] + [number + ["n" nat]]] + [math + ["." random (#+ Random)]] + [world + ["." file]]] + [// + ["@." profile] + [// + [lux + [data + ["_." binary]]]]] + {#program + ["." / + ["/#" // #_ + ["#" profile] + ["#." dependency (#+ Dependency)] + ["#." pom] + ["#." hash]]]}) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Package]) + (do {! random.monad} + [content-size (:: ! map (n.% 100) random.nat) + content (_binary.random content-size) + [profile pom] (random.one (function (_ profile) + (try.to-maybe + (do try.monad + [pom (//pom.write profile)] + (wrap [profile pom])))) + @profile.random)] + ($_ _.and + (_.cover [/.local] + (let [package (/.local pom content)] + (and (:: //hash.equivalence = + (//hash.sha-1 content) + (get@ #/.sha-1 package)) + (:: //hash.equivalence = + (//hash.md5 content) + (get@ #/.md5 package))))) + (_.cover [/.dependencies] + (let [expected (get@ #//.dependencies profile)] + (case (/.dependencies (/.local pom content)) + (#try.Success actual) + (:: set.equivalence = expected actual) + + (#try.Failure error) + false))) + )))) diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux index f63de1509..d31e6aef8 100644 --- a/stdlib/source/test/lux/control/concurrency/actor.lux +++ b/stdlib/source/test/lux/control/concurrency/actor.lux @@ -1,7 +1,8 @@ (.module: [lux #* ["_" test (#+ Test)] - [abstract/monad (#+ do)] + [abstract + [monad (#+ do)]] [control ["." try (#+ Try)] ["." exception (#+ exception:)] @@ -18,143 +19,144 @@ [// ["." promise (#+ Promise Resolver) ("#@." monad)]]]}) -(exception: get-wrecked) +(exception: got-wrecked) -(actor: Counter +(actor: counter Nat - ((handle [message state self]) + ((on-mail message state self) (message state self)) - ((stop [cause state]) - (promise@wrap []))) + ((on-stop cause state) + (promise@wrap [])) -(message: #export Counter - (count! {increment Nat} state self Nat) - (let [state' (n.+ increment state)] - (promise@wrap (#try.Success [state' state'])))) + (message: (count! {increment Nat} state self Nat) + (let [state' (n.+ increment state)] + (promise@wrap (#try.Success [state' state'])))) + ) + +(def: (mailed? outcome) + (-> (Try Any) Bit) + (case outcome + (#try.Success _) true + (#try.Failure _) false)) (def: #export test Test (do random.monad - [initial-state random.nat] + [initial-state random.nat + #let [inc! (: (/.Mail Nat) + (function (_ state actor) + (promise@wrap + (#try.Success + (inc state)))))]] (<| (_.covering /._) (_.with-cover [/.Actor]) ($_ _.and (_.cover [/.alive?] (io.run (do io.monad - [actor (/.spawn /.default-behavior 0)] + [actor (/.spawn! /.default 0)] (/.alive? actor)))) + + (_.cover [/.poison!] + (let [poisoned-actors-die! + (io.run (do io.monad + [actor (/.spawn! /.default 0) + poisoned? (/.poison! actor) + alive? (/.alive? actor)] + (wrap (and (..mailed? poisoned?) + (not alive?))))) + + cannot-poison-more-than-once! + (io.run (do io.monad + [actor (/.spawn! /.default 0) + first-time? (/.poison! actor) + second-time? (/.poison! actor)] + (wrap (and (..mailed? first-time?) + (not (..mailed? second-time?))))))] + (and poisoned-actors-die! + cannot-poison-more-than-once!))) - (_.cover [/.poison] - (and (io.run (do io.monad - [actor (/.spawn /.default-behavior 0) - poisoned? (/.poison actor) - alive? (/.alive? actor)] - (wrap (and poisoned? - (not alive?))))) - (io.run (do io.monad - [actor (/.spawn /.default-behavior 0) - first-time? (/.poison actor) - second-time? (/.poison actor)] - (wrap (and first-time? - (not second-time?))))))) - - (let [inc! (: (/.Message Nat) - (function (_ state actor) - (promise@wrap - (#try.Success - (inc state)))))] - (:: random.monad wrap - (do promise.monad + (let [[read write] (: [(Promise Text) (Resolver Text)] + (promise.promise []))] + (wrap (do promise.monad + [_ (promise.future (do io.monad + [actor (/.spawn! (: (/.Behavior Any Any) + {#/.on-init (|>>) + #/.on-mail (function (_ message state self) + (message state self)) + #/.on-stop (function (_ cause state) + (promise.future (write cause)))}) + [])] + (/.poison! actor))) + _ (promise.wait 100) + result (promise.future (promise.poll read))] + (_.claim [/.poisoned] + (case result + (#.Some error) + (exception.match? /.poisoned error) + + #.None + false))))) + + (wrap (do promise.monad + [sent? (promise.future (do io.monad + [actor (/.spawn! /.default 0) + sent? (/.mail! inc! actor)] + (wrap (..mailed? sent?))))] + (_.claim [/.Behavior /.Mail + /.default /.spawn! /.mail!] + sent?))) + + (wrap (do promise.monad [result (promise.future (do io.monad - [actor (/.spawn /.default-behavior 0) - sent? (/.send inc! actor)] - (wrap (#try.Success sent?))))] - (_.claim [/.Behavior /.Message - /.default-behavior /.spawn /.send] + [counter (/.spawn! /.default 0) + _ (/.poison! counter)] + (/.mail! inc! counter)))] + (_.claim [/.dead] (case result (#try.Success outcome) - outcome + false (#try.Failure error) - false))))) + (exception.match? /.dead error))))) - (let [[read write] (: [(Promise Text) (Resolver Text)] - (promise.promise []))] - (:: random.monad wrap - (do promise.monad - [_ (promise.future (do io.monad - [actor (/.spawn {#/.handle (function (_ message state self) - (message state self)) - #/.end (function (_ cause state) - (promise.future (write cause)))} - write)] - (/.poison actor))) - _ (promise.wait 100) - result (promise.future (promise.poll read))] - (_.claim [/.poisoned] - (case result - (#.Some error) - (exception.match? /.poisoned error) - - #.None - false))))) - - (:: random.monad wrap - (do promise.monad - [result (do (try.with promise.monad) - [#let [counter (io.run (new@Counter 0))] - output-1 (count! 1 counter) - output-2 (count! 1 counter) - output-3 (count! 1 counter)] - (wrap (and (n.= 1 output-1) - (n.= 2 output-2) - (n.= 3 output-3))))] - (_.claim [/.actor: /.message:] - (case result - (#try.Success outcome) - outcome - - (#try.Failure error) - false)))) - - (:: random.monad wrap - (do promise.monad - [result (do (try.with promise.monad) - [counter (promise.future (do io.monad - [counter (new@Counter 0) - _ (/.poison counter)] - (wrap (#try.Success counter))))] - (count! 1 counter))] - (_.claim [/.dead] - (case result - (#try.Success outcome) - false - - (#try.Failure error) - (exception.match? /.dead error))))) - - (let [die! (: (/.Message Nat) + (let [die! (: (/.Mail Nat) (function (_ state actor) - (promise@wrap (exception.throw ..get-wrecked []))))] - (:: random.monad wrap - (do promise.monad - [result (promise.future (do io.monad - [actor (/.spawn /.default-behavior initial-state) - sent? (/.send die! actor) - alive? (/.alive? actor) - obituary (/.obituary actor)] - (wrap (#try.Success [actor sent? alive? obituary]))))] - (_.claim [/.Obituary /.obituary] + (promise@wrap (exception.throw ..got-wrecked []))))] + (wrap (do promise.monad + [result (promise.future (do io.monad + [actor (/.spawn! /.default initial-state) + sent? (/.mail! die! actor) + alive? (/.alive? actor) + obituary (/.obituary actor)] + (wrap (#try.Success [actor sent? alive? obituary]))))] + (_.claim [/.Obituary /.obituary] + (case result + (^ (#try.Success [actor sent? alive? (#.Some [error state (list single-pending-message)])])) + (and (..mailed? sent?) + (not alive?) + (exception.match? ..got-wrecked error) + (n.= initial-state state) + (is? die! single-pending-message)) + + _ + false))))) + + (wrap (do promise.monad + [counter (promise.future (/.spawn! ..counter 0)) + result (do (try.with promise.monad) + [output-1 (/.tell! (count! 1) counter) + output-2 (/.tell! (count! 1) counter) + output-3 (/.tell! (count! 1) counter)] + (wrap (and (n.= 1 output-1) + (n.= 2 output-2) + (n.= 3 output-3))))] + (_.claim [/.actor: /.message: /.tell!] (case result - (^ (#try.Success [actor sent? alive? (#.Some [error state (list single-pending-message)])])) - (and sent? - (not alive?) - (exception.match? ..get-wrecked error) - (n.= initial-state state) - (is? die! single-pending-message)) - - _ - false))))) + (#try.Success outcome) + outcome + + (#try.Failure error) + false)))) )))) diff --git a/stdlib/source/test/lux/control/parser/binary.lux b/stdlib/source/test/lux/control/parser/binary.lux index 98b8bab90..b02a94f0f 100644 --- a/stdlib/source/test/lux/control/parser/binary.lux +++ b/stdlib/source/test/lux/control/parser/binary.lux @@ -89,8 +89,8 @@ (Random Code) (random.rec (function (_ recur) - (let [random-sequence (do {@ random.monad} - [size (:: @ map (n.% 2) random.nat)] + (let [random-sequence (do {! random.monad} + [size (:: ! map (n.% 2) random.nat)] (random.list size recur))] ($_ random.and ..random-location @@ -106,8 +106,8 @@ ..random-name random-sequence random-sequence - (do {@ random.monad} - [size (:: @ map (n.% 2) random.nat)] + (do {! random.monad} + [size (:: ! map (n.% 2) random.nat)] (random.list size (random.and recur recur))) ))))))) @@ -125,8 +125,8 @@ (<| (_.with-cover [/.Size]) (`` ($_ _.and (~~ (template [<size> <parser> <format>] - [(do {@ random.monad} - [expected (:: @ map (i64.and (i64.mask <size>)) + [(do {! random.monad} + [expected (:: ! map (i64.and (i64.mask <size>)) random.nat)] (_.cover [<size> <parser>] (|> (format.run <format> expected) @@ -145,8 +145,8 @@ Test (`` ($_ _.and (~~ (template [<parser> <format>] - [(do {@ random.monad} - [expected (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + [(do {! random.monad} + [expected (:: ! map encoding.to-utf8 (random.ascii ..segment-size))] (_.cover [<parser>] (|> (format.run <format> expected) (/.run <parser>) @@ -163,7 +163,7 @@ Test (`` ($_ _.and (~~ (template [<parser> <format>] - [(do {@ random.monad} + [(do {! random.monad} [expected (random.ascii ..segment-size)] (_.cover [<parser>] (|> (format.run <format> expected) @@ -182,7 +182,7 @@ Test (`` ($_ _.and (~~ (template [<parser> <format>] - [(do {@ random.monad} + [(do {! random.monad} [expected (random.row ..segment-size random.nat)] (_.cover [<parser>] (|> expected @@ -201,7 +201,7 @@ Test (`` ($_ _.and (~~ (template [<parser> <format> <random> <equivalence>] - [(do {@ random.monad} + [(do {! random.monad} [expected <random>] (_.cover [<parser>] (|> expected @@ -214,7 +214,7 @@ [/.nat format.nat random.nat n.equivalence] [/.int format.int random.int int.equivalence] [/.rev format.rev random.rev rev.equivalence])) - (do {@ random.monad} + (do {! random.monad} [expected random.frac] (_.cover [/.frac] (|> expected @@ -224,8 +224,8 @@ (or (:: frac.equivalence = expected actual) (and (frac.not-a-number? expected) (frac.not-a-number? actual)))))))) - (do {@ random.monad} - [expected (:: @ map (|>> (i64.and (i64.mask /.size/8)) + (do {! random.monad} + [expected (:: ! map (|>> (i64.and (i64.mask /.size/8)) (n.max 2)) random.nat)] (_.cover [/.not-a-bit] @@ -240,7 +240,7 @@ Test (`` ($_ _.and (~~ (template [<parser> <format> <random> <equivalence>] - [(do {@ random.monad} + [(do {! random.monad} [expected <random>] (_.cover [<parser>] (|> expected @@ -254,7 +254,7 @@ [/.type format.type random-type type.equivalence] )) (~~ (template [<cover> <parser> <format> <random> <equivalence>] - [(do {@ random.monad} + [(do {! random.monad} [expected <random>] (_.cover [<cover>] (|> expected @@ -267,15 +267,15 @@ [/.list (/.list /.nat) (format.list format.nat) (random.list ..segment-size random.nat) (list.equivalence n.equivalence)] [/.set (/.set n.hash /.nat) (format.set format.nat) (random.set n.hash ..segment-size random.nat) set.equivalence] [/.name /.name format.name ..random-name name.equivalence])) - (do {@ random.monad} - [expected (:: @ map (list.repeat ..segment-size) random.nat)] + (do {! random.monad} + [expected (:: ! map (list.repeat ..segment-size) random.nat)] (_.cover [/.set-elements-are-not-unique] (|> expected (format.run (format.list format.nat)) (/.run (/.set n.hash /.nat)) (!expect (^multi (#try.Failure error) (exception.match? /.set-elements-are-not-unique error)))))) - (do {@ random.monad} + (do {! random.monad} [expected (random.or random.bit random.nat)] (_.cover [/.or] (|> expected @@ -286,8 +286,8 @@ (:: (sum.equivalence bit.equivalence n.equivalence) = expected actual)))))) - (do {@ random.monad} - [tag (:: @ map (|>> (i64.and (i64.mask /.size/8)) + (do {! random.monad} + [tag (:: ! map (|>> (i64.and (i64.mask /.size/8)) (n.max 2)) random.nat) value random.bit] @@ -298,7 +298,7 @@ (/.or /.bit /.nat))) (!expect (^multi (#try.Failure error) (exception.match? /.invalid-tag error)))))) - (do {@ random.monad} + (do {! random.monad} [expected (random.list ..segment-size random.nat)] (_.cover [/.rec] (|> expected @@ -324,22 +324,22 @@ (|> (binary.create 0) (/.run /.any) (!expect (#try.Success _)))) - (do {@ random.monad} - [data (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (do {! random.monad} + [data (:: ! map encoding.to-utf8 (random.ascii ..segment-size))] (_.cover [/.binary-was-not-fully-read] (|> data (/.run /.any) (!expect (^multi (#try.Failure error) (exception.match? /.binary-was-not-fully-read error)))))) - (do {@ random.monad} - [expected (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (do {! random.monad} + [expected (:: ! map encoding.to-utf8 (random.ascii ..segment-size))] (_.cover [/.segment] (|> expected (/.run (/.segment ..segment-size)) (!expect (^multi (#try.Success actual) (:: binary.equivalence = expected actual)))))) - (do {@ random.monad} - [data (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (do {! random.monad} + [data (:: ! map encoding.to-utf8 (random.ascii ..segment-size))] (_.cover [/.end?] (|> data (/.run (do <>.monad @@ -349,9 +349,9 @@ (wrap (and (not pre) post)))) (!expect (#try.Success #1))))) - (do {@ random.monad} - [to-read (:: @ map (n.% (inc ..segment-size)) random.nat) - data (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (do {! random.monad} + [to-read (:: ! map (n.% (inc ..segment-size)) random.nat) + data (:: ! map encoding.to-utf8 (random.ascii ..segment-size))] (_.cover [/.Offset /.offset] (|> data (/.run (do <>.monad @@ -364,9 +364,9 @@ (n.= to-read offset) (n.= ..segment-size nothing-left))))) (!expect (#try.Success #1))))) - (do {@ random.monad} - [to-read (:: @ map (n.% (inc ..segment-size)) random.nat) - data (:: @ map encoding.to-utf8 (random.ascii ..segment-size))] + (do {! random.monad} + [to-read (:: ! map (n.% (inc ..segment-size)) random.nat) + data (:: ! map encoding.to-utf8 (random.ascii ..segment-size))] (_.cover [/.remaining] (|> data (/.run (do <>.monad diff --git a/stdlib/source/test/lux/control/parser/cli.lux b/stdlib/source/test/lux/control/parser/cli.lux index 2c781e4fc..7d90eb49d 100644 --- a/stdlib/source/test/lux/control/parser/cli.lux +++ b/stdlib/source/test/lux/control/parser/cli.lux @@ -29,8 +29,8 @@ Test (<| (_.covering /._) (_.with-cover [/.Parser]) - (do {@ random.monad} - [expected (:: @ map n@encode random.nat) + (do {! random.monad} + [expected (:: ! map n@encode random.nat) #let [random-dummy (random.filter (|>> (text@= expected) not) (random.unicode 5))] dummy random-dummy diff --git a/stdlib/source/test/lux/control/parser/json.lux b/stdlib/source/test/lux/control/parser/json.lux index 8ed632ac5..4b3bfeb7d 100644 --- a/stdlib/source/test/lux/control/parser/json.lux +++ b/stdlib/source/test/lux/control/parser/json.lux @@ -44,8 +44,8 @@ (<| (_.covering /._) (_.with-cover [/.Parser]) (`` ($_ _.and - (do {@ random.monad} - [expected (:: @ map (|>> #json.String) (random.unicode 1))] + (do {! random.monad} + [expected (:: ! map (|>> #json.String) (random.unicode 1))] (_.cover [/.run /.any] (|> (/.run /.any expected) (!expect (^multi (#try.Success actual) @@ -54,7 +54,7 @@ (|> (/.run /.null #json.Null) (!expect (#try.Success _)))) (~~ (template [<query> <test> <check> <random> <json> <equivalence>] - [(do {@ random.monad} + [(do {! random.monad} [expected <random> dummy (|> <random> (random.filter (|>> (:: <equivalence> = expected) not)))] ($_ _.and @@ -77,21 +77,21 @@ [/.number /.number? /.number! ..safe-frac #json.Number frac.equivalence] [/.string /.string? /.string! (random.unicode 1) #json.String text.equivalence] )) - (do {@ random.monad} + (do {! random.monad} [expected (random.unicode 1) dummy random.bit] (_.cover [/.unexpected-value] (|> (/.run /.string (#json.Boolean dummy)) (!expect (^multi (#try.Failure error) (exception.match? /.unexpected-value error)))))) - (do {@ random.monad} + (do {! random.monad} [expected (random.unicode 1) dummy (|> (random.unicode 1) (random.filter (|>> (:: text.equivalence = expected) not)))] (_.cover [/.value-mismatch] (|> (/.run (/.string! expected) (#json.String dummy)) (!expect (^multi (#try.Failure error) (exception.match? /.value-mismatch error)))))) - (do {@ random.monad} + (do {! random.monad} [expected (random.unicode 1)] (_.cover [/.nullable] (and (|> (/.run (/.nullable /.string) #json.Null) @@ -100,18 +100,18 @@ (|> (/.run (/.nullable /.string) (#json.String expected)) (!expect (^multi (#try.Success actual) (:: (maybe.equivalence text.equivalence) = (#.Some expected) actual))))))) - (do {@ random.monad} - [size (:: @ map (n.% 10) random.nat) + (do {! random.monad} + [size (:: ! map (n.% 10) random.nat) expected (|> (random.unicode 1) (random.list size) - (:: @ map row.from-list))] + (:: ! map row.from-list))] (_.cover [/.array] (|> (/.run (/.array (<>.some /.string)) (#json.Array (row@map (|>> #json.String) expected))) (!expect (^multi (#try.Success actual) (:: (row.equivalence text.equivalence) = expected (row.from-list actual))))))) - (do {@ random.monad} - [expected (:: @ map (|>> #json.String) (random.unicode 1))] + (do {! random.monad} + [expected (:: ! map (|>> #json.String) (random.unicode 1))] (_.cover [/.unconsumed-input] (|> (/.run (/.array /.any) (#json.Array (row expected expected))) (!expect (^multi (#try.Failure error) @@ -120,12 +120,12 @@ (|> (/.run (/.array /.any) (#json.Array (row))) (!expect (^multi (#try.Failure error) (exception.match? /.empty-input error))))) - (do {@ random.monad} + (do {! random.monad} [expected-boolean random.bit expected-number ..safe-frac expected-string (random.unicode 1) [boolean-field number-field string-field] (|> (random.set text.hash 3 (random.unicode 3)) - (:: @ map (|>> set.to-list + (:: ! map (|>> set.to-list (case> (^ (list boolean-field number-field string-field)) [boolean-field number-field string-field] @@ -145,8 +145,8 @@ (and (:: bit.equivalence = expected-boolean actual-boolean) (:: frac.equivalence = expected-number actual-number) (:: text.equivalence = expected-string actual-string))))))) - (do {@ random.monad} - [size (:: @ map (n.% 10) random.nat) + (do {! random.monad} + [size (:: ! map (n.% 10) random.nat) keys (random.list size (random.unicode 1)) values (random.list size (random.unicode 1)) #let [expected (dictionary.from-list text.hash (list.zip/2 keys values))]] diff --git a/stdlib/source/test/lux/control/parser/text.lux b/stdlib/source/test/lux/control/parser/text.lux index 4b207b257..206b93b12 100644 --- a/stdlib/source/test/lux/control/parser/text.lux +++ b/stdlib/source/test/lux/control/parser/text.lux @@ -68,50 +68,50 @@ (def: character-classes Test ($_ _.and - (do {@ random.monad} - [offset (:: @ map (n.% 50) random.nat) - range (:: @ map (|>> (n.% 50) (n.+ 10)) random.nat) + (do {! random.monad} + [offset (:: ! map (n.% 50) random.nat) + range (:: ! map (|>> (n.% 50) (n.+ 10)) random.nat) #let [limit (n.+ offset range)] - expected (:: @ map (|>> (n.% range) (n.+ offset) text.from-code) random.nat) + expected (:: ! map (|>> (n.% range) (n.+ offset) text.from-code) random.nat) out-of-range (case offset - 0 (:: @ map (|>> (n.% 10) inc (n.+ limit) text.from-code) random.nat) - _ (:: @ map (|>> (n.% offset) text.from-code) random.nat))] + 0 (:: ! map (|>> (n.% 10) inc (n.+ limit) text.from-code) random.nat) + _ (:: ! map (|>> (n.% offset) text.from-code) random.nat))] (_.cover [/.range] (and (..should-pass expected (/.range offset limit)) (..should-fail out-of-range (/.range offset limit))))) - (do {@ random.monad} + (do {! random.monad} [expected (random.char unicode.ascii/upper-alpha) invalid (random.filter (|>> (unicode.within? unicode.basic-latin/upper-alpha) not) (random.char unicode.full))] (_.cover [/.upper] (and (..should-pass (text.from-code expected) /.upper) (..should-fail (text.from-code invalid) /.upper)))) - (do {@ random.monad} + (do {! random.monad} [expected (random.char unicode.ascii/lower-alpha) invalid (random.filter (|>> (unicode.within? unicode.basic-latin/lower-alpha) not) (random.char unicode.full))] (_.cover [/.lower] (and (..should-pass (text.from-code expected) /.lower) (..should-fail (text.from-code invalid) /.lower)))) - (do {@ random.monad} - [expected (:: @ map (n.% 10) random.nat) + (do {! random.monad} + [expected (:: ! map (n.% 10) random.nat) invalid (random.char (unicode.set [unicode.number-forms (list)]))] (_.cover [/.decimal] (and (..should-pass (:: n.decimal encode expected) /.decimal) (..should-fail (text.from-code invalid) /.decimal)))) - (do {@ random.monad} - [expected (:: @ map (n.% 8) random.nat) + (do {! random.monad} + [expected (:: ! map (n.% 8) random.nat) invalid (random.char (unicode.set [unicode.number-forms (list)]))] (_.cover [/.octal] (and (..should-pass (:: n.octal encode expected) /.octal) (..should-fail (text.from-code invalid) /.octal)))) - (do {@ random.monad} - [expected (:: @ map (n.% 16) random.nat) + (do {! random.monad} + [expected (:: ! map (n.% 16) random.nat) invalid (random.char (unicode.set [unicode.number-forms (list)]))] (_.cover [/.hexadecimal] (and (..should-pass (:: n.hex encode expected) /.hexadecimal) (..should-fail (text.from-code invalid) /.hexadecimal)))) - (do {@ random.monad} + (do {! random.monad} [expected (random.char unicode.ascii/alpha) invalid (random.filter (function (_ char) (not (or (unicode.within? unicode.basic-latin/upper-alpha char) @@ -120,7 +120,7 @@ (_.cover [/.alpha] (and (..should-pass (text.from-code expected) /.alpha) (..should-fail (text.from-code invalid) /.alpha)))) - (do {@ random.monad} + (do {! random.monad} [expected (random.char unicode.ascii/alpha-num) invalid (random.filter (function (_ char) (not (or (unicode.within? unicode.basic-latin/upper-alpha char) @@ -130,7 +130,7 @@ (_.cover [/.alpha-num] (and (..should-pass (text.from-code expected) /.alpha-num) (..should-fail (text.from-code invalid) /.alpha-num)))) - (do {@ random.monad} + (do {! random.monad} [expected ($_ random.either (wrap text.tab) (wrap text.vertical-tab) @@ -148,14 +148,14 @@ (_.cover [/.space] (and (..should-pass expected /.space) (..should-fail invalid /.space)))) - (do {@ random.monad} + (do {! random.monad} [#let [num-options 3] options (|> (random.char unicode.full) (random.set n.hash num-options) - (:: @ map (|>> set.to-list + (:: ! map (|>> set.to-list (list@map text.from-code) (text.join-with "")))) - expected (:: @ map (function (_ value) + expected (:: ! map (function (_ value) (|> options (text.nth (n.% num-options value)) maybe.assume)) @@ -174,14 +174,14 @@ (..should-fail (text.from-code invalid) (/.one-of! options)) (..should-fail' (text.from-code invalid) (/.one-of! options) /.character-should-be)))) - (do {@ random.monad} + (do {! random.monad} [#let [num-options 3] options (|> (random.char unicode.full) (random.set n.hash num-options) - (:: @ map (|>> set.to-list + (:: ! map (|>> set.to-list (list@map text.from-code) (text.join-with "")))) - invalid (:: @ map (function (_ value) + invalid (:: ! map (function (_ value) (|> options (text.nth (n.% num-options value)) maybe.assume)) @@ -206,27 +206,27 @@ Test (let [octal! (/.one-of! "01234567")] ($_ _.and - (do {@ random.monad} - [left (:: @ map (|>> (n.% 8) (:: n.octal encode)) random.nat) - right (:: @ map (|>> (n.% 8) (:: n.octal encode)) random.nat) + (do {! random.monad} + [left (:: ! map (|>> (n.% 8) (:: n.octal encode)) random.nat) + right (:: ! map (|>> (n.% 8) (:: n.octal encode)) random.nat) #let [expected (format left right)] invalid (|> random.nat - (:: @ map (n.% 16)) + (:: ! map (n.% 16)) (random.filter (n.>= 8)) - (:: @ map (:: n.hex encode)))] + (:: ! map (:: n.hex encode)))] (_.cover [/.many /.many!] (and (..should-pass expected (/.many /.octal)) (..should-fail invalid (/.many /.octal)) (..should-pass! expected (/.many! octal!))))) - (do {@ random.monad} - [left (:: @ map (|>> (n.% 8) (:: n.octal encode)) random.nat) - right (:: @ map (|>> (n.% 8) (:: n.octal encode)) random.nat) + (do {! random.monad} + [left (:: ! map (|>> (n.% 8) (:: n.octal encode)) random.nat) + right (:: ! map (|>> (n.% 8) (:: n.octal encode)) random.nat) #let [expected (format left right)] invalid (|> random.nat - (:: @ map (n.% 16)) + (:: ! map (n.% 16)) (random.filter (n.>= 8)) - (:: @ map (:: n.hex encode)))] + (:: ! map (:: n.hex encode)))] (_.cover [/.some /.some!] (and (..should-pass expected (/.some /.octal)) (..should-pass "" (/.some /.octal)) @@ -234,8 +234,8 @@ (..should-pass! expected (/.some! octal!)) (..should-pass! "" (/.some! octal!))))) - (do {@ random.monad} - [#let [octal (:: @ map (|>> (n.% 8) (:: n.octal encode)) random.nat)] + (do {! random.monad} + [#let [octal (:: ! map (|>> (n.% 8) (:: n.octal encode)) random.nat)] first octal second octal third octal] @@ -247,8 +247,8 @@ (..should-pass! (format first second) (/.exactly! 2 octal!)) (..should-fail (format first second third) (/.exactly! 2 octal!)) (..should-fail (format first) (/.exactly! 2 octal!))))) - (do {@ random.monad} - [#let [octal (:: @ map (|>> (n.% 8) (:: n.octal encode)) random.nat)] + (do {! random.monad} + [#let [octal (:: ! map (|>> (n.% 8) (:: n.octal encode)) random.nat)] first octal second octal third octal] @@ -260,8 +260,8 @@ (..should-pass! (format first second) (/.at-most! 2 octal!)) (..should-pass! (format first) (/.at-most! 2 octal!)) (..should-fail (format first second third) (/.at-most! 2 octal!))))) - (do {@ random.monad} - [#let [octal (:: @ map (|>> (n.% 8) (:: n.octal encode)) random.nat)] + (do {! random.monad} + [#let [octal (:: ! map (|>> (n.% 8) (:: n.octal encode)) random.nat)] first octal second octal third octal] @@ -273,8 +273,8 @@ (..should-pass! (format first second) (/.at-least! 2 octal!)) (..should-pass! (format first second third) (/.at-least! 2 octal!)) (..should-fail (format first) (/.at-least! 2 octal!))))) - (do {@ random.monad} - [#let [octal (:: @ map (|>> (n.% 8) (:: n.octal encode)) random.nat)] + (do {! random.monad} + [#let [octal (:: ! map (|>> (n.% 8) (:: n.octal encode)) random.nat)] first octal second octal third octal] @@ -293,7 +293,7 @@ (<| (_.covering /._) (_.with-cover [/.Parser]) ($_ _.and - (do {@ random.monad} + (do {! random.monad} [sample (random.unicode 1)] (_.cover [/.run /.end!] (and (|> (/.run /.end! @@ -302,7 +302,7 @@ (|> (/.run /.end! sample) (!expect (#try.Failure _)))))) - (do {@ random.monad} + (do {! random.monad} [#let [size 10] expected (random.unicode size) dummy (|> (random.unicode size) @@ -320,7 +320,7 @@ (/.run (/.slice /.any!)) (!expect (^multi (#try.Failure error) (exception.match? /.cannot-slice error))))) - (do {@ random.monad} + (do {! random.monad} [expected (random.unicode 1)] (_.cover [/.any /.any!] (and (..should-pass expected /.any) @@ -328,7 +328,7 @@ (..should-pass! expected /.any!) (..should-fail "" /.any!)))) - (do {@ random.monad} + (do {! random.monad} [expected (random.unicode 1)] (_.cover [/.peek /.cannot-parse] (and (..should-pass expected (<>.before /.any /.peek)) @@ -336,14 +336,14 @@ (/.run (<>.before /.any /.peek)) (!expect (^multi (#try.Failure error) (exception.match? /.cannot-parse error))))))) - (do {@ random.monad} + (do {! random.monad} [dummy (random.unicode 1)] (_.cover [/.unconsumed-input] (|> (format dummy dummy) (/.run /.any) (!expect (^multi (#try.Failure error) (exception.match? /.unconsumed-input error)))))) - (do {@ random.monad} + (do {! random.monad} [sample (random.unicode 1)] (_.cover [/.Offset /.offset] (|> sample @@ -353,7 +353,7 @@ post /.offset] (wrap [pre post]))) (!expect (#try.Success [0 1]))))) - (do {@ random.monad} + (do {! random.monad} [left (random.unicode 1) right (random.unicode 1) #let [input (format left right)]] @@ -367,7 +367,7 @@ (wrap (and (text@= input pre) (text@= right post))))) (!expect (#try.Success #1))))) - (do {@ random.monad} + (do {! random.monad} [left (random.unicode 1) right (random.unicode 1) expected (random.filter (|>> (text@= right) not) @@ -376,7 +376,7 @@ (|> (format left expected right) (/.run (/.enclosed [left right] (/.this expected))) (!expect (#try.Success _))))) - (do {@ random.monad} + (do {! random.monad} [in (random.unicode 1) out (random.unicode 1)] (_.cover [/.local] @@ -385,14 +385,14 @@ [_ (/.local in (/.this in))] (/.this out))) (!expect (#try.Success _))))) - (do {@ random.monad} - [expected (:: @ map (|>> (n.% 8) (:: n.octal encode)) random.nat)] + (do {! random.monad} + [expected (:: ! map (|>> (n.% 8) (:: n.octal encode)) random.nat)] (_.cover [/.embed] (|> (list (code.text expected)) (<c>.run (/.embed /.octal <c>.text)) (!expect (^multi (#try.Success actual) (text@= expected actual)))))) - (do {@ random.monad} + (do {! random.monad} [invalid (random.ascii/upper-alpha 1) expected (random.filter (|>> (unicode.within? unicode.basic-latin/upper-alpha) not) @@ -410,7 +410,7 @@ (/.run (/.not! upper!)) (!expect (^multi (#try.Failure error) (exception.match? /.expected-to-fail error))))))) - (do {@ random.monad} + (do {! random.monad} [upper (random.ascii/upper-alpha 1) lower (random.ascii/lower-alpha 1) invalid (random.filter (function (_ char) @@ -427,7 +427,7 @@ (..should-pass! (format upper lower) (/.and! upper! lower!)) (..should-fail (format (text.from-code invalid) lower) (/.and! upper! lower!)) (..should-fail (format upper (text.from-code invalid)) (/.and! upper! lower!))))) - (do {@ random.monad} + (do {! random.monad} [expected (random.unicode 1) invalid (random.unicode 1)] (_.cover [/.satisfies /.character-does-not-satisfy-predicate] diff --git a/stdlib/source/test/lux/control/parser/type.lux b/stdlib/source/test/lux/control/parser/type.lux index 99e995f2d..10925cb12 100644 --- a/stdlib/source/test/lux/control/parser/type.lux +++ b/stdlib/source/test/lux/control/parser/type.lux @@ -34,7 +34,7 @@ (def: matches Test (<| (_.with-cover [/.types-do-not-match]) - (do {@ random.monad} + (do {! random.monad} [expected ..primitive dummy (random.filter (|>> (type@= expected) not) ..primitive)]) @@ -69,7 +69,7 @@ (def: aggregate Test - (do {@ random.monad} + (do {! random.monad} [expected-left ..primitive expected-middle ..primitive expected-right ..primitive] @@ -120,13 +120,13 @@ (<| (_.covering /._) (_.with-cover [/.Parser]) ($_ _.and - (do {@ random.monad} + (do {! random.monad} [expected ..primitive] (_.cover [/.run /.any] (|> (/.run /.any expected) (!expect (^multi (#try.Success actual) (type@= expected actual)))))) - (do {@ random.monad} + (do {! random.monad} [expected ..primitive] (_.cover [/.peek /.unconsumed-input] (and (|> (/.run (do //.monad @@ -139,7 +139,7 @@ (|> (/.run /.peek expected) (!expect (^multi (#try.Failure error) (exception.match? /.unconsumed-input error))))))) - (do {@ random.monad} + (do {! random.monad} [expected ..primitive] (_.cover [/.empty-input] (`` (and (~~ (template [<parser>] @@ -153,7 +153,7 @@ [/.any] [/.peek] )))))) - (do {@ random.monad} + (do {! random.monad} [expected ..primitive] (_.cover [/.Env /.env /.fresh] (|> (/.run (do //.monad @@ -163,7 +163,7 @@ expected) (!expect (^multi (#try.Success environment) (is? /.fresh environment)))))) - (do {@ random.monad} + (do {! random.monad} [expected ..primitive dummy (random.filter (|>> (type@= expected) not) ..primitive)] @@ -175,14 +175,14 @@ dummy) (!expect (^multi (#try.Success actual) (type@= expected actual)))))) - (do {@ random.monad} + (do {! random.monad} [expected random.nat] (_.cover [/.existential /.not-existential] (|> (/.run /.existential (#.Ex expected)) (!expect (^multi (#try.Success actual) (n.= expected actual)))))) - (do {@ random.monad} + (do {! random.monad} [expected-name (random.and (random.ascii/alpha-num 1) (random.ascii/alpha-num 1)) expected-type ..primitive] diff --git a/stdlib/source/test/lux/control/parser/xml.lux b/stdlib/source/test/lux/control/parser/xml.lux index b46994c97..db7a51d39 100644 --- a/stdlib/source/test/lux/control/parser/xml.lux +++ b/stdlib/source/test/lux/control/parser/xml.lux @@ -34,7 +34,7 @@ (template: (!failure <exception> <cases>) (with-expansions [<<cases>> (template.splice <cases>)] - (do {@ random.monad} + (do {! random.monad} [expected (random.ascii/alpha 1)] (_.cover [<exception>] (`` (and (~~ (template [<parser> <input>] @@ -57,7 +57,7 @@ (<| (_.covering /._) (_.with-cover [/.Parser]) ($_ _.and - (do {@ random.monad} + (do {! random.monad} [expected (random.ascii/alpha 1)] (_.cover [/.run /.text] (|> (/.run /.text (#xml.Text expected)) @@ -66,12 +66,12 @@ (!failure /.unconsumed-inputs [[(//@wrap expected) (#xml.Text expected)]]) - (do {@ random.monad} + (do {! random.monad} [expected (random.ascii/alpha 1)] (_.cover [/.ignore] (|> (/.run /.ignore (#xml.Text expected)) (!expect (#try.Success []))))) - (do {@ random.monad} + (do {! random.monad} [expected ..random-tag] (_.cover [/.node] (|> (/.run (do //.monad @@ -82,7 +82,7 @@ (!failure /.wrong-tag [[(/.node ["" expected]) (#xml.Node [expected ""] (dictionary.new name.hash) (list))]]) - (do {@ random.monad} + (do {! random.monad} [expected-tag ..random-tag expected-attribute ..random-attribute expected-value (random.ascii/alpha 1)] @@ -104,13 +104,13 @@ (|> (dictionary.new name.hash) (dictionary.put [expected ""] expected)) (list))]]) - (do {@ random.monad} + (do {! random.monad} [expected ..random-tag] (_.cover [/.children] - (|> (/.run (do {@ //.monad} + (|> (/.run (do {! //.monad} [_ (/.node expected)] (/.children - (do @ + (do ! [_ (/.node expected)] /.ignore))) (#xml.Node expected @@ -161,10 +161,10 @@ [_ (/.attribute [expected expected])] /.ignore) (#xml.Text expected)] - [(do {@ //.monad} + [(do {! //.monad} [_ (/.node [expected expected])] (/.children - (do @ + (do ! [_ (/.node [expected expected])] /.ignore))) (#xml.Text expected)]]) diff --git a/stdlib/source/test/lux/data.lux b/stdlib/source/test/lux/data.lux index 287a93526..6ae68a061 100644 --- a/stdlib/source/test/lux/data.lux +++ b/stdlib/source/test/lux/data.lux @@ -42,28 +42,6 @@ [_ (wrap [])] body))) -(def: number - Test - ## TODO: Inline ASAP - (let [part0 ($_ _.and - /i8.test - /i16.test - /i32.test - /i64.test) - part1 ($_ _.and - /nat.test - /int.test - /rev.test) - part2 ($_ _.and - /frac.test - /ratio.test - /complex.test)] - ($_ _.and - (!bundle part0) - (!bundle part1) - (!bundle part2) - ))) - (def: text ($_ _.and /text.test @@ -93,10 +71,10 @@ /product.test) test2 ($_ _.and /sum.test - ..number ..text ..format - /collection.test)] + /collection.test + )] ($_ _.and (!bundle test0) (!bundle test1) diff --git a/stdlib/source/test/lux/data/collection/list.lux b/stdlib/source/test/lux/data/collection/list.lux index a81de6c24..2190c2fe2 100644 --- a/stdlib/source/test/lux/data/collection/list.lux +++ b/stdlib/source/test/lux/data/collection/list.lux @@ -177,7 +177,8 @@ (let [(^open "/@.") (/.equivalence n.equivalence) (^open "/@.") /.monoid] (do {! random.monad} - [sample ..random + [sample (random.filter (|>> /.size (n.> 0)) + ..random) #let [size (/.size sample)] idx (:: ! map (n.% size) random.nat) chunk-size (:: ! map (|>> (n.% size) inc) random.nat)] diff --git a/stdlib/source/test/lux/data/collection/tree.lux b/stdlib/source/test/lux/data/collection/tree.lux index 8ba66ef02..ccd4a1d70 100644 --- a/stdlib/source/test/lux/data/collection/tree.lux +++ b/stdlib/source/test/lux/data/collection/tree.lux @@ -1,63 +1,91 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract - [monad (#+ do)] + ["." monad (#+ do)] {[0 #spec] [/ ["$." equivalence] ["$." fold] ["$." functor]]}] [data + ["." product] [number ["n" nat]] [collection ["." list ("#@." functor fold)]]] [math - ["r" random (#+ Random)]]] + ["." random (#+ Random)]]] {1 ["." / (#+ Tree)]}) -(def: #export (tree size gen-value) - (All [a] (-> Nat (Random a) (Random (Tree a)))) - (let [singleton (:: r.monad map /.leaf gen-value)] - (case size - 0 - singleton - - 1 - singleton - - 2 - (do r.monad - [value gen-value - single (tree 1 gen-value)] - (wrap (/.branch value (list single)))) - - _ - (do r.monad - [value gen-value - #let [size (dec size)] - left (tree (n./ 2 size) gen-value) - right (tree (n.+ (n.% 2 size) (n./ 2 size)) - gen-value)] - (wrap (/.branch value (list left right)))) - ))) +(def: #export (tree gen-value) + (All [a] (-> (Random a) (Random [Nat (Tree a)]))) + (do {! random.monad} + [value gen-value + num-children (:: ! map (n.% 2) random.nat) + children (random.list num-children (tree gen-value))] + (wrap [(|> children + (list@map product.left) + (list@fold n.+ 1)) + {#/.value value + #/.children (list@map product.right children)}]))) (def: #export test Test - (<| (_.context (%.name (name-of /.Tree))) - (do {! r.monad} - [size (:: ! map (|>> (n.% 100) (n.+ 1)) r.nat)] - ($_ _.and - ($equivalence.spec (/.equivalence n.equivalence) (..tree size r.nat)) - ($fold.spec /.leaf /.equivalence /.fold) - ($functor.spec /.leaf /.equivalence /.functor) - - (do ! - [sample (..tree size r.nat)] - (_.test "Can flatten a tree to get all the nodes as a flat tree." - (n.= size - (list.size (/.flatten sample))))) - )))) + (<| (_.covering /._) + (_.with-cover [/.Tree]) + ($_ _.and + (_.with-cover [/.equivalence] + (|> (..tree random.nat) + (:: random.monad map product.right) + ($equivalence.spec (/.equivalence n.equivalence)))) + (_.with-cover [/.fold] + ($fold.spec /.leaf /.equivalence /.fold)) + (_.with-cover [/.functor] + ($functor.spec /.leaf /.equivalence /.functor)) + + (do random.monad + [[size sample] (..tree random.nat)] + (_.cover [/.flatten] + (n.= size + (list.size (/.flatten sample))))) + (do random.monad + [expected random.nat] + (_.cover [/.leaf] + (:: (list.equivalence n.equivalence) = + (list expected) + (/.flatten (/.leaf expected))))) + (do {! random.monad} + [value random.nat + num-children (:: ! map (n.% 3) random.nat) + children (random.list num-children random.nat)] + (_.cover [/.branch] + (:: (list.equivalence n.equivalence) = + (list& value children) + (/.flatten (/.branch value (list@map /.leaf children)))))) + (do random.monad + [expected/0 random.nat + expected/1 random.nat + expected/2 random.nat + expected/3 random.nat + expected/4 random.nat + expected/5 random.nat] + (_.cover [/.tree] + (and (:: (list.equivalence n.equivalence) = + (list expected/0) + (/.flatten (/.tree expected/0))) + (:: (list.equivalence n.equivalence) = + (list expected/0 expected/1 expected/2) + (/.flatten (/.tree expected/0 + {expected/1 {} + expected/2 {}}))) + (:: (list.equivalence n.equivalence) = + (list expected/0 expected/1 expected/2 + expected/3 expected/4 expected/5) + (/.flatten (/.tree expected/0 + {expected/1 {} + expected/2 {expected/3 {} + expected/4 {expected/5 {}}}}))) + ))) + ))) diff --git a/stdlib/source/test/lux/data/collection/tree/zipper.lux b/stdlib/source/test/lux/data/collection/tree/zipper.lux index 7354eafed..6d0ab8a6c 100644 --- a/stdlib/source/test/lux/data/collection/tree/zipper.lux +++ b/stdlib/source/test/lux/data/collection/tree/zipper.lux @@ -24,8 +24,7 @@ Test (<| (_.context (%.name (name-of /.Zipper))) (do {! r.monad} - [size (:: ! map (|>> (n.% 90) (n.+ 10)) r.nat) - sample (//.tree size r.nat) + [[size sample] (//.tree r.nat) mid-val r.nat new-val r.nat pre-val r.nat diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux index b59ae9ca2..faa3fa85f 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/case.lux @@ -61,11 +61,11 @@ (^template [<tag> <gen> <wrapper>] [_ (<tag> _)] (if allow-literals? - (do {@ r.monad} + (do {! r.monad} [?sample (r.maybe <gen>)] (case ?sample (#.Some sample) - (do @ + (do ! [else (exhaustive-branches allow-literals? variantTC inputC)] (wrap (list& (<wrapper> sample) else))) @@ -82,8 +82,8 @@ (r@wrap (list (' []))) [_ (#.Tuple members)] - (do {@ r.monad} - [member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) members)] + (do {! r.monad} + [member-wise-patterns (monad.map ! (exhaustive-branches allow-literals? variantTC) members)] (wrap (|> member-wise-patterns exhaustive-weaving (list@map code.tuple)))) @@ -92,19 +92,19 @@ (r@wrap (list (' {}))) [_ (#.Record kvs)] - (do {@ r.monad} + (do {! r.monad} [#let [ks (list@map product.left kvs) vs (list@map product.right kvs)] - member-wise-patterns (monad.map @ (exhaustive-branches allow-literals? variantTC) vs)] + member-wise-patterns (monad.map ! (exhaustive-branches allow-literals? variantTC) vs)] (wrap (|> member-wise-patterns exhaustive-weaving (list@map (|>> (list.zip/2 ks) code.record))))) (^ [_ (#.Form (list [_ (#.Tag _)] _))]) - (do {@ r.monad} - [bundles (monad.map @ + (do {! r.monad} + [bundles (monad.map ! (function (_ [_tag _code]) - (do @ + (do ! [v-branches (exhaustive-branches allow-literals? variantTC _code)] (wrap (list@map (function (_ pattern) (` ((~ _tag) (~ pattern)))) v-branches)))) @@ -121,13 +121,13 @@ (function (_ input) ($_ r.either (r@map product.right _primitive.primitive) - (do {@ r.monad} - [choice (|> r.nat (:: @ map (n.% (list.size variant-tags)))) + (do {! r.monad} + [choice (|> r.nat (:: ! map (n.% (list.size variant-tags)))) #let [choiceT (maybe.assume (list.nth choice variant-tags)) choiceC (maybe.assume (list.nth choice primitivesC))]] (wrap (` ((~ choiceT) (~ choiceC))))) - (do {@ r.monad} - [size (|> r.nat (:: @ map (n.% 3))) + (do {! r.monad} + [size (|> r.nat (:: ! map (n.% 3))) elems (r.list size input)] (wrap (code.tuple elems))) (r@wrap (code.record (list.zip/2 record-tags primitivesC))) @@ -139,13 +139,13 @@ (def: #export test (<| (_.context (name.module (name-of /._))) - (do {@ r.monad} + (do {! r.monad} [module-name (r.unicode 5) variant-name (r.unicode 5) record-name (|> (r.unicode 5) (r.filter (|>> (text@= variant-name) not))) - size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - variant-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) - record-tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) + size (|> r.nat (:: ! map (|>> (n.% 10) (n.max 2)))) + variant-tags (|> (r.set text.hash size (r.unicode 5)) (:: ! map set.to-list)) + record-tags (|> (r.set text.hash size (r.unicode 5)) (:: ! map set.to-list)) primitivesTC (r.list size _primitive.primitive) #let [primitivesT (list@map product.left primitivesTC) primitivesC (list@map product.right primitivesTC) @@ -183,10 +183,10 @@ (_.test "Will reject non-exhaustive pattern-matching." (|> (analyse-pm non-exhaustive-branchesC) _structure.check-fails))) - (do @ + (do ! [redundant-patterns (exhaustive-branches false variantTC inputC) - redundancy-idx (|> r.nat (:: @ map (n.% (list.size redundant-patterns)))) - #let [redundant-branchesC (<| (list@map (branch outputC)) + redundancy-idx (|> r.nat (:: ! map (n.% (list.size redundant-patterns)))) + #let [redundant-branchesC (<| (list!map (branch outputC)) list.concat (list (list.take redundancy-idx redundant-patterns) (list (maybe.assume (list.nth redundancy-idx redundant-patterns))) @@ -194,10 +194,10 @@ (_.test "Will reject redundant pattern-matching." (|> (analyse-pm redundant-branchesC) _structure.check-fails))) - (do @ + (do ! [[heterogeneousT heterogeneousC] (r.filter (|>> product.left (check.checks? outputT) not) _primitive.primitive) - heterogeneous-idx (|> r.nat (:: @ map (n.% (list.size exhaustive-patterns)))) + heterogeneous-idx (|> r.nat (:: ! map (n.% (list.size exhaustive-patterns)))) #let [heterogeneous-branchesC (list.concat (list (list.take heterogeneous-idx exhaustive-branchesC) (list (let [[_pattern _body] (maybe.assume (list.nth heterogeneous-idx exhaustive-branchesC))] [_pattern heterogeneousC])) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux index 3dbacc0e2..4fa365850 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/function.lux @@ -80,10 +80,10 @@ )))) (def: apply - (do {@ r.monad} - [full-args (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - partial-args (|> r.nat (:: @ map (n.% full-args))) - var-idx (|> r.nat (:: @ map (|>> (n.% full-args) (n.max 1)))) + (do {! r.monad} + [full-args (|> r.nat (:: ! map (|>> (n.% 10) (n.max 2)))) + partial-args (|> r.nat (:: ! map (n.% full-args))) + var-idx (|> r.nat (:: ! map (|>> (n.% full-args) (n.max 1)))) inputsTC (r.list full-args _primitive.primitive) #let [inputsT (list@map product.left inputsTC) inputsC (list@map product.right inputsTC)] diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux index 7197dbca6..b67193533 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/reference.lux @@ -49,11 +49,11 @@ (def: (reach-test var-name [export? def-module] [import? dependent-module] check!) (-> Text [Bit Text] [Bit Text] Check Bit) - (|> (do {@ phase.monad} + (|> (do {! phase.monad} [_ (//module.with-module 0 def-module (//module.define var-name (#.Right [export? Any (' {}) []])))] (//module.with-module 0 dependent-module - (do @ + (do ! [_ (if import? (//module.import def-module) (wrap []))] diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux index 6da982c17..fc6d49b3d 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/analysis/structure.lux @@ -117,11 +117,11 @@ false))) (def: sum - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - choice (|> r.nat (:: @ map (n.% size))) + (do {! r.monad} + [size (|> r.nat (:: ! map (|>> (n.% 10) (n.max 2)))) + choice (|> r.nat (:: ! map (n.% size))) primitives (r.list size _primitive.primitive) - +choice (|> r.nat (:: @ map (n.% (inc size)))) + +choice (|> r.nat (:: ! map (n.% (inc size)))) [_ +valueC] _primitive.primitive #let [variantT (type.variant (list@map product.left primitives)) [valueT valueC] (maybe.assume (list.nth choice primitives)) @@ -169,10 +169,10 @@ )))) (def: product - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) + (do {! r.monad} + [size (|> r.nat (:: ! map (|>> (n.% 10) (n.max 2)))) primitives (r.list size _primitive.primitive) - choice (|> r.nat (:: @ map (n.% size))) + choice (|> r.nat (:: ! map (n.% size))) [_ +valueC] _primitive.primitive #let [tupleT (type.tuple (list@map product.left primitives)) [singletonT singletonC] (|> primitives (list.nth choice) maybe.assume) @@ -229,11 +229,11 @@ )))) (def: variant - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) - choice (|> r.nat (:: @ map (n.% size))) - other-choice (|> r.nat (:: @ map (n.% size)) (r.filter (|>> (n.= choice) not))) + (do {! r.monad} + [size (|> r.nat (:: ! map (|>> (n.% 10) (n.max 2)))) + tags (|> (r.set text.hash size (r.unicode 5)) (:: ! map set.to-list)) + choice (|> r.nat (:: ! map (n.% size))) + other-choice (|> r.nat (:: ! map (n.% size)) (r.filter (|>> (n.= choice) not))) primitives (r.list size _primitive.primitive) module-name (r.unicode 5) type-name (r.unicode 5) @@ -275,13 +275,13 @@ )))) (def: record - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) - tags (|> (r.set text.hash size (r.unicode 5)) (:: @ map set.to-list)) + (do {! r.monad} + [size (|> r.nat (:: ! map (|>> (n.% 10) (n.max 2)))) + tags (|> (r.set text.hash size (r.unicode 5)) (:: ! map set.to-list)) primitives (r.list size _primitive.primitive) module-name (r.unicode 5) type-name (r.unicode 5) - choice (|> r.nat (:: @ map (n.% size))) + choice (|> r.nat (:: ! map (n.% size))) #let [varT (#.Parameter 1) tagsC (list@map (|>> [module-name] code.tag) tags) primitivesT (list@map product.left primitives) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux index a7686e0f2..0c0a2d467 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/extension/analysis/lux.lux @@ -72,10 +72,10 @@ (def: i64 Test - (do {@ r.monad} - [subjectC (|> r.nat (:: @ map code.nat)) - signedC (|> r.int (:: @ map code.int)) - paramC (|> r.nat (:: @ map code.nat))] + (do {! r.monad} + [subjectC (|> r.nat (:: ! map code.nat)) + signedC (|> r.int (:: ! map code.int)) + paramC (|> r.nat (:: ! map code.nat))] ($_ _.and (_.test "i64 'and'." (check-success+ "lux i64 and" (list paramC subjectC) Nat)) @@ -99,9 +99,9 @@ (def: int Test - (do {@ r.monad} - [subjectC (|> r.int (:: @ map code.int)) - paramC (|> r.int (:: @ map code.int))] + (do {! r.monad} + [subjectC (|> r.int (:: ! map code.int)) + paramC (|> r.int (:: ! map code.int))] ($_ _.and (_.test "Can multiply integers." (check-success+ "lux i64 *" (list paramC subjectC) Int)) @@ -119,10 +119,10 @@ (def: frac Test - (do {@ r.monad} - [subjectC (|> r.safe-frac (:: @ map code.frac)) - paramC (|> r.safe-frac (:: @ map code.frac)) - encodedC (|> r.safe-frac (:: @ map (|>> %.frac code.text)))] + (do {! r.monad} + [subjectC (|> r.safe-frac (:: ! map code.frac)) + paramC (|> r.safe-frac (:: ! map code.frac)) + encodedC (|> r.safe-frac (:: ! map (|>> %.frac code.text)))] ($_ _.and (_.test "Can add frac numbers." (check-success+ "lux f64 +" (list paramC subjectC) Frac)) @@ -154,12 +154,12 @@ (def: text Test - (do {@ r.monad} - [subjectC (|> (r.unicode 5) (:: @ map code.text)) - paramC (|> (r.unicode 5) (:: @ map code.text)) - replacementC (|> (r.unicode 5) (:: @ map code.text)) - fromC (|> r.nat (:: @ map code.nat)) - toC (|> r.nat (:: @ map code.nat))] + (do {! r.monad} + [subjectC (|> (r.unicode 5) (:: ! map code.text)) + paramC (|> (r.unicode 5) (:: ! map code.text)) + replacementC (|> (r.unicode 5) (:: ! map code.text)) + fromC (|> r.nat (:: ! map code.nat)) + toC (|> r.nat (:: ! map code.nat))] ($_ _.and (_.test "Can test text equivalence." (check-success+ "lux text =" (list paramC subjectC) Bit)) @@ -179,9 +179,9 @@ (def: io Test - (do {@ r.monad} - [logC (|> (r.unicode 5) (:: @ map code.text)) - exitC (|> r.int (:: @ map code.int))] + (do {! r.monad} + [logC (|> (r.unicode 5) (:: ! map code.text)) + exitC (|> r.int (:: ! map code.int))] ($_ _.and (_.test "Can log messages to standard output." (check-success+ "lux io log" (list logC) Any)) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux index 0789d5ddd..45706256b 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/variable.lux @@ -44,13 +44,13 @@ (template [<name> <synthesis> <random>] [(def: (<name> context) (Scenario Synthesis) - (do {@ random.monad} + (do {! random.monad} [value <random>] (wrap [(<synthesis> value) (<synthesis> value)])))] [bit-scenario synthesis.bit random.bit] - [i64-scenario synthesis.i64 (:: @ map .i64 random.nat)] + [i64-scenario synthesis.i64 (:: ! map .i64 random.nat)] [f64-scenario synthesis.f64 random.frac] [text-scenario synthesis.text (random.unicode 1)] ) @@ -64,10 +64,10 @@ (def: (with-redundancy scenario context) (-> (Scenario Synthesis) (Scenario Synthesis)) - (do {@ random.monad} + (do {! random.monad} [redundant? random.bit] (if redundant? - (do @ + (do ! [let? random.bit [expected-input actual-input] (..primitive-scenario context) #let [fake-register (n.+ (get@ #redundants context) @@ -86,7 +86,7 @@ (def: (variant-scenario scenario context) (-> (Scenario Synthesis) (Scenario Synthesis)) - (do {@ random.monad} + (do {! random.monad} [lefts random.nat right? random.bit [expected input] (scenario context)] @@ -142,8 +142,8 @@ (def: (get-scenario scenario context) (-> (Scenario Synthesis) (Scenario Synthesis)) - (do {@ random.monad} - [length (:: @ map (|>> (n.% 5) inc) random.nat) + (do {! random.monad} + [length (:: ! map (|>> (n.% 5) inc) random.nat) path (random.list length ..random-member) [expected-record actual-record] (scenario context)] (wrap [(synthesis.branch/get [path expected-record]) @@ -157,14 +157,14 @@ (-> (Scenario Synthesis) (Scenario Path)) (`` ($_ random.either ($_ random.either - (do {@ random.monad} + (do {! random.monad} [_ (wrap []) [expected-then actual-then] (scenario context)] (wrap [(#synthesis.Seq #synthesis.Pop (#synthesis.Then expected-then)) (#synthesis.Seq #synthesis.Pop (#synthesis.Then actual-then))])) - (do {@ random.monad} + (do {! random.monad} [_ (wrap []) #let [real-register (dictionary.size (get@ #necessary context)) fake-register (n.+ (get@ #redundants context) @@ -178,7 +178,7 @@ (#synthesis.Then actual-then)))]))) ($_ random.either (~~ (template [<tag> <random>] - [(do {@ random.monad} + [(do {! random.monad} [test <random> [expected-then actual-then] (scenario context)] (wrap [(#synthesis.Seq (#synthesis.Test (<tag> test)) @@ -187,26 +187,26 @@ (#synthesis.Then actual-then))]))] [#synthesis.Bit random.bit] - [#synthesis.I64 (:: @ map .i64 random.nat)] + [#synthesis.I64 (:: ! map .i64 random.nat)] [#synthesis.F64 random.frac] [#synthesis.Text (random.unicode 1)] ))) ($_ random.either - (do {@ random.monad} + (do {! random.monad} [side ..random-side [expected-next actual-next] (path-scenario scenario context)] (wrap [(#synthesis.Seq (#synthesis.Access (#synthesis.Side side)) expected-next) (#synthesis.Seq (#synthesis.Access (#synthesis.Side side)) actual-next)])) - (do {@ random.monad} + (do {! random.monad} [member ..random-member [expected-next actual-next] (path-scenario scenario context)] (wrap [(#synthesis.Seq (#synthesis.Access (#synthesis.Member member)) expected-next) (#synthesis.Seq (#synthesis.Access (#synthesis.Member member)) actual-next)]))) - (do {@ random.monad} + (do {! random.monad} [_ (wrap []) [expected-left actual-left] (path-scenario scenario context) [expected-right actual-right] (path-scenario scenario context)] @@ -216,7 +216,7 @@ (def: (case-scenario scenario context) (-> (Scenario Synthesis) (Scenario Synthesis)) - (do {@ random.monad} + (do {! random.monad} [_ (wrap []) [expected-input actual-input] (scenario context) [expected-path actual-path] (..path-scenario scenario context)] @@ -236,7 +236,7 @@ (def: (scope-scenario scenario context) (-> (Scenario Synthesis) (Scenario Synthesis)) - (do {@ random.monad} + (do {! random.monad} [_ (wrap []) #let [real-start (dictionary.size (get@ #necessary context)) fake-start (n.+ (get@ #redundants context) @@ -256,7 +256,7 @@ (def: (recur-scenario scenario context) (-> (Scenario Synthesis) (Scenario Synthesis)) - (do {@ random.monad} + (do {! random.monad} [_ (wrap []) resets (random.list ..scope-arity (scenario context))] (wrap [(synthesis.loop/recur (list@map product.left resets)) @@ -271,7 +271,7 @@ (def: (abstraction-scenario scenario context) (-> (Scenario Synthesis) (Scenario Synthesis)) - (do {@ random.monad} + (do {! random.monad} [_ (wrap []) #let [registers (dictionary.entries (get@ #necessary context)) expected-environment (list@map (|>> product.left #variable.Local) registers) @@ -282,8 +282,8 @@ (def: (apply-scenario scenario context) (-> (Scenario Synthesis) (Scenario Synthesis)) - (do {@ random.monad} - [abstraction (:: @ map (|>> synthesis.constant) + (do {! random.monad} + [abstraction (:: ! map (|>> synthesis.constant) (random.and (random.unicode 1) (random.unicode 1))) inputs (random.list ..scope-arity (scenario context))] diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux index 819f6ccf1..7c2ece82e 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux @@ -26,8 +26,8 @@ (def: name-part^ (Random Text) - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 20) (n.max 1))))] + (do {! r.monad} + [size (|> r.nat (:: ! map (|>> (n.% 20) (n.max 1))))] (r.ascii/lower-alpha size))) (def: name^ @@ -73,7 +73,7 @@ (def: code Test - (do {@ r.monad} + (do {! r.monad} [sample code^] ($_ _.and (_.test "Can parse Lux code." @@ -85,7 +85,7 @@ (#.Right [_ parsed]) (:: code.equivalence = parsed sample))) - (do @ + (do ! [other code^] (_.test "Can parse multiple Lux code nodes." (let [source-code (format (%.code sample) " " (%.code other)) |