aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/abstract/hash.lux19
-rw-r--r--stdlib/source/lux/control/function/memo.lux2
-rw-r--r--stdlib/source/lux/control/function/mixin.lux18
-rw-r--r--stdlib/source/lux/data/collection/queue.lux30
-rw-r--r--stdlib/source/lux/world/file.lux456
-rw-r--r--stdlib/source/program/aedifex.lux46
-rw-r--r--stdlib/source/program/aedifex/command/pom.lux35
-rw-r--r--stdlib/source/test/aedifex.lux3
-rw-r--r--stdlib/source/test/aedifex/command/pom.lux67
-rw-r--r--stdlib/source/test/aedifex/parser.lux12
-rw-r--r--stdlib/source/test/lux/control/function/memo.lux2
-rw-r--r--stdlib/source/test/lux/control/function/mixin.lux18
-rw-r--r--stdlib/source/test/lux/control/parser/analysis.lux2
-rw-r--r--stdlib/source/test/lux/data/collection/list.lux61
-rw-r--r--stdlib/source/test/lux/data/collection/queue.lux138
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)))))
))))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-26 01:03:03 +0000