diff options
author | Eduardo Julian | 2020-10-24 21:44:21 -0400 |
---|---|---|
committer | Eduardo Julian | 2020-10-24 21:44:21 -0400 |
commit | e153b011bb94ba95474505c307873616bb493b6d (patch) | |
tree | b68a68723bd33a19264c2ec83b379b07fbf30420 /stdlib/source | |
parent | 0ebabc6e307d161ac4ef837aa492066d4320f6a9 (diff) |
Changed type-parameters for Mixin types.
Diffstat (limited to '')
-rw-r--r-- | stdlib/source/lux/abstract/hash.lux | 19 | ||||
-rw-r--r-- | stdlib/source/lux/control/function/memo.lux | 2 | ||||
-rw-r--r-- | stdlib/source/lux/control/function/mixin.lux | 18 | ||||
-rw-r--r-- | stdlib/source/lux/data/collection/queue.lux | 30 | ||||
-rw-r--r-- | stdlib/source/lux/world/file.lux | 456 | ||||
-rw-r--r-- | stdlib/source/program/aedifex.lux | 46 | ||||
-rw-r--r-- | stdlib/source/program/aedifex/command/pom.lux | 35 | ||||
-rw-r--r-- | stdlib/source/test/aedifex.lux | 3 | ||||
-rw-r--r-- | stdlib/source/test/aedifex/command/pom.lux | 67 | ||||
-rw-r--r-- | stdlib/source/test/aedifex/parser.lux | 12 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/function/memo.lux | 2 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/function/mixin.lux | 18 | ||||
-rw-r--r-- | stdlib/source/test/lux/control/parser/analysis.lux | 2 | ||||
-rw-r--r-- | stdlib/source/test/lux/data/collection/list.lux | 61 | ||||
-rw-r--r-- | stdlib/source/test/lux/data/collection/queue.lux | 138 |
15 files changed, 768 insertions, 141 deletions
diff --git a/stdlib/source/lux/abstract/hash.lux b/stdlib/source/lux/abstract/hash.lux index 62e72e52a..df2dd2e27 100644 --- a/stdlib/source/lux/abstract/hash.lux +++ b/stdlib/source/lux/abstract/hash.lux @@ -11,14 +11,29 @@ (: (-> a Nat) hash)) +(def: #export (sum left right) + (All [l r] (-> (Hash l) (Hash r) (Hash (| l r)))) + (structure + (def: &equivalence + (equivalence.sum (:: left &equivalence) + (:: right &equivalence))) + (def: (hash value) + (<| (:coerce Nat) + (case value + (#.Left value) + ("lux i64 *" +2 (:coerce Int (:: left hash value))) + + (#.Right value) + ("lux i64 *" +3 (:coerce Int (:: right hash value)))))))) + (def: #export (product left right) - (All [l r] (-> (Hash l) (Hash r) (Hash [l r]))) + (All [l r] (-> (Hash l) (Hash r) (Hash (& l r)))) (structure (def: &equivalence (equivalence.product (:: left &equivalence) (:: right &equivalence))) (def: (hash [leftV rightV]) (:coerce Nat - ("lux i64 *" + ("lux i64 +" (:coerce Int (:: left hash leftV)) (:coerce Int (:: right hash rightV))))))) diff --git a/stdlib/source/lux/control/function/memo.lux b/stdlib/source/lux/control/function/memo.lux index fb6456699..c03237cf8 100644 --- a/stdlib/source/lux/control/function/memo.lux +++ b/stdlib/source/lux/control/function/memo.lux @@ -17,7 +17,7 @@ (def: #export memoization (All [i o] - (Mixin (-> i (State (Dictionary i o) o)))) + (Mixin i (State (Dictionary i o) o))) (function (_ delegate recur) (function (_ input) (do {@ state.monad} diff --git a/stdlib/source/lux/control/function/mixin.lux b/stdlib/source/lux/control/function/mixin.lux index 328115ec4..f10123aa6 100644 --- a/stdlib/source/lux/control/function/mixin.lux +++ b/stdlib/source/lux/control/function/mixin.lux @@ -8,11 +8,11 @@ [predicate (#+ Predicate)] [monad (#+ Monad do)]]]) -(type: #export (Mixin m) - (-> m m m)) +(type: #export (Mixin i o) + (-> (-> i o) (-> i o) (-> i o))) (def: #export (mixin f) - (All [i o] (-> (Mixin (-> i o)) (-> i o))) + (All [i o] (-> (Mixin i o) (-> i o))) (function (mix input) ((f mix mix) input))) @@ -22,32 +22,32 @@ delegate)) (def: #export (inherit parent child) - (All [m] (-> (Mixin m) (Mixin m) (Mixin m))) + (All [i o] (-> (Mixin i o) (Mixin i o) (Mixin i o))) (function (_ delegate recur) (parent (child delegate recur) recur))) (structure: #export monoid - (All [m] (Monoid (Mixin m))) + (All [i o] (Monoid (Mixin i o))) (def: identity ..nothing) (def: compose ..inherit)) (def: #export (advice when then) - (All [i o] (-> (Predicate i) (Mixin (-> i o)) (Mixin (-> i o)))) + (All [i o] (-> (Predicate i) (Mixin i o) (Mixin i o))) (function (_ delegate recur input) (if (when input) ((then delegate recur) input) (delegate input)))) (def: #export (before monad action) - (All [! i o] (-> (Monad !) (-> i (! Any)) (Mixin (-> i (! o))))) + (All [! i o] (-> (Monad !) (-> i (! Any)) (Mixin i (! o)))) (function (_ delegate recur input) (do monad [_ (action input)] (delegate input)))) (def: #export (after monad action) - (All [! i o] (-> (Monad !) (-> i o (! Any)) (Mixin (-> i (! o))))) + (All [! i o] (-> (Monad !) (-> i o (! Any)) (Mixin i (! o)))) (function (_ delegate recur input) (do monad [output (delegate input) @@ -58,6 +58,6 @@ (-> (-> i o) (-> i o))) (def: #export (from-recursive recursive) - (All [i o] (-> (Recursive i o) (Mixin (-> i o)))) + (All [i o] (-> (Recursive i o) (Mixin i o))) (function (_ delegate recur) (recursive recur))) diff --git a/stdlib/source/lux/data/collection/queue.lux b/stdlib/source/lux/data/collection/queue.lux index c0e16ee29..b3d384f6d 100644 --- a/stdlib/source/lux/data/collection/queue.lux +++ b/stdlib/source/lux/data/collection/queue.lux @@ -42,24 +42,27 @@ (All [a] (-> (Queue a) Bit)) (|>> (get@ #front) list.empty?)) -(def: #export (member? Equivalence<a> queue member) +(def: #export (member? equivalence queue member) (All [a] (-> (Equivalence a) (Queue a) a Bit)) (let [(^slots [#front #rear]) queue] - (or (list.member? Equivalence<a> front member) - (list.member? Equivalence<a> rear member)))) + (or (list.member? equivalence front member) + (list.member? equivalence rear member)))) (def: #export (pop queue) (All [a] (-> (Queue a) (Queue a))) (case (get@ #front queue) - (^ (list)) ## Empty... + ## Empty... + (^ (list)) queue - (^ (list _)) ## Front has dried up... + ## Front has dried up... + (^ (list _)) (|> queue (set@ #front (list.reverse (get@ #rear queue))) (set@ #rear (list))) - - (^ (list& _ front')) ## Consume front! + + ## Consume front! + (^ (list& _ front')) (|> queue (set@ #front front')))) @@ -72,12 +75,17 @@ _ (update@ #rear (|>> (#.Cons val)) queue))) -(structure: #export (equivalence Equivalence<a>) +(structure: #export (equivalence super) (All [a] (-> (Equivalence a) (Equivalence (Queue a)))) - (def: (= qx qy) - (:: (list.equivalence Equivalence<a>) = (to-list qx) (to-list qy)))) + + (def: (= reference subject) + (:: (list.equivalence super) = + (..to-list reference) + (..to-list subject)))) -(structure: #export functor (Functor Queue) +(structure: #export functor + (Functor Queue) + (def: (map f fa) {#front (|> fa (get@ #front) (list@map f)) #rear (|> fa (get@ #rear) (list@map f))})) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 81ab60faa..c21d20d80 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -8,8 +8,10 @@ ["." try (#+ Try) ("#@." functor)] ["." exception (#+ Exception exception:)] ["." io (#+ IO) ("#@." functor)] + ["." function] [concurrency - ["." promise (#+ Promise)]] + ["." promise (#+ Promise)] + ["." stm (#+ Var STM)]] [security ["!" capability (#+ capability:)]]] [data @@ -23,7 +25,8 @@ ["f" frac]] [collection ["." array (#+ Array)] - ["." list ("#@." functor)]]] + ["." list ("#@." functor)] + ["." dictionary (#+ Dictionary)]]] [time ["." instant (#+ Instant)] ["." duration]] @@ -194,6 +197,7 @@ [cannot-create-file] [cannot-find-file] [cannot-delete-file] + [not-a-file] [cannot-create-directory] [cannot-find-directory] @@ -674,3 +678,451 @@ (#try.Failure _) (wrap false)))))) + +(type: Mock-File + {#mock-last-modified Instant + #mock-can-execute Bit + #mock-content Binary}) + +(type: #rec Mock + (Dictionary Text (Either Mock-File Mock))) + +(def: empty-mock + Mock + (dictionary.new text.hash)) + +(def: (create-mock-file! separator path now mock) + (-> Text Path Instant Mock (Try [Text Mock])) + (loop [directory mock + trail (text.split-all-with separator path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (case tail + #.Nil + (#try.Success [head (dictionary.put head + (#.Left {#mock-last-modified now + #mock-can-execute false + #mock-content (binary.create 0)}) + directory)]) + + (#.Cons _) + (exception.throw ..cannot-create-file [path])) + + (#.Some node) + (case [node tail] + [(#.Right sub-directory) (#.Cons _)] + (do try.monad + [[file-name sub-directory] (recur sub-directory tail)] + (wrap [file-name (dictionary.put head (#.Right sub-directory) directory)])) + + _ + (exception.throw ..cannot-create-file [path]))) + + #.Nil + (exception.throw ..cannot-create-file [path])))) + +(def: (retrieve-mock-file! separator path mock) + (-> Text Path Mock (Try [Text Mock-File])) + (loop [directory mock + trail (text.split-all-with separator path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot-find-file [path]) + + (#.Some node) + (case [node tail] + [(#.Left file) #.Nil] + (#try.Success [head file]) + + [(#.Right sub-directory) (#.Cons _)] + (recur sub-directory tail) + + _ + (exception.throw ..cannot-find-file [path]))) + + #.Nil + (exception.throw ..not-a-file [path])))) + +(def: (update-mock-file! separator path now content mock) + (-> Text Path Instant Binary Mock (Try Mock)) + (loop [directory mock + trail (text.split-all-with separator path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot-find-file [path]) + + (#.Some node) + (case [node tail] + [(#.Left file) #.Nil] + (#try.Success (dictionary.put head + (#.Left (|> file + (set@ #mock-last-modified now) + (set@ #mock-content content))) + directory)) + + [(#.Right sub-directory) (#.Cons _)] + (do try.monad + [sub-directory (recur sub-directory tail)] + (wrap (dictionary.put head (#.Right sub-directory) directory))) + + _ + (exception.throw ..cannot-find-file [path]))) + + #.Nil + (exception.throw ..cannot-find-file [path])))) + +(def: (delete-mock-file! separator path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split-all-with separator path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot-delete-file [path]) + + (#.Some node) + (case [node tail] + [(#.Left file) #.Nil] + (#try.Success (dictionary.remove head directory)) + + [(#.Right sub-directory) (#.Cons _)] + (do try.monad + [sub-directory (recur sub-directory tail)] + (wrap (dictionary.put head (#.Right sub-directory) directory))) + + _ + (exception.throw ..cannot-delete-file [path]))) + + #.Nil + (exception.throw ..cannot-delete-file [path])))) + +(def: (try-update! transform var) + (All [a] (-> (-> a (Try a)) (Var a) (STM (Try Any)))) + (do {@ stm.monad} + [|var| (stm.read var)] + (case (transform |var|) + (#try.Success |var|) + (do @ + [_ (stm.write |var| var)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error))))) + +(def: (mock-file separator name path store) + (-> Text Text Path (Var Mock) (File Promise)) + (structure + (def: name + (..can-see + (function.constant name))) + + (def: path + (..can-see + (function.constant path))) + + (def: size + (..can-query + (function (_ _) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [[name file] (..retrieve-mock-file! separator path |store|)] + (wrap (binary.size (get@ #mock-content file)))))))))) + + (def: content + (..can-query + (function (_ _) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [[name file] (..retrieve-mock-file! separator path |store|)] + (wrap (get@ #mock-content file))))))))) + + (def: last-modified + (..can-query + (function (_ _) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [[name file] (..retrieve-mock-file! separator path |store|)] + (wrap (get@ #mock-last-modified file))))))))) + + (def: can-execute? + (..can-query + (function (_ _) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [[name file] (..retrieve-mock-file! separator path |store|)] + (wrap (get@ #mock-can-execute file))))))))) + + (def: over-write + (..can-modify + (function (_ content) + (do promise.monad + [now (promise.future instant.now)] + (stm.commit + (..try-update! (..update-mock-file! separator path now content) store)))))) + + (def: append + (..can-modify + (function (_ content) + (do promise.monad + [now (promise.future instant.now)] + (stm.commit + (..try-update! (function (_ |store|) + (do try.monad + [[name file] (..retrieve-mock-file! separator path |store|)] + (..update-mock-file! separator path now + (:: binary.monoid compose + (get@ #mock-content file) + content) + |store|))) + store)))))) + + (def: modify + (..can-modify + (function (_ now) + (stm.commit + (..try-update! (function (_ |store|) + (do try.monad + [[name file] (..retrieve-mock-file! separator path |store|)] + (..update-mock-file! separator path now (get@ #mock-content file) |store|))) + store))))) + + (def: delete + (..can-delete + (function (_ _) + (stm.commit + (..try-update! (..delete-mock-file! separator path) store))))) + + (def: move + (..can-open + (function (_ path) + (stm.commit + (do {@ stm.monad} + [|store| (stm.read store)] + (case (do try.monad + [[name file] (..retrieve-mock-file! separator path |store|) + |store| (..delete-mock-file! separator path |store|) + [name |store|] (..create-mock-file! separator path (get@ #mock-last-modified file) |store|) + |store| (..update-mock-file! separator path (get@ #mock-last-modified file) (get@ #mock-content file) |store|)] + (wrap [|store| (mock-file separator name path store)])) + (#try.Success [|store| moved]) + (do @ + [_ (stm.write |store| store)] + (wrap (#try.Success moved))) + + (#try.Failure error) + (wrap (#try.Failure error)))))))) + )) + +(def: (create-mock-directory! separator path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split-all-with separator path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (case tail + #.Nil + (#try.Success (dictionary.put head (#.Right ..empty-mock) directory)) + + (#.Cons _) + (exception.throw ..cannot-create-directory [path])) + + (#.Some node) + (case [node tail] + [(#.Right sub-directory) (#.Cons _)] + (do try.monad + [sub-directory (recur sub-directory tail)] + (wrap (dictionary.put head (#.Right sub-directory) directory))) + + _ + (exception.throw ..cannot-create-directory [path]))) + + #.Nil + (exception.throw ..cannot-create-directory [path])))) + +(def: (retrieve-mock-directory! separator path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split-all-with separator path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot-find-directory [path]) + + (#.Some node) + (case [node tail] + [(#.Right sub-directory) #.Nil] + (#try.Success sub-directory) + + [(#.Right sub-directory) (#.Cons _)] + (recur sub-directory tail) + + _ + (exception.throw ..cannot-find-directory [path]))) + + #.Nil + (#try.Success directory)))) + +(def: (delete-mock-directory! separator path mock) + (-> Text Path Mock (Try Mock)) + (loop [directory mock + trail (text.split-all-with separator path)] + (case trail + (#.Cons head tail) + (case (dictionary.get head directory) + #.None + (exception.throw ..cannot-discard-directory [path]) + + (#.Some node) + (case [node tail] + [(#.Right directory) #.Nil] + (if (dictionary.empty? directory) + (#try.Success (dictionary.remove head directory)) + (exception.throw ..cannot-discard-directory [path])) + + [(#.Right sub-directory) (#.Cons _)] + (do try.monad + [sub-directory (recur sub-directory tail)] + (wrap (dictionary.put head (#.Right sub-directory) directory))) + + _ + (exception.throw ..cannot-discard-directory [path]))) + + #.Nil + (exception.throw ..cannot-discard-directory [path])))) + +(def: (mock-directory separator path store) + (-> Text Path (Var Mock) (Directory Promise)) + (structure + (def: files + (..can-query + (function (_ _) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [directory (..retrieve-mock-directory! separator path |store|)] + (wrap (|> directory + dictionary.entries + (list.all (function (_ [node-name node]) + (case node + (#.Left file) + (#.Some (..mock-file separator + node-name + (format path separator node-name) + store)) + + (#.Right directory) + #.None)))))))))))) + + (def: directories + (..can-query + (function (_ _) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [directory (..retrieve-mock-directory! separator path |store|)] + (wrap (|> directory + dictionary.entries + (list.all (function (_ [node-name node]) + (case node + (#.Left file) + #.None + + (#.Right directory) + (#.Some (mock-directory separator + (format path separator node-name) + store)))))))))))))) + + (def: discard + (..can-delete + (function (_ _) + (stm.commit + (do {@ stm.monad} + [|store| (stm.read store)] + (case (..delete-mock-directory! separator path |store|) + (#try.Success |store|) + (do @ + [_ (stm.write |store| store)] + (wrap (#try.Success []))) + + (#try.Failure error) + (wrap (#try.Failure error)))))))) + )) + +(def: #export (mock separator) + (-> Text (System Promise)) + (let [store (stm.var ..empty-mock)] + (structure + (def: separator separator) + + (def: file + (..can-open + (function (_ path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [[name file] (..retrieve-mock-file! separator path |store|)] + (wrap (..mock-file separator name path store))))))))) + + (def: create-file + (..can-open + (function (_ path) + (do promise.monad + [now (promise.future instant.now)] + (stm.commit + (do {@ stm.monad} + [|store| (stm.read store)] + (case (..create-mock-file! separator path now |store|) + (#try.Success [name |store|]) + (do @ + [_ (stm.write |store| store)] + (wrap (#try.Success (..mock-file separator name path store)))) + + (#try.Failure error) + (wrap (#try.Failure error))))))))) + + (def: directory + (..can-open + (function (_ path) + (stm.commit + (do stm.monad + [|store| (stm.read store)] + (wrap (do try.monad + [directory (..retrieve-mock-directory! separator path |store|)] + (wrap (..mock-directory separator path store))))))))) + + (def: create-directory + (..can-open + (function (_ path) + (stm.commit + (do {@ stm.monad} + [|store| (stm.read store)] + (case (..create-mock-directory! separator path |store|) + (#try.Success _) + (do @ + [_ (stm.write |store| store)] + (wrap (#try.Success (..mock-directory separator path store)))) + + (#try.Failure error) + (wrap (#try.Failure error)))))))) + ))) diff --git a/stdlib/source/program/aedifex.lux b/stdlib/source/program/aedifex.lux index f23ac26da..327eb8902 100644 --- a/stdlib/source/program/aedifex.lux +++ b/stdlib/source/program/aedifex.lux @@ -39,11 +39,12 @@ ["#." local] ["#." dependency #_ ["#" resolution]] - [command - ["#." build] - ["#." test] - ["#." auto] - ["#." deploy]]]) + ["#." command + ["#/." pom] + ["#/." build] + ["#/." test] + ["#/." auto] + ["#/." deploy]]]) (def: (read-file! path) (-> Path (IO (Try Binary))) @@ -65,28 +66,6 @@ (#.Right [end lux-code]) (#try.Success lux-code)))) -(def: (write-pom!' path profile) - (-> Path /.Profile (IO (Try Any))) - (do (try.with io.monad) - [file (!.use (:: file.system file) [path]) - pom (:: io.monad wrap (/pom.write profile))] - (|> pom - (:: xml.codec encode) - encoding.to-utf8 - (!.use (:: file over-write))))) - -(def: (write-pom! profile) - (-> /.Profile (IO Any)) - (do io.monad - [outcome (write-pom!' /pom.file profile)] - (case outcome - (#try.Success value) - (wrap (log! "Successfully wrote POM file!")) - - (#try.Failure error) - (wrap (log! (format "Could not write POM file:" text.new-line - error)))))) - (def: (install! profile) (-> /.Profile (Promise Any)) (do promise.monad @@ -137,7 +116,8 @@ (#try.Success profile) (case operation #/cli.POM - (..write-pom! profile) + (exec (/command/pom.do! (file.async file.system) profile) + (wrap [])) #/cli.Dependencies (exec (..fetch-dependencies! profile) @@ -148,20 +128,20 @@ (wrap [])) (#/cli.Deploy repository user password) - (exec (/deploy.do! repository user password profile) + (exec (/command/deploy.do! repository user password profile) (wrap [])) (#/cli.Compilation compilation) (case compilation - #/cli.Build (exec (/build.do! profile) + #/cli.Build (exec (/command/build.do! profile) (wrap [])) - #/cli.Test (exec (/test.do! profile) + #/cli.Test (exec (/command/test.do! profile) (wrap []))) (#/cli.Auto auto) (exec (case auto - #/cli.Build (/auto.do! /build.do! profile) - #/cli.Test (/auto.do! /test.do! profile)) + #/cli.Build (/command/auto.do! /command/build.do! profile) + #/cli.Test (/command/auto.do! /command/test.do! profile)) (wrap []))) (#try.Failure error) diff --git a/stdlib/source/program/aedifex/command/pom.lux b/stdlib/source/program/aedifex/command/pom.lux new file mode 100644 index 000000000..f493092a5 --- /dev/null +++ b/stdlib/source/program/aedifex/command/pom.lux @@ -0,0 +1,35 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try)] + [security + ["!" capability]] + [concurrency + ["." promise (#+ Promise) ("#@." monad)]]] + [data + ["." text + ["%" format (#+ format)] + ["." encoding]] + [format + ["." xml]]] + [world + ["." file (#+ Path File)]]] + ["." /// #_ + [command (#+ Command)] + ["#." action (#+ Action)] + ["#." pom]]) + +(def: #export (do! fs profile) + (-> (file.System Promise) (Command Path)) + (do ///action.monad + [pom (promise@wrap (///pom.write profile)) + file (: (Promise (Try (File Promise))) + (file.get-file promise.monad fs ///pom.file)) + outcome (|> pom + (:: xml.codec encode) + encoding.to-utf8 + (!.use (:: file over-write))) + #let [_ (log! "Successfully wrote POM file!")]] + (wrap ///pom.file))) diff --git a/stdlib/source/test/aedifex.lux b/stdlib/source/test/aedifex.lux index f4abc3887..50d194e43 100644 --- a/stdlib/source/test/aedifex.lux +++ b/stdlib/source/test/aedifex.lux @@ -7,6 +7,8 @@ [cli (#+ program:)]]]] ["." / #_ ["#." artifact] + ["#." command #_ + ["#/." pom]] ["#." dependency] ["#." profile] ["#." project] @@ -19,6 +21,7 @@ Test ($_ _.and /artifact.test + /command/pom.test /dependency.test /profile.test /project.test diff --git a/stdlib/source/test/aedifex/command/pom.lux b/stdlib/source/test/aedifex/command/pom.lux new file mode 100644 index 000000000..1bb098de0 --- /dev/null +++ b/stdlib/source/test/aedifex/command/pom.lux @@ -0,0 +1,67 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [control + ["." try (#+ Try) ("#@." functor)] + [concurrency + ["." promise (#+ Promise)]] + [security + ["!" capability]]] + [data + ["." binary] + ["." text ("#@." equivalence) + ["." encoding]] + [format + ["." xml]]] + [math + ["." random (#+ Random)]] + [world + ["." file (#+ File)]]] + [/// + ["@." profile]] + {#program + ["." / + ["//#" /// #_ + ["#" profile] + ["#." action] + ["#." pom]]]}) + +(def: #export test + Test + (<| (_.covering /._) + (do random.monad + [sample @profile.random + #let [fs (file.mock (:: file.system separator))]] + (wrap (do {@ promise.monad} + [outcome (/.do! fs sample)] + (case outcome + (#try.Success path) + (do @ + [verdict (do ///action.monad + [expected (|> (///pom.write sample) + (try@map (|>> (:: xml.codec encode) encoding.to-utf8)) + (:: @ wrap)) + file (: (Promise (Try (File Promise))) + (file.get-file promise.monad fs path)) + actual (!.use (:: file content) []) + + #let [expected-path! + (text@= ///pom.file path) + + expected-content! + (:: binary.equivalence = expected actual)]] + (wrap (and expected-path! + expected-content!)))] + (_.claim [/.do!] + (try.default false verdict))) + + (#try.Failure error) + (_.claim [/.do!] + (case (get@ #///.identity sample) + (#.Some _) + false + + #.None + true)))))))) diff --git a/stdlib/source/test/aedifex/parser.lux b/stdlib/source/test/aedifex/parser.lux index a171e694d..0c85156d2 100644 --- a/stdlib/source/test/aedifex/parser.lux +++ b/stdlib/source/test/aedifex/parser.lux @@ -22,7 +22,7 @@ [macro ["." code]]] [// - ["_." profile]] + ["@." profile]] {#program ["." / ["/#" // #_ @@ -48,9 +48,9 @@ (dictionary.from-list key-hash) (..list-of (random.and key-random value-random)))) -(def: project +(def: random (Random Project) - (..dictionary-of text.hash ..name _profile.random)) + (..dictionary-of text.hash ..name @profile.random)) (def: with-default-sources (-> //.Profile //.Profile) @@ -64,7 +64,7 @@ (def: single-profile Test (do random.monad - [expected _profile.random] + [expected @profile.random] (_.test "Single profile." (|> expected //format.profile @@ -88,7 +88,7 @@ (def: multiple-profiles Test (do random.monad - [expected ..project] + [expected ..random] (_.test "Multiple profiles." (|> expected //format.project @@ -100,7 +100,7 @@ dictionary.entries (list@map (function (_ [name profile]) [name (..with-default-sources profile)])) - (dictionary.from-list text.hash) + (dictionary.from-list text.hash) (:: //project.equivalence = actual)) (#try.Failure error) diff --git a/stdlib/source/test/lux/control/function/memo.lux b/stdlib/source/test/lux/control/function/memo.lux index a57adaa53..85fe41f8d 100644 --- a/stdlib/source/test/lux/control/function/memo.lux +++ b/stdlib/source/test/lux/control/function/memo.lux @@ -82,7 +82,7 @@ (_.cover [/.memoization] (let [memo (<| //.mixin (//.inherit /.memoization) - (: (//.Mixin (-> Nat (State (Dictionary Nat Nat) Nat))) + (: (//.Mixin Nat (State (Dictionary Nat Nat) Nat)) (function (factorial delegate recur input) (case input (^or 0 1) (:: state.monad wrap 1) diff --git a/stdlib/source/test/lux/control/function/mixin.lux b/stdlib/source/test/lux/control/function/mixin.lux index 23704362d..2d83f5515 100644 --- a/stdlib/source/test/lux/control/function/mixin.lux +++ b/stdlib/source/test/lux/control/function/mixin.lux @@ -28,12 +28,12 @@ [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))) + #let [equivalence (: (Equivalence (/.Mixin Nat Nat)) (structure (def: (= left right) (n.= ((/.mixin left) input) ((/.mixin right) input))))) - generator (: (Random (/.Mixin (-> Nat Nat))) + generator (: (Random (/.Mixin Nat Nat)) (do @ [output random.nat] (wrap (function (_ delegate recur input) @@ -56,19 +56,19 @@ (n.= expected (factorial input)))) (_.cover [/.inherit] - (let [bottom (: (/.Mixin (-> Nat Nat)) + (let [bottom (: (/.Mixin Nat Nat) (function (_ delegate recur input) (case input (^or 0 1) 1 _ (delegate input)))) - multiplication (: (/.Mixin (-> Nat Nat)) + multiplication (: (/.Mixin Nat Nat) (function (_ delegate recur input) (n.* input (recur (dec input))))) factorial (/.mixin (/.inherit bottom multiplication))] (n.= expected (factorial input)))) (_.cover [/.nothing] - (let [loop (: (/.Mixin (-> Nat Nat)) + (let [loop (: (/.Mixin Nat Nat) (function (_ delegate recur input) (case input (^or 0 1) 1 @@ -80,7 +80,7 @@ (n.= expected (right input))))) (_.cover [/.advice] - (let [bottom (: (/.Mixin (-> Nat Nat)) + (let [bottom (: (/.Mixin Nat Nat) (function (_ delegate recur input) 1)) bottom? (: (Predicate Nat) @@ -88,7 +88,7 @@ (case input (^or 0 1) true _ false))) - multiplication (: (/.Mixin (-> Nat Nat)) + multiplication (: (/.Mixin Nat Nat) (function (_ delegate recur input) (n.* input (recur (dec input))))) factorial (/.mixin (/.inherit (/.advice bottom? bottom) @@ -100,7 +100,7 @@ (function (_ input) (function (_ state) [shift []]))) - meld (: (/.Mixin (-> Nat (State Nat Nat))) + meld (: (/.Mixin Nat (State Nat Nat)) (function (_ delegate recur input) (function (_ state) [state (n.+ state input)]))) @@ -113,7 +113,7 @@ (function (_ input output) (function (_ state) [shift []]))) - meld (: (/.Mixin (-> Nat (State Nat Nat))) + meld (: (/.Mixin Nat (State Nat Nat)) (function (_ delegate recur input) (function (_ state) [state (n.+ state input)]))) diff --git a/stdlib/source/test/lux/control/parser/analysis.lux b/stdlib/source/test/lux/control/parser/analysis.lux index 1eb314b6e..47a987d03 100644 --- a/stdlib/source/test/lux/control/parser/analysis.lux +++ b/stdlib/source/test/lux/control/parser/analysis.lux @@ -82,7 +82,7 @@ [/.bit /.bit! random.bit analysis.bit bit@=] [/.nat /.nat! random.nat analysis.nat n.=] [/.int /.int! random.int analysis.int i.=] - [/.frac /.frac! random.frac analysis.frac f.=] + [/.frac /.frac! random.safe-frac analysis.frac f.=] [/.rev /.rev! random.rev analysis.rev r.=] [/.text /.text! (random.unicode 10) analysis.text text@=] [/.local /.local! random.nat analysis.variable/local n.=] diff --git a/stdlib/source/test/lux/data/collection/list.lux b/stdlib/source/test/lux/data/collection/list.lux index e6c971ae2..92cec10e8 100644 --- a/stdlib/source/test/lux/data/collection/list.lux +++ b/stdlib/source/test/lux/data/collection/list.lux @@ -95,10 +95,16 @@ (_.cover [/.repeat] (n.= size (/.size (/.repeat size [])))) (_.cover [/.reverse] - (and (not (/@= sample - (/.reverse sample))) - (/@= sample - (/.reverse (/.reverse sample))))) + (or (n.< 2 (/.size sample)) + (let [not-same! + (not (/@= sample + (/.reverse sample))) + + self-symmetry! + (/@= sample + (/.reverse (/.reverse sample)))] + (and not-same! + self-symmetry!)))) (_.cover [/.every? /.any?] (if (/.every? n.even? sample) (not (/.any? (bit.complement n.even?) sample)) @@ -144,11 +150,17 @@ already-sorted! expected-numbers!))) (_.cover [/.enumeration] - (let [enumeration (/.enumeration sample)] - (and (/@= (/.indices (/.size enumeration)) - (/@map product.left enumeration)) - (/@= sample - (/@map product.right enumeration))))) + (let [enumeration (/.enumeration sample) + + has-correct-indices! + (/@= (/.indices (/.size enumeration)) + (/@map product.left enumeration)) + + has-correct-values! + (/@= sample + (/@map product.right enumeration))] + (and has-correct-indices! + has-correct-values!))) (_.cover [/.nth] (/.every? (function (_ [index expected]) (case (/.nth index sample) @@ -366,13 +378,10 @@ (_.cover [/.find] (case (/.find n.even? sample) (#.Some found) - (and (n.even? found) - (/.any? n.even? sample) - (not (/.every? (bit.complement n.even?) sample))) + (n.even? found) #.None - (and (not (/.any? n.even? sample)) - (/.every? (bit.complement n.even?) sample)))) + (not (/.any? n.even? sample)))) )))) (def: #export test @@ -394,18 +403,20 @@ ..search (_.cover [/.interpose] - (let [sample+ (/.interpose separator sample)] - (and (n.= (|> (/.size sample) (n.* 2) dec) - (/.size sample+)) - (|> sample+ /.as-pairs (/.every? (|>> product.right (n.= separator))))))) + (or (/.empty? sample) + (let [sample+ (/.interpose separator sample)] + (and (n.= (|> (/.size sample) (n.* 2) dec) + (/.size sample+)) + (|> sample+ /.as-pairs (/.every? (|>> product.right (n.= separator)))))))) (_.cover [/.iterate] - (let [size (/.size sample)] - (/@= (/.indices size) - (/.iterate (function (_ index) - (if (n.< size index) - (#.Some (inc index)) - #.None)) - 0)))) + (or (/.empty? sample) + (let [size (/.size sample)] + (/@= (/.indices size) + (/.iterate (function (_ index) + (if (n.< size index) + (#.Some (inc index)) + #.None)) + 0))))) (_.cover [/.folds] (/@= (/@map (function (_ index) (:: /.fold fold n.+ 0 (/.take index sample))) diff --git a/stdlib/source/test/lux/data/collection/queue.lux b/stdlib/source/test/lux/data/collection/queue.lux index 9605a50b1..f646fd82a 100644 --- a/stdlib/source/test/lux/data/collection/queue.lux +++ b/stdlib/source/test/lux/data/collection/queue.lux @@ -1,6 +1,5 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract [monad (#+ do)] @@ -9,10 +8,15 @@ ["$." equivalence] ["$." functor (#+ Injection)]]}] [data + ["." bit ("#@." equivalence)] + ["%" text/format (#+ format)] [number - ["n" nat]]] + ["n" nat]] + [collection + ["." set] + ["." list ("#@." monoid)]]] [math - ["r" random]]] + ["." random]]] {1 ["." /]}) @@ -22,43 +26,95 @@ (def: #export test Test - (<| (_.context (%.name (name-of /.Queue))) - (do {@ r.monad} - [size (:: @ map (n.% 100) r.nat) - sample (r.queue size r.nat) - non-member (|> r.nat - (r.filter (|>> (/.member? n.equivalence sample) not)))] + (<| (_.covering /._) + (_.with-cover [/.Queue]) + (do {@ random.monad} + [size (:: @ map (n.% 100) random.nat) + members (random.set n.hash size random.nat) + non-member (random.filter (|>> (set.member? members) not) + random.nat) + #let [members (set.to-list members) + sample (/.from-list members)]] ($_ _.and - ($equivalence.spec (/.equivalence n.equivalence) (r.queue size r.nat)) - ($functor.spec ..injection /.equivalence /.functor) - - (_.test "I can query the size of a queue (and empty queues have size 0)." - (if (n.= 0 size) - (/.empty? sample) - (n.= size (/.size sample)))) - (_.test "Enqueueing and dequeing affects the size of queues." - (and (n.= (inc size) (/.size (/.push non-member sample))) - (or (/.empty? sample) - (n.= (dec size) (/.size (/.pop sample)))) - (n.= size (/.size (/.pop (/.push non-member sample)))))) - (_.test "Transforming to/from list can't change the queue." - (let [(^open "/;.") (/.equivalence n.equivalence)] - (|> sample - /.to-list /.from-list - (/;= sample)))) - (_.test "I can always peek at a non-empty queue." - (case (/.peek sample) - #.None (/.empty? sample) - (#.Some _) #1)) - (_.test "I can query whether an element belongs to a queue." - (and (not (/.member? n.equivalence sample non-member)) - (/.member? n.equivalence (/.push non-member sample) - non-member) - (case (/.peek sample) - #.None - (/.empty? sample) - - (#.Some first) - (and (/.member? n.equivalence sample first) - (not (/.member? n.equivalence (/.pop sample) first)))))) + (_.with-cover [/.equivalence] + ($equivalence.spec (/.equivalence n.equivalence) (random.queue size random.nat))) + (_.with-cover [/.functor] + ($functor.spec ..injection /.equivalence /.functor)) + + (_.cover [/.from-list /.to-list] + (|> members /.from-list /.to-list + (:: (list.equivalence n.equivalence) = members))) + (_.cover [/.size] + (n.= size (/.size sample))) + (_.cover [/.empty?] + (bit@= (n.= 0 size) (/.empty? sample))) + (_.cover [/.empty] + (let [empty-is-empty! + (/.empty? /.empty) + + all-empty-queues-look-the-same! + (bit@= (/.empty? sample) + (:: (/.equivalence n.equivalence) = + sample + /.empty))] + (and empty-is-empty! + all-empty-queues-look-the-same!))) + (_.cover [/.peek] + (case [members (/.peek sample)] + [(#.Cons head tail) (#.Some first)] + (n.= head first) + + [#.Nil #.None] + true + + _ + false)) + (_.cover [/.member?] + (let [every-member-is-identified! + (list.every? (/.member? n.equivalence sample) + (/.to-list sample)) + + non-member-is-not-identified! + (not (/.member? n.equivalence sample non-member))] + (and every-member-is-identified! + non-member-is-not-identified!))) + (_.cover [/.push] + (let [pushed (/.push non-member sample) + + size-increases! + (n.= (inc (/.size sample)) (/.size pushed)) + + new-member-is-identified! + (/.member? n.equivalence pushed non-member) + + has-expected-order! + (:: (list.equivalence n.equivalence) = + (list@compose (/.to-list sample) (list non-member)) + (/.to-list pushed))] + (and size-increases! + new-member-is-identified! + has-expected-order!))) + (_.cover [/.pop] + (case members + (#.Cons target expected) + (let [popped (/.pop sample) + + size-decreases! + (n.= (dec (/.size sample)) + (/.size popped)) + + popped-member-is-not-identified! + (not (/.member? n.equivalence popped target)) + + has-expected-order! + (:: (list.equivalence n.equivalence) = + expected + (/.to-list popped))] + (and size-decreases! + popped-member-is-not-identified! + has-expected-order!)) + + #.Nil + (and (/.empty? sample) + (/.empty? (/.pop sample))))) )))) |