diff options
44 files changed, 729 insertions, 486 deletions
diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el index 16609262b..65aa29b33 100644 --- a/lux-mode/lux-mode.el +++ b/lux-mode/lux-mode.el @@ -264,7 +264,7 @@ Called by `imenu--generic-function'." (code//super-quotation (altRE "``" "~~")) (code//template (altRE "template" "template:")) ;; Miscellaneous - (actor (altRE "actor:" "message:" "on:")) + (actor (altRE "actor:" "message:" "actor")) (jvm-host (altRE "class:" "interface:" "import:" "object" "do-to" "synchronized" "class-for")) (alternative-format (altRE "char" "bin" "oct" "hex")) (documentation (altRE "doc" "comment")) diff --git a/stdlib/source/lux/control/concurrency/actor.lux b/stdlib/source/lux/control/concurrency/actor.lux index 320dc4207..c5f6ca6c7 100644 --- a/stdlib/source/lux/control/concurrency/actor.lux +++ b/stdlib/source/lux/control/concurrency/actor.lux @@ -301,7 +301,7 @@ {#.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] + (with-gensyms [g!_] (do meta.monad [g!type (meta.gensym (format name "-abstract-type")) #let [g!actor (code.local-identifier name) @@ -313,11 +313,22 @@ (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))}) + #..on-mail (~ (..on-mail g!_ ?on-mail)) + #..on-stop (~ (..on-stop g!_ ?on-stop))}) (~+ messages)))))))) + (syntax: #export (actor {[state-type init] (<c>.record (<>.and <c>.any <c>.any))} + {[?on-mail ?on-stop messages] behavior^}) + (with-gensyms [g!_] + (wrap (list (` (: ((~! io.IO) (..Actor (~ state-type))) + (..spawn! (: (..Behavior (~ state-type) (~ state-type)) + {#..on-init (|>>) + #..on-mail (~ (..on-mail g!_ ?on-mail)) + #..on-stop (~ (..on-stop g!_ ?on-stop))}) + (: (~ state-type) + (~ init))))))))) + (type: Signature {#vars (List Text) #name Text @@ -354,10 +365,10 @@ <examples>)} (with-gensyms [g!_ g!return] (do meta.monad - [[actor-name actor-vars] abstract.current - #let [g!type (code.local-identifier actor-name) + [actor-scope abstract.current + #let [g!type (code.local-identifier (get@ #abstract.name actor-scope)) g!message (code.local-identifier (get@ #name signature)) - g!actor-vars (list@map code.local-identifier actor-vars) + g!actor-vars (get@ #abstract.type-vars actor-scope) 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)) @@ -367,13 +378,14 @@ (~ (csw.annotations annotations)) (All [(~+ g!all-vars)] (-> (~+ g!inputsT) - (..Message ((~ g!type) (~+ g!actor-vars)) (~ (get@ #output signature))))) + (..Message (~ (get@ #abstract.abstraction actor-scope)) + (~ (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)])))))))) + (let [(~ g!state) (:coerce (~ (get@ #abstract.representation actor-scope)) + (~ g!state))] + (|> (~ body) + (: ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.representation actor-scope)) + (~ (get@ #output signature))]))) + (:coerce ((~! promise.Promise) ((~! try.Try) [(~ (get@ #abstract.abstraction actor-scope)) + (~ (get@ #output signature))])))))))) )))))) diff --git a/stdlib/source/lux/data/collection/dictionary/ordered.lux b/stdlib/source/lux/data/collection/dictionary/ordered.lux index 9ae66df08..f0bacd85a 100644 --- a/stdlib/source/lux/data/collection/dictionary/ordered.lux +++ b/stdlib/source/lux/data/collection/dictionary/ordered.lux @@ -129,6 +129,10 @@ [depth n.max] ) +(def: #export empty? + (All [k v] (-> (Dictionary k v) Bit)) + (|>> ..size (n.= 0))) + (template [<name> <other-color> <self-color> <no-change>] [(def: (<name> self) (All [k v] (-> (Node k v) (Node k v))) @@ -272,7 +276,7 @@ )) ## (_@= reference key) - ?root + (#.Some (set@ #value value root)) ))) ))] (set@ #root root' dict))) @@ -527,10 +531,13 @@ ))) (def: #export (update key transform dict) - (All [k v] (-> k (-> v v) (Dictionary k v) (Maybe (Dictionary k v)))) - (do maybe.monad - [old (get key dict)] - (wrap (put key (transform old) dict)))) + (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v))) + (case (..get key dict) + (#.Some old) + (..put key (transform old) dict) + + #.None + dict)) (def: #export (from-list Order<l> list) (All [k v] (-> (Order k) (List [k v]) (Dictionary k v))) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index 22a21cc9c..46cbd641b 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -1,5 +1,5 @@ (.module: - [lux (#- Scope) + [lux #* [abstract [monad (#+ Monad do)]] [control @@ -34,14 +34,14 @@ (All [a] (-> (Stack a) (Maybe (Stack a)))) list.tail) -(type: Scope +(type: #export Frame {#name Text #type-vars (List Code) #abstraction Code #representation Code}) -(def: scopes - (Stack Scope) +(def: frames + (Stack Frame) #.Nil) (template: (!peek <source> <reference> <then>) @@ -55,53 +55,49 @@ #.Nil (undefined)))) -(def: (peek-scopes-definition reference source) - (-> Text (List [Text Global]) (Stack Scope)) +(def: (peek-frames-definition reference source) + (-> Text (List [Text Global]) (Stack Frame)) (!peek source reference (case head (#.Left _) (undefined) - (#.Right [exported? scope-type scope-anns scope-value]) - (:coerce (Stack Scope) scope-value)))) + (#.Right [exported? frame-type frame-anns frame-value]) + (:coerce (Stack Frame) frame-value)))) -(def: (peek-scopes reference definition-reference source) - (-> Text Text (List [Text Module]) (Stack Scope)) +(def: (peek-frames reference definition-reference source) + (-> Text Text (List [Text Module]) (Stack Frame)) (!peek source reference - (peek-scopes-definition definition-reference (get@ #.definitions head)))) + (peek-frames-definition definition-reference (get@ #.definitions head)))) -(exception: #export no-active-scopes) +(exception: #export no-active-frames) -(def: (peek! scope) - (-> (Maybe Text) (Meta Scope)) +(def: (peek! frame) + (-> (Maybe Text) (Meta Frame)) (function (_ compiler) - (let [[reference definition-reference] (name-of ..scopes) - current-scopes (peek-scopes reference definition-reference (get@ #.modules compiler))] - (case (case scope - (#.Some scope) + (let [[reference definition-reference] (name-of ..frames) + current-frames (peek-frames reference definition-reference (get@ #.modules compiler))] + (case (case frame + (#.Some frame) (list.find (function (_ [actual _]) - (text@= scope actual)) - current-scopes) + (text@= frame actual)) + current-frames) #.None - (..peek current-scopes)) - (#.Some scope) - (#.Right [compiler scope]) + (..peek current-frames)) + (#.Some frame) + (#.Right [compiler frame]) #.None - (exception.throw ..no-active-scopes []))))) + (exception.throw ..no-active-frames []))))) (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)]))) + (Meta Frame) + (..peek! #.None)) (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)))) + (-> Text (Meta Frame)) + (..peek! (#.Some name))) (template: (!push <source> <reference> <then>) (loop [entries <source>] @@ -116,60 +112,60 @@ #.Nil (undefined)))) -(def: (push-scope-definition reference scope source) - (-> Text Scope (List [Text Global]) (List [Text Global])) +(def: (push-frame-definition reference frame source) + (-> Text Frame (List [Text Global]) (List [Text Global])) (!push source reference (case head (#.Left _) (undefined) - (#.Right [exported? scopes-type scopes-anns scopes-value]) + (#.Right [exported? frames-type frames-anns frames-value]) (#.Right [exported? - scopes-type - scopes-anns - (..push scope (:coerce (Stack Scope) scopes-value))])))) + frames-type + frames-anns + (..push frame (:coerce (Stack Frame) frames-value))])))) -(def: (push-scope [module-reference definition-reference] scope source) - (-> Name Scope (List [Text Module]) (List [Text Module])) +(def: (push-frame [module-reference definition-reference] frame source) + (-> Name Frame (List [Text Module]) (List [Text Module])) (!push source module-reference - (update@ #.definitions (push-scope-definition definition-reference scope) head))) + (update@ #.definitions (push-frame-definition definition-reference frame) head))) -(def: (push! scope) - (-> Scope (Meta Any)) +(def: (push! frame) + (-> Frame (Meta Any)) (function (_ compiler) (#.Right [(update@ #.modules - (..push-scope (name-of ..scopes) scope) + (..push-frame (name-of ..frames) frame) compiler) []]))) -(def: (pop-scope-definition reference source) +(def: (pop-frame-definition reference source) (-> Text (List [Text Global]) (List [Text Global])) (!push source reference (case head (#.Left _) (undefined) - (#.Right [exported? scopes-type scopes-anns scopes-value]) + (#.Right [exported? frames-type frames-anns frames-value]) (#.Right [exported? - scopes-type - scopes-anns - (let [current-scopes (:coerce (Stack Scope) scopes-value)] - (case (..pop current-scopes) - (#.Some current-scopes') - current-scopes' + frames-type + frames-anns + (let [current-frames (:coerce (Stack Frame) frames-value)] + (case (..pop current-frames) + (#.Some current-frames') + current-frames' #.None - current-scopes))])))) + current-frames))])))) -(def: (pop-scope [module-reference definition-reference] source) +(def: (pop-frame [module-reference definition-reference] source) (-> Name (List [Text Module]) (List [Text Module])) (!push source module-reference - (|> head (update@ #.definitions (pop-scope-definition definition-reference))))) + (|> head (update@ #.definitions (pop-frame-definition definition-reference))))) (syntax: (pop!) (function (_ compiler) (#.Right [(update@ #.modules - (..pop-scope (name-of ..scopes)) + (..pop-frame (name-of ..frames)) compiler) (list)]))) @@ -179,9 +175,9 @@ (<>.and (<>@wrap #.None) <c>.any))) (template [<name> <from> <to>] - [(syntax: #export (<name> {[scope value] ..cast}) + [(syntax: #export (<name> {[frame value] ..cast}) (do meta.monad - [[name type-vars abstraction representation] (peek! scope)] + [[name type-vars abstraction representation] (peek! frame)] (wrap (list (` ((~! :cast) [(~+ type-vars)] (~ <from>) (~ <to>) (~ value)))))))] diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux index f3f222d90..a3712a19f 100644 --- a/stdlib/source/program/aedifex.lux +++ b/stdlib/source/program/aedifex.lux @@ -37,7 +37,7 @@ ["#." parser] ["#." pom] ["#." cli] - ["#." local] + ["#." cache] ["#." dependency #_ ["#" resolution]] ["#." command @@ -52,14 +52,14 @@ (-> /.Profile (Promise Any)) (do promise.monad [outcome (do (try.with promise.monad) - [cache (/local.all-cached (file.async file.default) - (set.to-list (get@ #/.dependencies profile)) - /dependency.empty) + [cache (/cache.read-all (file.async file.default) + (set.to-list (get@ #/.dependencies profile)) + /dependency.empty) resolution (promise.future (/dependency.resolve-all (set.to-list (get@ #/.repositories profile)) (set.to-list (get@ #/.dependencies profile)) cache))] - (/local.cache-all (file.async file.default) + (/cache.write-all (file.async file.default) resolution))] (wrap (case outcome (#try.Success _) diff --git a/stdlib/source/program/aedifex/cache.lux b/stdlib/source/program/aedifex/cache.lux new file mode 100644 index 000000000..2a81b2869 --- /dev/null +++ b/stdlib/source/program/aedifex/cache.lux @@ -0,0 +1,138 @@ +(.module: + [lux #* + [abstract + [codec (#+ Codec)] + ["." monad (#+ do)]] + [control + ["." try (#+ Try)] + [concurrency + ["." promise (#+ Promise)]] + [security + ["!" capability]]] + [data + [binary (#+ Binary)] + [text + ["%" format (#+ format)] + ["." encoding]] + [collection + ["." dictionary] + ["." set]] + [format + ["." xml]]] + [world + ["." file (#+ Path File Directory)]]] + ["." // #_ + ["#" local] + ["#." hash] + ["#." package (#+ Package)] + ["#." artifact + ["#/." extension]] + [dependency (#+ Dependency) + [resolution (#+ Resolution)]]]) + +(def: (write! system content file) + (-> (file.System Promise) Binary Path (Promise (Try Any))) + (do (try.with promise.monad) + [file (: (Promise (Try (File Promise))) + (file.get-file promise.monad system file))] + (!.use (:: file over-write) [content]))) + +(def: #export (write-one system [artifact type] package) + (-> (file.System Promise) Dependency Package (Promise (Try Any))) + (do (try.with promise.monad) + [directory (: (Promise (Try Path)) + (file.make-directories promise.monad system (//.path system artifact))) + #let [prefix (format directory (:: system separator) (//artifact.identity artifact))] + directory (: (Promise (Try (Directory Promise))) + (file.get-directory promise.monad system directory)) + _ (..write! system + (get@ #//package.library package) + (format prefix (//artifact/extension.extension type))) + _ (..write! system + (|> package + (get@ #//package.sha-1) + (:: //hash.sha-1-codec encode) + encoding.to-utf8) + (format prefix //artifact/extension.sha-1)) + _ (..write! system + (|> package + (get@ #//package.md5) + (:: //hash.md5-codec encode) + encoding.to-utf8) + (format prefix //artifact/extension.md5)) + _ (..write! system + (|> package (get@ #//package.pom) (:: xml.codec encode) encoding.to-utf8) + (format prefix //artifact/extension.pom))] + (wrap []))) + +(def: #export (write-all system resolution) + (-> (file.System Promise) Resolution (Promise (Try Any))) + (do {! (try.with promise.monad)} + [_ (monad.map ! (function (_ [dependency package]) + (..write-one system dependency package)) + (dictionary.entries resolution))] + (wrap []))) + +(def: (read! system path) + (-> (file.System Promise) Path (Promise (Try Binary))) + (do (try.with promise.monad) + [file (: (Promise (Try (File Promise))) + (!.use (:: system file) path))] + (!.use (:: file content) []))) + +(def: (decode codec data) + (All [a] (-> (Codec Text a) Binary (Try a))) + (let [(^open "_@.") try.monad] + (|> data + encoding.from-utf8 + (_@map (:: codec decode)) + _@join))) + +(def: #export (read-one system [artifact type]) + (-> (file.System Promise) Dependency (Promise (Try Package))) + (let [prefix (format (//.path system artifact) + (:: system separator) + (//artifact.identity artifact))] + (do (try.with promise.monad) + [pom (..read! system (format prefix //artifact/extension.pom)) + library (..read! system (format prefix (//artifact/extension.extension type))) + sha-1 (..read! system (format prefix //artifact/extension.sha-1)) + md5 (..read! system (format prefix //artifact/extension.md5))] + (:: promise.monad wrap + (do try.monad + [pom (..decode xml.codec pom) + sha-1 (..decode //hash.sha-1-codec sha-1) + md5 (..decode //hash.md5-codec md5)] + (wrap {#//package.library library + #//package.pom pom + #//package.sha-1 sha-1 + #//package.md5 md5})))))) + +(def: #export (read-all system dependencies resolution) + (-> (file.System Promise) (List Dependency) Resolution (Promise (Try Resolution))) + (case dependencies + #.Nil + (:: (try.with promise.monad) wrap resolution) + + (#.Cons head tail) + (do promise.monad + [package (case (dictionary.get head resolution) + (#.Some package) + (wrap (#try.Success package)) + + #.None + (..read-one system head))] + (with-expansions [<next> (as-is (read-all system tail resolution))] + (case package + (#try.Success package) + (do (try.with promise.monad) + [sub-dependencies (|> package + //package.dependencies + (:: promise.monad wrap)) + resolution (|> resolution + (dictionary.put head package) + (read-all system (set.to-list sub-dependencies)))] + <next>) + + (#try.Failure error) + <next>))))) diff --git a/stdlib/source/program/aedifex/command/build.lux b/stdlib/source/program/aedifex/command/build.lux index 2d8ffb763..2e3e464a2 100644 --- a/stdlib/source/program/aedifex/command/build.lux +++ b/stdlib/source/program/aedifex/command/build.lux @@ -25,6 +25,7 @@ ["#." action] ["#." command (#+ Command)] ["#." local] + ["#." cache] ["#." dependency (#+ Dependency) ["#/." resolution (#+ Resolution)]] ["#." shell] @@ -124,14 +125,14 @@ [(#.Some program) (#.Some target)] (do ///action.monad - [cache (///local.all-cached (file.async file.default) - (set.to-list (get@ #///.dependencies profile)) - ///dependency/resolution.empty) + [cache (///cache.read-all (file.async file.default) + (set.to-list (get@ #///.dependencies profile)) + ///dependency/resolution.empty) resolution (promise.future (///dependency/resolution.resolve-all (set.to-list (get@ #///.repositories profile)) (set.to-list (get@ #///.dependencies profile)) cache)) - _ (///local.cache-all (file.async file.default) + _ (///cache.write-all (file.async file.default) resolution) [resolution compiler] (promise@wrap (..compiler resolution)) working-directory (promise.future ..working-directory) diff --git a/stdlib/source/program/aedifex/dependency/resolution.lux b/stdlib/source/program/aedifex/dependency/resolution.lux index 7e48610e3..10874cbfc 100644 --- a/stdlib/source/program/aedifex/dependency/resolution.lux +++ b/stdlib/source/program/aedifex/dependency/resolution.lux @@ -3,6 +3,7 @@ ["." host (#+ import:)] [abstract [codec (#+ Codec)] + [equivalence (#+ Equivalence)] [monad (#+ do)]] [control ["." io (#+ IO)] @@ -133,6 +134,10 @@ Resolution (dictionary.new //.hash)) +(def: #export equivalence + (Equivalence Resolution) + (dictionary.equivalence ///package.equivalence)) + (exception: #export (cannot-resolve {dependency Dependency}) (let [artifact (get@ #//.artifact dependency) type (get@ #//.type dependency)] diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux index dc769bcc1..17ddeb4cf 100644 --- a/stdlib/source/program/aedifex/local.lux +++ b/stdlib/source/program/aedifex/local.lux @@ -1,45 +1,12 @@ (.module: [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["." io (#+ IO)] - ["." try (#+ Try)] - ["." exception] - [concurrency - ["." promise (#+ Promise)]] - [security - ["!" capability]] - ["<>" parser - ["<.>" xml]]] [data - [binary (#+ Binary)] [text - ["%" format (#+ format)] - ["." encoding]] - [collection - ["." list ("#@." monoid)] - ["." dictionary] - ["." set]] - [format - ["." binary] - ["." tar] - ["." xml]]] + ["%" format (#+ format)]]] [world - ["." file (#+ Path File Directory)]]] - [program - [compositor - ["." export]]] + ["." file (#+ Path)]]] ["." // #_ - ["/" profile (#+ Profile)] - ["#." pom] - ["#." hash] - ["#." package (#+ Package)] - ["#." artifact (#+ Artifact) - ["#/." type] - ["#/." extension]] - ["#." dependency (#+ Dependency) - ["#/." resolution (#+ Resolution)]]]) + ["#." artifact (#+ Artifact)]]) (def: #export (repository system) (All [a] (-> (file.System a) Path)) @@ -51,103 +18,3 @@ (format (..repository system) (:: system separator) (//artifact.path system artifact))) - -(def: (save! system content file) - (-> (file.System Promise) Binary Path (Promise (Try Any))) - (do (try.with promise.monad) - [file (: (Promise (Try (File Promise))) - (file.get-file promise.monad system file))] - (!.use (:: file over-write) [content]))) - -(def: #export (cache system [artifact type] package) - (-> (file.System Promise) Dependency Package (Promise (Try Any))) - (do (try.with promise.monad) - [directory (: (Promise (Try Path)) - (file.make-directories promise.monad system (..path system artifact))) - #let [prefix (format directory (:: system separator) (//artifact.identity artifact))] - directory (: (Promise (Try (Directory Promise))) - (file.get-directory promise.monad system directory)) - _ (..save! system - (get@ #//package.library package) - (format prefix (//artifact/extension.extension type))) - _ (..save! system - (|> package - (get@ #//package.sha-1) - (:: //hash.sha-1-codec encode) - encoding.to-utf8) - (format prefix //artifact/extension.sha-1)) - _ (..save! system - (|> package - (get@ #//package.md5) - (:: //hash.md5-codec encode) - encoding.to-utf8) - (format prefix //artifact/extension.md5)) - _ (..save! system - (|> package (get@ #//package.pom) (:: xml.codec encode) encoding.to-utf8) - (format prefix //artifact/extension.pom))] - (wrap []))) - -(def: #export (cache-all system resolution) - (-> (file.System Promise) Resolution (Promise (Try Any))) - (do {! (try.with promise.monad)} - [_ (monad.map ! (function (_ [dependency package]) - (..cache system dependency package)) - (dictionary.entries resolution))] - (wrap []))) - -(def: (read! system path) - (-> (file.System Promise) Path (Promise (Try Binary))) - (do (try.with promise.monad) - [file (: (Promise (Try (File Promise))) - (!.use (:: system file) path))] - (!.use (:: file content) []))) - -(def: #export (cached system [artifact type]) - (-> (file.System Promise) Dependency (Promise (Try Package))) - (do (try.with promise.monad) - [directory (: (Promise (Try Path)) - (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)) - library (..read! system (format prefix (//artifact/extension.extension type))) - sha-1 (..read! system (format prefix //artifact/extension.sha-1)) - md5 (..read! system (format prefix //artifact/extension.md5))] - (:: 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))) - (case dependencies - #.Nil - (:: (try.with promise.monad) wrap resolution) - - (#.Cons head tail) - (do promise.monad - [package (case (dictionary.get head resolution) - (#.Some package) - (wrap (#try.Success package)) - - #.None - (..cached system head))] - (with-expansions [<next> (as-is (all-cached system tail resolution))] - (case package - (#try.Success package) - (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 index 757f116e6..31376c6f5 100644 --- a/stdlib/source/program/aedifex/package.lux +++ b/stdlib/source/program/aedifex/package.lux @@ -1,13 +1,15 @@ (.module: [lux #* + [abstract + ["." equivalence (#+ Equivalence)]] [control ["." try (#+ Try) ("#@." functor)] [parser ["<.>" xml]]] [data - [binary (#+ Binary)] + ["." binary (#+ Binary)] [format - [xml (#+ XML)]] + ["." xml (#+ XML)]] [collection [set (#+ Set)]]]] ["." // #_ @@ -34,3 +36,12 @@ (|>> (get@ #pom) (<xml>.run //pom.parser) (try@map (get@ #/.dependencies)))) + +(def: #export equivalence + (Equivalence Package) + ($_ equivalence.product + binary.equivalence + xml.equivalence + //hash.equivalence + //hash.equivalence + )) diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux index c1aa9ae9b..ed32b969c 100644 --- a/stdlib/source/test/aedifex.lux +++ b/stdlib/source/test/aedifex.lux @@ -12,6 +12,7 @@ ["#/." pom] ["#/." install]] ["#." local] + ["#." cache] ["#." dependency] ["#." package] ["#." profile] @@ -29,6 +30,7 @@ /command/pom.test /command/install.test /local.test + /cache.test /dependency.test /package.test /profile.test diff --git a/stdlib/source/test/aedifex/cache.lux b/stdlib/source/test/aedifex/cache.lux new file mode 100644 index 000000000..e1b4abfc5 --- /dev/null +++ b/stdlib/source/test/aedifex/cache.lux @@ -0,0 +1,137 @@ +(.module: + [lux (#- Type type) + ["_" test (#+ Test)] + [abstract + ["." monad (#+ do)]] + [control + ["." try] + [concurrency + ["." promise (#+ Promise)]]] + [data + [binary (#+ Binary)] + ["." text] + [number + ["n" nat]] + [format + [xml (#+ XML)]] + [collection + ["." set] + ["." dictionary]]] + [math + ["." random (#+ Random) ("#@." monad)]] + [world + ["." file]]] + [// + ["@." profile] + ["@." artifact] + [// + [lux + [data + ["_." binary]]]]] + {#program + ["." / + ["/#" // #_ + ["#" profile (#+ Profile)] + ["#." package (#+ Package)] + ["#." pom] + ["#." dependency (#+ Dependency) + ["#/." resolution (#+ Resolution)]] + ["#." artifact (#+ Artifact) + ["#/." type (#+ Type)]]]]}) + +(def: type + (Random Type) + ($_ random.either + (random@wrap //artifact/type.lux-library) + (random@wrap //artifact/type.jvm-library))) + +(def: profile + (Random [Artifact Profile XML]) + (random.one (function (_ profile) + (try.to-maybe + (do try.monad + [pom (//pom.write profile) + identity (try.from-maybe (get@ #//.identity profile))] + (wrap [identity profile pom])))) + @profile.random)) + +(def: content + (Random Binary) + (do {! random.monad} + [content-size (:: ! map (n.% 100) random.nat)] + (_binary.random content-size))) + +(def: package + (Random [Dependency Package]) + (do {! random.monad} + [[identity profile pom] ..profile + type ..type + content ..content] + (wrap [{#//dependency.artifact identity + #//dependency.type type} + (//package.local pom content)]))) + +(def: resolution + (Random Resolution) + (do {! random.monad} + [[main-dependency main-package] ..package + dependencies (|> (//package.dependencies main-package) + (:: try.monad map set.to-list) + (try.default (list)) + (monad.map ! (function (_ dependency) + (do ! + [pom (random.one (function (_ [identity profile pom]) + (|> profile + (set@ #//.dependencies (set.new //dependency.hash)) + (set@ #//.identity (#.Some (get@ #//dependency.artifact dependency))) + //pom.write + try.to-maybe)) + ..profile) + content ..content] + (wrap [dependency + (//package.local pom content)])))))] + (wrap (dictionary.from-list //dependency.hash (list& [main-dependency main-package] dependencies))))) + +(def: singular + Test + (do {! random.monad} + [[dependency expected-package] ..package + #let [fs (: (file.System Promise) + (file.mock (:: file.default separator)))]] + (wrap (do promise.monad + [wrote! (/.write-one fs dependency expected-package) + read! (/.read-one fs dependency)] + (_.claim [/.write-one /.read-one] + (<| (try.default false) + (do try.monad + [_ wrote! + actual-package read!] + (wrap (:: //package.equivalence = + expected-package + actual-package))))))))) + +(def: plural + Test + (do {! random.monad} + [expected ..resolution + #let [fs (: (file.System Promise) + (file.mock (:: file.default separator)))]] + (wrap (do promise.monad + [wrote! (/.write-all fs expected) + read! (/.read-all fs (dictionary.keys expected) //dependency/resolution.empty)] + (_.claim [/.write-all /.read-all] + (<| (try.default false) + (do try.monad + [_ wrote! + actual read!] + (wrap (:: //dependency/resolution.equivalence = + expected + actual))))))))) + +(def: #export test + Test + (<| (_.covering /._) + ($_ _.and + ..singular + ..plural + ))) diff --git a/stdlib/source/test/aedifex/command/install.lux b/stdlib/source/test/aedifex/command/install.lux index 7f8a4557f..60a46116d 100644 --- a/stdlib/source/test/aedifex/command/install.lux +++ b/stdlib/source/test/aedifex/command/install.lux @@ -69,7 +69,7 @@ #let [fs (file.mock (:: file.default separator))]] (wrap (case (get@ #///.identity sample) (#.Some identity) - (do {@ promise.monad} + (do {! promise.monad} [verdict (do ///action.monad [_ (..execute! fs sample) #let [artifact-path (format (///local.path fs identity) @@ -90,7 +90,7 @@ (try.default false verdict))) #.None - (do {@ promise.monad} + (do {! promise.monad} [outcome (..execute! fs sample)] (_.claim [/.do!] (case outcome diff --git a/stdlib/source/test/aedifex/command/pom.lux b/stdlib/source/test/aedifex/command/pom.lux index cd0eed8e9..c973678cc 100644 --- a/stdlib/source/test/aedifex/command/pom.lux +++ b/stdlib/source/test/aedifex/command/pom.lux @@ -34,15 +34,15 @@ (do random.monad [sample @profile.random #let [fs (file.mock (:: file.default separator))]] - (wrap (do {@ promise.monad} + (wrap (do {! promise.monad} [outcome (/.do! fs sample)] (case outcome (#try.Success path) - (do @ + (do ! [verdict (do ///action.monad [expected (|> (///pom.write sample) (try@map (|>> (:: xml.codec encode) encoding.to-utf8)) - (:: @ wrap)) + (:: ! wrap)) file (: (Promise (Try (File Promise))) (file.get-file promise.monad fs path)) actual (!.use (:: file content) []) diff --git a/stdlib/source/test/aedifex/hash.lux b/stdlib/source/test/aedifex/hash.lux index bc6bb1b4b..745ec0910 100644 --- a/stdlib/source/test/aedifex/hash.lux +++ b/stdlib/source/test/aedifex/hash.lux @@ -29,9 +29,9 @@ (All [h] (-> (-> Binary (/.Hash h)) (Random (/.Hash h)))) - (do {@ random.monad} - [size (:: @ map (n.% 100) random.nat)] - (:: @ map hash (_binary.random size)))) + (do {! random.monad} + [size (:: ! map (n.% 100) random.nat)] + (:: ! map hash (_binary.random size)))) (def: #export test Test diff --git a/stdlib/source/test/aedifex/input.lux b/stdlib/source/test/aedifex/input.lux index 50b99a218..b05d0afcb 100644 --- a/stdlib/source/test/aedifex/input.lux +++ b/stdlib/source/test/aedifex/input.lux @@ -31,8 +31,8 @@ (def: #export test Test (<| (_.covering /._) - (do {@ random.monad} - [expected (:: @ map (set@ #//.parents (list)) @profile.random) + (do {! random.monad} + [expected (:: ! map (set@ #//.parents (list)) @profile.random) #let [fs (: (file.System Promise) (file.mock (:: file.default separator)))]] (wrap (do promise.monad diff --git a/stdlib/source/test/aedifex/local.lux b/stdlib/source/test/aedifex/local.lux index a883f565e..1c713684c 100644 --- a/stdlib/source/test/aedifex/local.lux +++ b/stdlib/source/test/aedifex/local.lux @@ -22,7 +22,7 @@ (def: #export test Test (<| (_.covering /._) - (do {@ random.monad} + (do {! random.monad} [sample @artifact.random #let [fs (: (file.System Promise) (file.mock (:: file.default separator)))]] diff --git a/stdlib/source/test/aedifex/parser.lux b/stdlib/source/test/aedifex/parser.lux index 0c85156d2..e26240562 100644 --- a/stdlib/source/test/aedifex/parser.lux +++ b/stdlib/source/test/aedifex/parser.lux @@ -38,8 +38,8 @@ (def: (list-of random) (All [a] (-> (Random a) (Random (List a)))) - (do {@ random.monad} - [size (:: @ map (n.% 5) random.nat)] + (do {! random.monad} + [size (:: ! map (n.% 5) random.nat)] (random.list size random))) (def: (dictionary-of key-hash key-random value-random) diff --git a/stdlib/source/test/aedifex/profile.lux b/stdlib/source/test/aedifex/profile.lux index 398a85f5b..d0da1ff2a 100644 --- a/stdlib/source/test/aedifex/profile.lux +++ b/stdlib/source/test/aedifex/profile.lux @@ -70,8 +70,8 @@ (def: (list-of random) (All [a] (-> (Random a) (Random (List a)))) - (do {@ random.monad} - [size (:: @ map (n.% 5) random.nat)] + (do {! random.monad} + [size (:: ! map (n.% 5) random.nat)] (random.list size random))) (def: (set-of hash random) diff --git a/stdlib/source/test/licentia.lux b/stdlib/source/test/licentia.lux index 619d9c711..f73d55ab4 100644 --- a/stdlib/source/test/licentia.lux +++ b/stdlib/source/test/licentia.lux @@ -42,11 +42,11 @@ (def: period (Random (Period Nat)) - (do {@ r.monad} + (do {! r.monad} [start (r.filter (|>> (n.= n@top) not) r.nat) #let [wiggle-room (n.- start n@top)] - end (:: @ map + end (:: ! map (|>> (n.% wiggle-room) (n.max 1)) r.nat)] (wrap {#time.start start @@ -104,8 +104,8 @@ (def: (variable-list max-size gen-element) (All [a] (-> Nat (Random a) (Random (List a)))) - (do {@ r.monad} - [amount (:: @ map (n.% (n.max 1 max-size)) + (do {! r.monad} + [amount (:: ! map (n.% (n.max 1 max-size)) r.nat)] (r.list amount gen-element))) diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 6549f9a17..809e906fb 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -138,8 +138,7 @@ ["#." host] ["#." extension] ["#." target #_ - ["#/." jvm]]] - ) + ["#/." jvm]]]) ## TODO: Get rid of this ASAP (template: (!bundle body) @@ -150,12 +149,12 @@ (def: identity Test - (do {@ random.monad} + (do {! random.monad} [self (random.unicode 1)] ($_ _.and (_.test "Every value is identical to itself." (is? self self)) - (do @ + (do ! [other (random.unicode 1)] (_.test "Values created separately can't be identical." (not (is? self other)))) diff --git a/stdlib/source/test/lux/control/concurrency/actor.lux b/stdlib/source/test/lux/control/concurrency/actor.lux index d31e6aef8..1b1a01242 100644 --- a/stdlib/source/test/lux/control/concurrency/actor.lux +++ b/stdlib/source/test/lux/control/concurrency/actor.lux @@ -45,11 +45,12 @@ Test (do random.monad [initial-state random.nat - #let [inc! (: (/.Mail Nat) - (function (_ state actor) - (promise@wrap - (#try.Success - (inc state)))))]] + #let [as-mail (: (All [a] (-> (-> a a) (/.Mail a))) + (function (_ transform) + (function (_ state actor) + (|> state transform #try.Success promise@wrap)))) + inc! (: (/.Mail Nat) (as-mail inc)) + dec! (: (/.Mail Nat) (as-mail dec))]] (<| (_.covering /._) (_.with-cover [/.Actor]) ($_ _.and @@ -159,4 +160,33 @@ (#try.Failure error) false)))) + + (wrap (do promise.monad + [verdict (promise.future + (do io.monad + [anonymous (/.actor {Nat + initial-state} + ((on-mail message state self) + (message (inc state) self)) + + ((on-stop cause state) + (promise@wrap (exec (%.nat state) + [])))) + sent/inc? (/.mail! inc! anonymous) + sent/dec? (/.mail! dec! anonymous) + poisoned? (/.poison! anonymous) + obituary (/.obituary anonymous)] + (wrap (and (..mailed? sent/inc?) + (..mailed? sent/dec?) + (..mailed? poisoned?) + (case obituary + (^ (#.Some [error final-state (list)])) + (and (exception.match? /.poisoned error) + (n.= (inc (inc initial-state)) + final-state)) + + _ + false)))))] + (_.claim [/.actor] + verdict))) )))) diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux index 6c52dc5ad..43198ff5b 100644 --- a/stdlib/source/test/lux/control/concurrency/frp.lux +++ b/stdlib/source/test/lux/control/concurrency/frp.lux @@ -121,7 +121,7 @@ (_.claim [/.filter] (list@= (list.filter n.even? inputs) output)))) - (wrap (do {@ promise.monad} + (wrap (do {! promise.monad} [#let [sink (: (Atom (Row Nat)) (atom.atom row.empty)) channel (/.sequential 0 inputs)] @@ -134,7 +134,7 @@ listened (|> sink atom.read promise.future - (:: @ map row.to-list))] + (:: ! map row.to-list))] (_.claim [/.listen] (and (list@= inputs output) diff --git a/stdlib/source/test/lux/control/concurrency/process.lux b/stdlib/source/test/lux/control/concurrency/process.lux index fc818e22d..6d59672ca 100644 --- a/stdlib/source/test/lux/control/concurrency/process.lux +++ b/stdlib/source/test/lux/control/concurrency/process.lux @@ -23,10 +23,10 @@ (def: #export test Test (<| (_.covering /._) - (do {@ random.monad} + (do {! random.monad} [dummy random.nat expected random.nat - delay (|> random.nat (:: @ map (n.% 100)))] + delay (|> random.nat (:: ! map (n.% 100)))] ($_ _.and (_.cover [/.parallelism] (n.> 0 /.parallelism)) diff --git a/stdlib/source/test/lux/control/concurrency/promise.lux b/stdlib/source/test/lux/control/concurrency/promise.lux index 1c8933499..0dc28819d 100644 --- a/stdlib/source/test/lux/control/concurrency/promise.lux +++ b/stdlib/source/test/lux/control/concurrency/promise.lux @@ -47,8 +47,8 @@ (def: #export test Test (<| (_.covering /._) - (do {@ random.monad} - [to-wait (|> random.nat (:: @ map (|>> (n.% 100) (n.max 10)))) + (do {! random.monad} + [to-wait (|> random.nat (:: ! map (|>> (n.% 100) (n.max 10)))) #let [extra-time (n.* 2 to-wait)] expected random.nat dummy random.nat diff --git a/stdlib/source/test/lux/control/concurrency/semaphore.lux b/stdlib/source/test/lux/control/concurrency/semaphore.lux index dcdb78f78..763ae41f8 100644 --- a/stdlib/source/test/lux/control/concurrency/semaphore.lux +++ b/stdlib/source/test/lux/control/concurrency/semaphore.lux @@ -30,8 +30,8 @@ Test (_.with-cover [/.Semaphore] ($_ _.and - (do {@ random.monad} - [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + (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))] @@ -42,11 +42,11 @@ #.None false))))) - (do {@ random.monad} - [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + (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)) + (wrap (do {! promise.monad} + [_ (monad.map ! /.wait (list.repeat initial-open-positions semaphore)) result (promise.time-out 10 (/.wait semaphore))] (_.claim [/.wait] (case result @@ -55,11 +55,11 @@ #.None true))))) - (do {@ random.monad} - [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + (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)) + (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) @@ -71,8 +71,8 @@ _ false))))) - (do {@ random.monad} - [initial-open-positions (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + (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)] @@ -89,8 +89,8 @@ Test (_.with-cover [/.Mutex] ($_ _.and - (do {@ random.monad} - [repetitions (|> random.nat (:: @ map (|>> (n.% 100) (n.max 10)))) + (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")) @@ -98,16 +98,16 @@ processA (<| (/.synchronize mutex) io.io promise.future - (do {@ io.monad} - [_ (<| (monad.seq @) + (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 @) + (do {! io.monad} + [_ (<| (monad.seq !) (list.repeat repetitions) (atom.update (|>> (format "B")) resource))] (wrap [])))]] @@ -146,11 +146,11 @@ _ false))) - (do {@ random.monad} - [limit (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + (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} + (wrap (do {! promise.monad} [#let [ending (|> "_" (list.repeat limit) (text.join-with "")) @@ -159,7 +159,7 @@ (exec (io.run (atom.update (|>> (format "_")) resource)) (waiter resource barrier id))) ids)] - _ (monad.seq @ waiters) + _ (monad.seq ! waiters) #let [outcome (io.run (atom.read resource))]] (_.claim [/.barrier /.block] (and (text.ends-with? ending outcome) diff --git a/stdlib/source/test/lux/control/concurrency/stm.lux b/stdlib/source/test/lux/control/concurrency/stm.lux index 040d97924..fd3cd53d9 100644 --- a/stdlib/source/test/lux/control/concurrency/stm.lux +++ b/stdlib/source/test/lux/control/concurrency/stm.lux @@ -38,10 +38,10 @@ (def: #export test Test (<| (_.covering /._) - (do {@ random.monad} + (do {! random.monad} [dummy random.nat expected random.nat - iterations-per-process (|> random.nat (:: @ map (n.% 100)))] + iterations-per-process (|> random.nat (:: ! map (n.% 100)))] ($_ _.and (_.with-cover [/.functor] ($functor.spec ..injection ..comparison /.functor)) @@ -92,10 +92,10 @@ (list expected (n.* 2 expected)) changes)))) (wrap (let [var (/.var 0)] - (do {@ promise.monad} + (do {! promise.monad} [_ (|> (list.repeat iterations-per-process []) (list@map (function (_ _) (/.commit (/.update inc var)))) - (monad.seq @)) + (monad.seq !)) cummulative (/.commit (/.read var))] (_.claim [/.STM] (n.= iterations-per-process diff --git a/stdlib/source/test/lux/control/exception.lux b/stdlib/source/test/lux/control/exception.lux index 599eb5863..db97197e3 100644 --- a/stdlib/source/test/lux/control/exception.lux +++ b/stdlib/source/test/lux/control/exception.lux @@ -24,11 +24,11 @@ (def: #export test Test - (do {@ random.monad} + (do {! random.monad} [expected random.nat wrong (|> random.nat (random.filter (|>> (n.= expected) not))) assertion-succeeded? random.bit - #let [report-element (:: @ map %.nat random.nat)] + #let [report-element (:: ! map %.nat random.nat)] field0 report-element value0 report-element field1 report-element diff --git a/stdlib/source/test/lux/control/function.lux b/stdlib/source/test/lux/control/function.lux index f795d27c0..6e9fc74ac 100644 --- a/stdlib/source/test/lux/control/function.lux +++ b/stdlib/source/test/lux/control/function.lux @@ -9,7 +9,7 @@ [data [number ["n" nat]] - ["." text ("#@." equivalence)]] + ["." text ("#!." equivalence)]] [math ["." random (#+ Random)]] ["_" test (#+ Test)]] @@ -18,10 +18,10 @@ (def: #export test Test - (do {@ random.monad} + (do {! random.monad} [expected random.nat - f0 (:: @ map n.+ random.nat) - f1 (:: @ map n.* random.nat) + f0 (:: ! map n.+ random.nat) + f1 (:: ! map n.* random.nat) dummy random.nat extra (|> random.nat (random.filter (|>> (n.= expected) not)))] (<| (_.covering /._) @@ -32,7 +32,7 @@ (n.= (left extra) (right extra))))) generator (: (Random (-> Nat Nat)) - (:: @ map n.- random.nat))] + (:: ! map n.- random.nat))] (_.with-cover [/.monoid] ($monoid.spec equivalence /.monoid generator))) diff --git a/stdlib/source/test/lux/control/function/contract.lux b/stdlib/source/test/lux/control/function/contract.lux index 0cde16295..422c98618 100644 --- a/stdlib/source/test/lux/control/function/contract.lux +++ b/stdlib/source/test/lux/control/function/contract.lux @@ -17,7 +17,7 @@ (def: #export test Test (<| (_.covering /._) - (do {@ random.monad} + (do {! random.monad} [expected random.nat]) ($_ _.and (_.cover [/.pre] diff --git a/stdlib/source/test/lux/control/function/memo.lux b/stdlib/source/test/lux/control/function/memo.lux index 85fe41f8d..90a2064af 100644 --- a/stdlib/source/test/lux/control/function/memo.lux +++ b/stdlib/source/test/lux/control/function/memo.lux @@ -49,8 +49,8 @@ (def: #export test Test (<| (_.covering /._) - (do {@ random.monad} - [input (|> random.nat (:: @ map (|>> (n.% 5) (n.+ 23))))]) + (do {! random.monad} + [input (|> random.nat (:: ! map (|>> (n.% 5) (n.+ 23))))]) (_.with-cover [/.Memo]) ($_ _.and (_.cover [/.closed /.none] diff --git a/stdlib/source/test/lux/control/function/mixin.lux b/stdlib/source/test/lux/control/function/mixin.lux index 2d83f5515..accf7659d 100644 --- a/stdlib/source/test/lux/control/function/mixin.lux +++ b/stdlib/source/test/lux/control/function/mixin.lux @@ -24,8 +24,8 @@ (def: #export test Test (<| (_.covering /._) - (do {@ random.monad} - [input (|> random.nat (:: @ map (|>> (n.% 6) (n.+ 20)))) + (do {! random.monad} + [input (|> random.nat (:: ! map (|>> (n.% 6) (n.+ 20)))) dummy random.nat shift (|> random.nat (random.filter (|>> (n.= dummy) not))) #let [equivalence (: (Equivalence (/.Mixin Nat Nat)) @@ -34,7 +34,7 @@ (n.= ((/.mixin left) input) ((/.mixin right) input))))) generator (: (Random (/.Mixin Nat Nat)) - (do @ + (do ! [output random.nat] (wrap (function (_ delegate recur input) output)))) diff --git a/stdlib/source/test/lux/control/parser.lux b/stdlib/source/test/lux/control/parser.lux index 092152160..cbf390441 100644 --- a/stdlib/source/test/lux/control/parser.lux +++ b/stdlib/source/test/lux/control/parser.lux @@ -74,9 +74,9 @@ (def: combinators-0 Test - (do {@ random.monad} + (do {! random.monad} [expected0 random.nat - variadic (:: @ map (|>> (n.max 1) (n.min 20)) random.nat) + variadic (:: ! map (|>> (n.max 1) (n.min 20)) random.nat) expected+ (random.list variadic random.nat) even0 (random.filter n.even? random.nat) odd0 (random.filter n.odd? random.nat) @@ -165,9 +165,9 @@ (def: combinators-1 Test - (do {@ random.monad} - [variadic (:: @ map (|>> (n.max 1) (n.min 20)) random.nat) - times (:: @ map (n.% variadic) random.nat) + (do {! random.monad} + [variadic (:: ! map (|>> (n.max 1) (n.min 20)) random.nat) + times (:: ! map (n.% variadic) random.nat) expected random.nat wrong (|> random.nat (random.filter (|>> (n.= expected) not))) expected+ (random.list variadic random.nat) diff --git a/stdlib/source/test/lux/control/parser/analysis.lux b/stdlib/source/test/lux/control/parser/analysis.lux index 47a987d03..dca66b9ef 100644 --- a/stdlib/source/test/lux/control/parser/analysis.lux +++ b/stdlib/source/test/lux/control/parser/analysis.lux @@ -48,11 +48,11 @@ Test (<| (_.covering /._) (_.with-cover [/.Parser]) - (do {@ random.monad} + (do {! random.monad} [] (`` ($_ _.and - (do {@ random.monad} - [expected (:: @ map (|>> analysis.bit) random.bit)] + (do {! random.monad} + [expected (:: ! map (|>> analysis.bit) random.bit)] (_.cover [/.run /.any] (|> (list expected) (/.run /.any) @@ -62,7 +62,7 @@ (#try.Failure _) false)))) (~~ (template [<query> <check> <random> <analysis> <=>] - [(do {@ random.monad} + [(do {! random.monad} [expected <random>] (_.cover [<query>] (|> (list (<analysis> expected)) @@ -72,7 +72,7 @@ (#try.Failure _) false)))) - (do {@ random.monad} + (do {! random.monad} [expected <random>] (_.cover [<check>] (|> (list (<analysis> expected)) @@ -89,7 +89,7 @@ [/.foreign /.foreign! random.nat analysis.variable/foreign n.=] [/.constant /.constant! ..constant analysis.constant name@=] )) - (do {@ random.monad} + (do {! random.monad} [expected random.bit] (_.cover [/.tuple] (|> (list (analysis.tuple (list (analysis.bit expected)))) @@ -99,7 +99,7 @@ (#try.Failure _) false)))) - (do {@ random.monad} + (do {! random.monad} [dummy random.bit] (_.cover [/.end?] (and (|> (/.run /.end? (list)) @@ -110,14 +110,14 @@ (wrap verdict)) (list (analysis.bit dummy))) (!expect (#try.Success #0)))))) - (do {@ random.monad} + (do {! random.monad} [dummy random.bit] (_.cover [/.end!] (and (|> (/.run /.end! (list)) (!expect (#try.Success _))) (|> (/.run /.end! (list (analysis.bit dummy))) (!expect (#try.Failure _)))))) - (do {@ random.monad} + (do {! random.monad} [expected random.bit] (_.cover [/.cannot-parse] (and (|> (list (analysis.bit expected)) @@ -134,7 +134,7 @@ (#try.Failure error) (exception.match? /.cannot-parse error)))))) - (do {@ random.monad} + (do {! random.monad} [expected random.bit] (_.cover [/.unconsumed-input] (|> (list (analysis.bit expected) (analysis.bit expected)) diff --git a/stdlib/source/test/lux/control/parser/code.lux b/stdlib/source/test/lux/control/parser/code.lux index 696f70265..de2601c45 100644 --- a/stdlib/source/test/lux/control/parser/code.lux +++ b/stdlib/source/test/lux/control/parser/code.lux @@ -43,15 +43,15 @@ (<| (_.covering /._) (_.with-cover [/.Parser]) (`` ($_ _.and - (do {@ random.monad} - [expected (:: @ map code.bit random.bit)] + (do {! random.monad} + [expected (:: ! map code.bit random.bit)] (_.cover [/.run] (and (|> (/.run /.any (list expected)) (!expect (#try.Success _))) (|> (/.run /.any (list)) (!expect (#try.Failure _)))))) (~~ (template [<query> <check> <random> <code> <equivalence>] - [(do {@ random.monad} + [(do {! random.monad} [expected <random> dummy (|> <random> (random.filter (|>> (:: <equivalence> = expected) not)))] ($_ _.and @@ -66,7 +66,7 @@ (!expect (#try.Failure _))))) ))] - [/.any /.this! (:: @ map code.bit random.bit) function.identity code.equivalence] + [/.any /.this! (:: ! map code.bit random.bit) function.identity code.equivalence] [/.bit /.bit! random.bit code.bit bit.equivalence] [/.nat /.nat! random.nat code.nat nat.equivalence] [/.int /.int! random.int code.int int.equivalence] @@ -79,7 +79,7 @@ [/.local-tag /.local-tag! (random.unicode 1) code.local-tag text.equivalence] )) (~~ (template [<query> <code>] - [(do {@ random.monad} + [(do {! random.monad} [expected-left random.nat expected-right random.int] (_.cover [<query>] @@ -93,7 +93,7 @@ [/.form code.form] [/.tuple code.tuple] )) - (do {@ random.monad} + (do {! random.monad} [expected-left random.nat expected-right random.int] (_.cover [/.record] @@ -103,7 +103,7 @@ (!expect (^multi (#try.Success [actual-left actual-right]) (and (:: nat.equivalence = expected-left actual-left) (:: int.equivalence = expected-right actual-right))))))) - (do {@ random.monad} + (do {! random.monad} [expected-local random.nat expected-global random.int] (_.cover [/.local] @@ -113,8 +113,8 @@ (!expect (^multi (#try.Success [actual-local actual-global]) (and (:: nat.equivalence = expected-local actual-local) (:: int.equivalence = expected-global actual-global))))))) - (do {@ random.monad} - [dummy (:: @ map code.bit random.bit)] + (do {! random.monad} + [dummy (:: ! map code.bit random.bit)] (_.cover [/.end?] (|> (/.run (do <>.monad [pre /.end? @@ -125,8 +125,8 @@ (list dummy)) (!expect (^multi (#try.Success verdict) verdict))))) - (do {@ random.monad} - [dummy (:: @ map code.bit random.bit)] + (do {! random.monad} + [dummy (:: ! map code.bit random.bit)] (_.cover [/.end!] (and (|> (/.run /.end! (list)) (!expect (#try.Success []))) diff --git a/stdlib/source/test/lux/control/parser/tree.lux b/stdlib/source/test/lux/control/parser/tree.lux index d451e6298..efea74853 100644 --- a/stdlib/source/test/lux/control/parser/tree.lux +++ b/stdlib/source/test/lux/control/parser/tree.lux @@ -27,7 +27,7 @@ false)) (template: (!cover <coverage> <parser> <sample>) - (do {@ random.monad} + (do {! random.monad} [dummy random.nat expected (|> random.nat (random.filter (|>> (n.= dummy) not)))] (_.cover <coverage> @@ -37,7 +37,7 @@ (n.= expected actual))))))) (template: (!cover2 <coverage> <parser> <sample0> <sample1>) - (do {@ random.monad} + (do {! random.monad} [dummy random.nat expected (|> random.nat (random.filter (|>> (n.= dummy) not)))] (_.cover <coverage> @@ -56,7 +56,7 @@ (!cover [/.run /.value] /.value (tree.leaf expected)) - (do {@ random.monad} + (do {! random.monad} [expected random.nat] (_.cover [/.run'] (|> (/.run' /.value @@ -156,7 +156,7 @@ (tree.branch expected (list (tree.leaf dummy) (tree.leaf dummy)))) - (do {@ random.monad} + (do {! random.monad} [dummy random.nat] (_.cover [/.cannot-move-further] (`` (and (~~ (template [<parser>] diff --git a/stdlib/source/test/lux/control/region.lux b/stdlib/source/test/lux/control/region.lux index 763a4be0c..691bcbbce 100644 --- a/stdlib/source/test/lux/control/region.lux +++ b/stdlib/source/test/lux/control/region.lux @@ -74,8 +74,8 @@ Test (<| (_.covering /._) (_.with-cover [/.Region]) - (do {@ random.monad} - [expected-clean-ups (|> random.nat (:: @ map (|>> (n.% 100) (n.max 1))))] + (do {! random.monad} + [expected-clean-ups (|> random.nat (:: ! map (|>> (n.% 100) (n.max 1))))] ($_ _.and (_.with-cover [/.functor] ($functor.spec ..injection ..comparison (: (All [! r] @@ -92,16 +92,16 @@ (_.cover [/.run] (thread.run - (do {@ thread.monad} + (do {! thread.monad} [clean-up-counter (thread.box 0) - #let [//@ @ + #let [//@ ! count-clean-up (function (_ value) - (do @ + (do ! [_ (thread.update inc clean-up-counter)] (wrap (#try.Success []))))] - outcome (/.run @ - (do {@ (/.monad @)} - [_ (monad.map @ (/.acquire //@ count-clean-up) + outcome (/.run ! + (do {! (/.monad !)} + [_ (monad.map ! (/.acquire //@ count-clean-up) (enum.range n.enum 1 expected-clean-ups))] (wrap []))) actual-clean-ups (thread.read clean-up-counter)] @@ -110,16 +110,16 @@ actual-clean-ups)))))) (_.cover [/.fail] (thread.run - (do {@ thread.monad} + (do {! thread.monad} [clean-up-counter (thread.box 0) - #let [//@ @ + #let [//@ ! count-clean-up (function (_ value) - (do @ + (do ! [_ (thread.update inc clean-up-counter)] (wrap (#try.Success []))))] - outcome (/.run @ - (do {@ (/.monad @)} - [_ (monad.map @ (/.acquire //@ count-clean-up) + outcome (/.run ! + (do {! (/.monad !)} + [_ (monad.map ! (/.acquire //@ count-clean-up) (enum.range n.enum 1 expected-clean-ups)) _ (/.fail //@ (exception.construct ..oops []))] (wrap []))) @@ -129,16 +129,16 @@ actual-clean-ups)))))) (_.cover [/.throw] (thread.run - (do {@ thread.monad} + (do {! thread.monad} [clean-up-counter (thread.box 0) - #let [//@ @ + #let [//@ ! count-clean-up (function (_ value) - (do @ + (do ! [_ (thread.update inc clean-up-counter)] (wrap (#try.Success []))))] - outcome (/.run @ - (do {@ (/.monad @)} - [_ (monad.map @ (/.acquire //@ count-clean-up) + outcome (/.run ! + (do {! (/.monad !)} + [_ (monad.map ! (/.acquire //@ count-clean-up) (enum.range n.enum 1 expected-clean-ups)) _ (/.throw //@ ..oops [])] (wrap []))) @@ -148,17 +148,17 @@ actual-clean-ups)))))) (_.cover [/.acquire] (thread.run - (do {@ thread.monad} + (do {! thread.monad} [clean-up-counter (thread.box 0) - #let [//@ @ + #let [//@ ! count-clean-up (function (_ value) - (do @ + (do ! [_ (thread.update inc clean-up-counter)] (wrap (: (Try Any) (exception.throw ..oops [])))))] - outcome (/.run @ - (do {@ (/.monad @)} - [_ (monad.map @ (/.acquire //@ count-clean-up) + outcome (/.run ! + (do {! (/.monad !)} + [_ (monad.map ! (/.acquire //@ count-clean-up) (enum.range n.enum 1 expected-clean-ups))] (wrap []))) actual-clean-ups (thread.read clean-up-counter)] @@ -168,11 +168,11 @@ actual-clean-ups)))))) (_.cover [/.lift] (thread.run - (do {@ thread.monad} + (do {! thread.monad} [clean-up-counter (thread.box 0) - #let [//@ @] - outcome (/.run @ - (do (/.monad @) + #let [//@ !] + outcome (/.run ! + (do (/.monad !) [_ (/.lift //@ (thread.write expected-clean-ups clean-up-counter))] (wrap []))) actual-clean-ups (thread.read clean-up-counter)] diff --git a/stdlib/source/test/lux/control/state.lux b/stdlib/source/test/lux/control/state.lux index b2a4fba96..ffac9570f 100644 --- a/stdlib/source/test/lux/control/state.lux +++ b/stdlib/source/test/lux/control/state.lux @@ -83,8 +83,8 @@ (def: loops Test - (do {@ random.monad} - [limit (|> random.nat (:: @ map (n.% 10))) + (do {! random.monad} + [limit (|> random.nat (:: ! map (n.% 10))) #let [condition (do /.monad [state /.get] (wrap (n.< limit state)))]] diff --git a/stdlib/source/test/lux/data/collection/dictionary/ordered.lux b/stdlib/source/test/lux/data/collection/dictionary/ordered.lux index e396dd81a..8b32295d9 100644 --- a/stdlib/source/test/lux/data/collection/dictionary/ordered.lux +++ b/stdlib/source/test/lux/data/collection/dictionary/ordered.lux @@ -1,6 +1,5 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract [monad (#+ do)] @@ -11,13 +10,15 @@ ["$." equivalence]]}] [data ["." product] + ["." bit ("#@." equivalence)] + ["." maybe ("#@." monad)] [number ["n" nat]] [collection ["." set] ["." list ("#@." functor)]]] [math - ["r" random (#+ Random) ("#@." monad)]]] + ["." random (#+ Random) ("#@." monad)]]] {1 ["." /]}) @@ -26,26 +27,29 @@ (-> (Order k) (Random k) (Random v) Nat (Random (/.Dictionary k v)))) (case size 0 - (r@wrap (/.new order)) + (random@wrap (/.new order)) _ - (do r.monad + (do random.monad [partial (dictionary order gen-key gen-value (dec size)) - key (r.filter (function (_ candidate) - (not (/.contains? candidate partial))) - gen-key) + key (random.filter (function (_ candidate) + (not (/.contains? candidate partial))) + gen-key) value gen-value] (wrap (/.put key value partial))))) (def: #export test Test - (<| (_.context (%.name (name-of /.Dictionary))) - (do {! r.monad} - [size (|> r.nat (:: ! map (n.% 100))) - keys (r.set n.hash size r.nat) - values (r.set n.hash size r.nat) - extra-key (|> r.nat (r.filter (|>> (set.member? keys) not))) - extra-value r.nat + (<| (_.covering /._) + (_.with-cover [/.Dictionary]) + (do {! random.monad} + [size (:: ! map (n.% 100) random.nat) + keys (random.set n.hash size random.nat) + values (random.set n.hash size random.nat) + extra-key (random.filter (|>> (set.member? keys) not) + random.nat) + extra-value random.nat + shift random.nat #let [pairs (list.zip/2 (set.to-list keys) (set.to-list values)) sample (/.from-list n.order pairs) @@ -53,58 +57,81 @@ (n.< left right)) pairs) sorted-values (list@map product.right sorted-pairs) + (^open "list@.") (list.equivalence (: (Equivalence [Nat Nat]) + (function (_ [kr vr] [ks vs]) + (and (n.= kr ks) + (n.= vr vs))))) (^open "/@.") (/.equivalence n.equivalence)]] ($_ _.and - ($equivalence.spec (/.equivalence n.equivalence) (..dictionary n.order r.nat r.nat size)) + (_.with-cover [/.equivalence] + ($equivalence.spec (/.equivalence n.equivalence) (..dictionary n.order random.nat random.nat size))) - (_.test "Can query the size of a dictionary." - (n.= size (/.size sample))) - (_.test "Can query value for minimum key." - (case [(/.min sample) (list.head sorted-values)] - [#.None #.None] - #1 + (_.cover [/.size] + (n.= size (/.size sample))) + (_.cover [/.empty?] + (bit@= (n.= 0 (/.size sample)) + (/.empty? sample))) + (_.cover [/.new] + (/.empty? (/.new n.order))) + (_.cover [/.min] + (case [(/.min sample) (list.head sorted-values)] + [#.None #.None] + #1 - [(#.Some reference) (#.Some sample)] - (n.= reference sample) + [(#.Some reference) (#.Some sample)] + (n.= reference sample) - _ - #0)) - (_.test "Can query value for maximum key." - (case [(/.max sample) (list.last sorted-values)] - [#.None #.None] - #1 + _ + #0)) + (_.cover [/.max] + (case [(/.max sample) (list.last sorted-values)] + [#.None #.None] + #1 - [(#.Some reference) (#.Some sample)] - (n.= reference sample) + [(#.Some reference) (#.Some sample)] + (n.= reference sample) - _ - #0)) - (_.test "Converting dictionaries to/from lists cannot change their values." - (|> sample - /.entries (/.from-list n.order) - (/@= sample))) - (_.test "Order is preserved." - (let [(^open "list@.") (list.equivalence (: (Equivalence [Nat Nat]) - (function (_ [kr vr] [ks vs]) - (and (n.= kr ks) - (n.= vr vs)))))] - (list@= (/.entries sample) - sorted-pairs))) - (_.test "Every key in a dictionary must be identifiable." - (list.every? (function (_ key) (/.contains? key sample)) - (/.keys sample))) - (_.test "Can add and remove elements in a dictionary." - (and (not (/.contains? extra-key sample)) - (let [sample' (/.put extra-key extra-value sample) - sample'' (/.remove extra-key sample')] - (and (/.contains? extra-key sample') - (not (/.contains? extra-key sample'')) - (case [(/.get extra-key sample') - (/.get extra-key sample'')] - [(#.Some found) #.None] - (n.= extra-value found) - - _ - #0))) - )) + _ + #0)) + (_.cover [/.entries] + (list@= (/.entries sample) + sorted-pairs)) + (_.cover [/.keys /.values] + (list@= (/.entries sample) + (list.zip/2 (/.keys sample) (/.values sample)))) + (_.cover [/.from-list] + (|> sample + /.entries (/.from-list n.order) + (/@= sample))) + (_.cover [/.contains?] + (and (list.every? (function (_ key) (/.contains? key sample)) + (/.keys sample)) + (not (/.contains? extra-key sample)))) + (_.cover [/.put] + (and (not (/.contains? extra-key sample)) + (let [sample+ (/.put extra-key extra-value sample)] + (and (/.contains? extra-key sample+) + (n.= (inc (/.size sample)) + (/.size sample+)))))) + (_.cover [/.get] + (let [sample+ (/.put extra-key extra-value sample)] + (case [(/.get extra-key sample) + (/.get extra-key sample+)] + [#.None (#.Some actual)] + (n.= extra-value actual) + + _ + false))) + (_.cover [/.remove] + (|> sample + (/.put extra-key extra-value) + (/.remove extra-key) + (/@= sample))) + (_.cover [/.update] + (|> sample + (/.put extra-key extra-value) + (/.update extra-key (n.+ shift)) + (/.get extra-key) + (maybe@map (n.= (n.+ shift extra-value))) + (maybe.default false))) )))) diff --git a/stdlib/source/test/lux/host.js.lux b/stdlib/source/test/lux/host.js.lux index 9112716ca..507cda9ff 100644 --- a/stdlib/source/test/lux/host.js.lux +++ b/stdlib/source/test/lux/host.js.lux @@ -38,11 +38,11 @@ (def: #export test Test - (do {@ random.monad} + (do {! random.monad} [boolean random.bit - number (:: @ map (|>> (nat.% 100) nat.frac) random.nat) + number (:: ! map (|>> (nat.% 100) nat.frac) random.nat) string (random.ascii 5) - function (:: @ map (function (_ shift) + function (:: ! map (function (_ shift) (: (-> Nat Nat) (nat.+ shift))) random.nat) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux index 5f8e46d3c..0a59b5534 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/case.lux @@ -41,9 +41,9 @@ (def: masking-test Test - (do {@ random.monad} + (do {! random.monad} [maskedA //primitive.primitive - temp (|> random.nat (:: @ map (n.% 100))) + temp (|> random.nat (:: ! map (n.% 100))) #let [maskA (analysis.control/case [maskedA [[(#analysis.Bind temp) @@ -109,8 +109,8 @@ (def: random-member (Random synthesis.Member) - (do {@ random.monad} - [lefts (|> random.nat (:: @ map (n.% 10))) + (do {! random.monad} + [lefts (|> random.nat (:: ! map (n.% 10))) right? random.bit] (wrap (if right? (#.Right lefts) @@ -118,8 +118,8 @@ (def: random-path (Random (analysis.Tuple synthesis.Member)) - (do {@ random.monad} - [size-1 (|> random.nat (:: @ map (|>> (n.% 10) inc)))] + (do {! random.monad} + [size-1 (|> random.nat (:: ! map (|>> (n.% 10) inc)))] (random.list size-1 ..random-member))) (def: (get-pattern path) @@ -144,11 +144,11 @@ (def: get-test Test - (do {@ random.monad} + (do {! random.monad} [recordA (|> random.nat - (:: @ map (|>> analysis.nat)) + (:: ! map (|>> analysis.nat)) (random.list 10) - (:: @ map (|>> analysis.tuple))) + (:: ! map (|>> analysis.tuple))) pathA ..random-path [pattern @member] (get-pattern pathA) #let [getA (analysis.control/case [recordA [[pattern @@ -167,7 +167,7 @@ (def: random-bit (Random [Path Match]) - (do {@ random.monad} + (do {! random.monad} [test random.bit then random.nat else random.nat] @@ -194,7 +194,7 @@ (template [<name> <hash> <random> <path> <synthesis> <pattern> <analysis>] [(def: <name> (Random [Path Match]) - (do {@ random.monad} + (do {! random.monad} [[test/0 test/1 test/2 test/3 test/4] (random-five <hash> <random>) [body/0 body/1 body/2 body/3 body/4] (random-five <hash> <random>)] (wrap [($_ #synthesis.Alt @@ -228,7 +228,7 @@ (def: random-variant (Random [Path Match]) - (do {@ random.monad} + (do {! random.monad} [[lefts/0 lefts/1 lefts/2 lefts/3 lefts/4] (random-five n.hash random.nat) [value/0 value/1 value/2 value/3 value/4] (random-five text.hash (random.unicode 1)) last-is-right? random.bit @@ -261,8 +261,8 @@ (def: random-tuple (Random [Path Match]) - (do {@ random.monad} - [mid-size (:: @ map (n.% 4) random.nat) + (do {! random.monad} + [mid-size (:: ! map (n.% 4) random.nat) value/first (random.unicode 1) value/mid (random.list mid-size (random.unicode 1)) @@ -327,8 +327,8 @@ (def: case-test Test - (do {@ random.monad} - [expected-input (:: @ map (|>> .i64 synthesis.i64) random.nat) + (do {! random.monad} + [expected-input (:: ! map (|>> .i64 synthesis.i64) random.nat) [expected-path match] ..random-case] (_.cover [/.synthesize-case] (|> (/.synthesize-case //.phase archive.empty expected-input match) diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux index eaca9c528..4d92094d3 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/function.lux @@ -88,7 +88,7 @@ (template [<name> <random> <synthesis> <analysis>] [(def: (<name> output?) Scenario - (do {@ random.monad} + (do {! random.monad} [value <random>] (wrap [true (<synthesis> value) @@ -114,7 +114,7 @@ (def: (random-variant random-value output?) (-> Scenario Scenario) - (do {@ random.monad} + (do {! random.monad} [lefts random.nat right? random.bit [loop? expected-value actual-value] (random-value false)] @@ -130,7 +130,7 @@ (def: (random-tuple random-value output?) (-> Scenario Scenario) - (do {@ random.monad} + (do {! random.monad} [[loop?-left expected-left actual-left] (random-value false) [loop?-right expected-right actual-right] (random-value false)] (wrap [(and loop?-left @@ -146,8 +146,8 @@ (def: (random-variable arity output?) (-> Arity Scenario) - (do {@ random.monad} - [register (:: @ map (|>> (n.% arity) inc) random.nat)] + (do {! random.monad} + [register (:: ! map (|>> (n.% arity) inc) random.nat)] (wrap [(not (n.= 0 register)) (synthesis.variable/local register) (if (n.= arity register) @@ -156,7 +156,7 @@ (def: (random-constant output?) Scenario - (do {@ random.monad} + (do {! random.monad} [module (random.unicode 1) short (random.unicode 1)] (wrap [true @@ -170,14 +170,14 @@ (def: (random-case arity random-value output?) (-> Arity Scenario Scenario) - (do {@ random.monad} + (do {! random.monad} [bit-test random.bit i64-test random.nat f64-test random.frac text-test (random.unicode 1) [loop?-input expected-input actual-input] (random-value false) [loop?-output expected-output actual-output] (random-value output?) - lefts (|> random.nat (:: @ map (n.% 10))) + lefts (|> random.nat (:: ! map (n.% 10))) right? random.bit #let [side|member (if right? (#.Right lefts) @@ -238,7 +238,7 @@ (def: (random-let arity random-value output?) (-> Arity Scenario Scenario) - (do {@ random.monad} + (do {! random.monad} [[loop?-input expected-input actual-input] (random-value false) [loop?-output expected-output actual-output] (random-value output?)] (wrap [(and loop?-input @@ -253,7 +253,7 @@ (def: (random-if random-value output?) (-> Scenario Scenario) - (do {@ random.monad} + (do {! random.monad} [[loop?-test expected-test actual-test] (random-value false) [loop?-then expected-then actual-then] (random-value output?) [loop?-else expected-else actual-else] (random-value output?) @@ -278,8 +278,8 @@ (def: (random-get random-value output?) (-> Scenario Scenario) - (do {@ random.monad} - [lefts (|> random.nat (:: @ map (n.% 10))) + (do {! random.monad} + [lefts (|> random.nat (:: ! map (n.% 10))) right? random.bit [loop?-record expected-record actual-record] (random-value false)] (wrap [loop?-record @@ -305,7 +305,7 @@ (def: (random-recur arity random-value output?) (-> Arity Scenario Scenario) - (do {@ random.monad} + (do {! random.monad} [resets (random.list arity (random-value false))] (wrap [true (synthesis.loop/recur (list@map (|>> product.right product.left) resets)) @@ -316,7 +316,7 @@ (def: (random-scope arity output?) (-> Arity Scenario) - (do {@ random.monad} + (do {! random.monad} [resets (random.list arity (..random-variable arity output?)) [_ expected-output actual-output] (..random-nat output?)] (wrap [(list@fold (function (_ new old) @@ -341,9 +341,9 @@ (def: (random-abstraction' output?) Scenario - (do {@ random.monad} + (do {! random.monad} [[loop?-output expected-output actual-output] (..random-nat output?) - arity (|> random.nat (:: @ map (|>> (n.% 5) inc))) + arity (|> random.nat (:: ! map (|>> (n.% 5) inc))) #let [environment ($_ list@compose (list@map (|>> #variable.Foreign) (list.indices arity)) @@ -361,9 +361,9 @@ (def: (random-apply random-value output?) (-> Scenario Scenario) - (do {@ random.monad} + (do {! random.monad} [[loop?-abstraction expected-abstraction actual-abstraction] (..random-nat output?) - arity (|> random.nat (:: @ map (|>> (n.% 5) inc))) + arity (|> random.nat (:: ! map (|>> (n.% 5) inc))) inputs (random.list arity (random-value false))] (wrap [(list@fold (function (_ new old) (and new old)) @@ -393,7 +393,7 @@ (def: (random-extension random-value output?) (-> Scenario Scenario) - (do {@ random.monad} + (do {! random.monad} [name (random.unicode 1) [loop?-first expected-first actual-first] (random-value false) [loop?-second expected-second actual-second] (random-value false) @@ -418,8 +418,8 @@ (def: random-abstraction (Random [Synthesis Analysis]) - (do {@ random.monad} - [arity (|> random.nat (:: @ map (|>> (n.% 5) inc))) + (do {! random.monad} + [arity (|> random.nat (:: ! map (|>> (n.% 5) inc))) [loop? expected-body actual-body] (random-body arity true)] (wrap [(..n-function loop? arity expected-body) (..n-abstraction arity actual-body)]))) @@ -437,8 +437,8 @@ (def: application Test - (do {@ random.monad} - [arity (|> random.nat (:: @ map (|>> (n.% 10) (n.max 1)))) + (do {! random.monad} + [arity (|> random.nat (:: ! map (|>> (n.% 10) (n.max 1)))) funcA //primitive.primitive argsA (random.list arity //primitive.primitive)] (_.cover [/.apply] diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/structure.lux b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/structure.lux index 24adb599c..d759ff213 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/structure.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/phase/synthesis/structure.lux @@ -34,9 +34,9 @@ (def: variant Test - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.+ 2)))) - tagA (|> r.nat (:: @ map (n.% size))) + (do {! r.monad} + [size (|> r.nat (:: ! map (|>> (n.% 10) (n.+ 2)))) + tagA (|> r.nat (:: ! map (n.% size))) #let [right? (n.= (dec size) tagA) lefts (if right? (dec tagA) @@ -57,8 +57,8 @@ (def: tuple Test - (do {@ r.monad} - [size (|> r.nat (:: @ map (|>> (n.% 10) (n.max 2)))) + (do {! r.monad} + [size (|> r.nat (:: ! map (|>> (n.% 10) (n.max 2)))) membersA (r.list size //primitive.primitive)] (_.test "Can synthesize tuple." (|> (////analysis.tuple membersA) diff --git a/stdlib/source/test/lux/type/check.lux b/stdlib/source/test/lux/type/check.lux index d4bf9ed8e..ccd44ed89 100644 --- a/stdlib/source/test/lux/type/check.lux +++ b/stdlib/source/test/lux/type/check.lux @@ -29,26 +29,37 @@ (r.Random Name) (r.and ..short ..short)) +(def: (type' num-vars) + (-> Nat (r.Random Type)) + (do r.monad + [_ (wrap [])] + (let [(^open "R@.") r.monad + pairG (r.and (type' num-vars) + (type' num-vars)) + quantifiedG (r.and (R@wrap (list)) (type' (n.+ 2 num-vars))) + random-pair (r.either (r.either (R@map (|>> #.Sum) pairG) + (R@map (|>> #.Product) pairG)) + (r.either (R@map (|>> #.Function) pairG) + (R@map (|>> #.Apply) pairG))) + random-id (let [random-id (r.either (R@map (|>> #.Var) r.nat) + (R@map (|>> #.Ex) r.nat))] + (case num-vars + 0 random-id + _ (r.either (R@map (|>> (n.% num-vars) #.Parameter) r.nat) + random-id))) + random-quantified (r.either (R@map (|>> #.UnivQ) quantifiedG) + (R@map (|>> #.ExQ) quantifiedG))] + ($_ r.either + (R@map (|>> #.Primitive) (r.and ..short (R@wrap (list)))) + random-pair + random-id + random-quantified + (R@map (|>> #.Named) (r.and ..name (type' num-vars))) + )))) + (def: type (r.Random Type) - (let [(^open "R@.") r.monad] - (r.rec (function (_ recur) - (let [pairG (r.and recur recur) - idG r.nat - quantifiedG (r.and (R@wrap (list)) recur)] - ($_ r.or - (r.and ..short (R@wrap (list))) - pairG - pairG - pairG - idG - idG - idG - quantifiedG - quantifiedG - pairG - (r.and ..name recur) - )))))) + (..type' 0)) (def: (valid-type? type) (-> Type Bit) |