aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/abstract/equivalence.lux9
-rw-r--r--stdlib/source/lux/abstract/functor.lux6
-rw-r--r--stdlib/source/lux/abstract/functor/contravariant.lux8
-rw-r--r--stdlib/source/lux/abstract/order.lux13
-rw-r--r--stdlib/source/lux/abstract/predicate.lux9
-rw-r--r--stdlib/source/lux/control/concurrency/frp.lux17
-rw-r--r--stdlib/source/lux/control/security/policy.lux4
-rw-r--r--stdlib/source/lux/data/collection/list.lux30
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux2
-rw-r--r--stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux2
-rw-r--r--stdlib/source/lux/target/jvm/constant.lux4
-rw-r--r--stdlib/source/lux/target/jvm/index.lux2
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/analysis.lux5
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux7
-rw-r--r--stdlib/source/lux/tool/compiler/language/lux/version.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/meta.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive.lux14
-rw-r--r--stdlib/source/lux/tool/compiler/meta/archive/signature.lux12
-rw-r--r--stdlib/source/lux/tool/compiler/meta/io/archive.lux17
-rw-r--r--stdlib/source/lux/tool/compiler/version.lux3
-rw-r--r--stdlib/source/test/lux/abstract/order.lux14
-rw-r--r--stdlib/source/test/lux/control/concurrency/atom.lux49
-rw-r--r--stdlib/source/test/lux/control/concurrency/frp.lux227
-rw-r--r--stdlib/source/test/lux/control/state.lux29
24 files changed, 348 insertions, 143 deletions
diff --git a/stdlib/source/lux/abstract/equivalence.lux b/stdlib/source/lux/abstract/equivalence.lux
index ccfc55928..d65e101a8 100644
--- a/stdlib/source/lux/abstract/equivalence.lux
+++ b/stdlib/source/lux/abstract/equivalence.lux
@@ -1,7 +1,8 @@
(.module:
[lux #*]
[//
- [functor (#+ Contravariant)]])
+ [functor
+ ["." contravariant]]])
(signature: #export (Equivalence a)
{#.doc "Equivalence for a type's instances."}
@@ -35,10 +36,10 @@
(def: (= left right)
(sub = left right))))
-(structure: #export contravariant
- (Contravariant Equivalence)
+(structure: #export functor
+ (contravariant.Functor Equivalence)
- (def: (map-1 f equivalence)
+ (def: (map f equivalence)
(structure
(def: (= reference sample)
(:: equivalence = (f reference) (f sample))))))
diff --git a/stdlib/source/lux/abstract/functor.lux b/stdlib/source/lux/abstract/functor.lux
index a9fc6796c..9ba47aaf8 100644
--- a/stdlib/source/lux/abstract/functor.lux
+++ b/stdlib/source/lux/abstract/functor.lux
@@ -42,9 +42,3 @@
(structure
(def: (map f fga)
(f@map (g@map f) fga))))
-
-(signature: #export (Contravariant f)
- (: (All [a b]
- (-> (-> b a)
- (-> (f a) (f b))))
- map-1))
diff --git a/stdlib/source/lux/abstract/functor/contravariant.lux b/stdlib/source/lux/abstract/functor/contravariant.lux
new file mode 100644
index 000000000..79ae218fa
--- /dev/null
+++ b/stdlib/source/lux/abstract/functor/contravariant.lux
@@ -0,0 +1,8 @@
+(.module:
+ [lux #*])
+
+(signature: #export (Functor f)
+ (: (All [a b]
+ (-> (-> b a)
+ (-> (f a) (f b))))
+ map))
diff --git a/stdlib/source/lux/abstract/order.lux b/stdlib/source/lux/abstract/order.lux
index c28026036..dad99b8b4 100644
--- a/stdlib/source/lux/abstract/order.lux
+++ b/stdlib/source/lux/abstract/order.lux
@@ -3,8 +3,9 @@
[control
["." function]]]
[//
- [functor (#+ Contravariant)]
- ["." equivalence (#+ Equivalence)]])
+ ["." equivalence (#+ Equivalence)]
+ [functor
+ ["." contravariant]]])
(signature: #export (Order a)
{#.doc "A signature for types that possess some sense of ordering among their elements."}
@@ -44,13 +45,13 @@
Choice
(if (:: order < y x) y x))
-(structure: #export contravariant
- (Contravariant Order)
+(structure: #export functor
+ (contravariant.Functor Order)
- (def: (map-1 f order)
+ (def: (map f order)
(structure
(def: &equivalence
- (:: equivalence.contravariant map-1 f (:: order &equivalence)))
+ (:: equivalence.functor map f (:: order &equivalence)))
(def: (< reference sample)
(:: order < (f reference) (f sample))))))
diff --git a/stdlib/source/lux/abstract/predicate.lux b/stdlib/source/lux/abstract/predicate.lux
index b69b43415..13aa9a083 100644
--- a/stdlib/source/lux/abstract/predicate.lux
+++ b/stdlib/source/lux/abstract/predicate.lux
@@ -4,7 +4,8 @@
["." function]]]
[//
[monoid (#+ Monoid)]
- [functor (#+ Contravariant)]])
+ [functor
+ ["." contravariant]]])
(type: #export (Predicate a)
(-> a Bit))
@@ -52,8 +53,8 @@
(function (recur input)
(predicate recur input)))
-(structure: #export contravariant
- (Contravariant Predicate)
+(structure: #export functor
+ (contravariant.Functor Predicate)
- (def: (map-1 f fb)
+ (def: (map f fb)
(|>> f fb)))
diff --git a/stdlib/source/lux/control/concurrency/frp.lux b/stdlib/source/lux/control/concurrency/frp.lux
index 2be15ea23..3dc596a91 100644
--- a/stdlib/source/lux/control/concurrency/frp.lux
+++ b/stdlib/source/lux/control/concurrency/frp.lux
@@ -207,29 +207,30 @@
(folds f init' tail)))))
(def: #export (poll milli-seconds action)
- (All [a] (-> Nat (IO a) (Channel a)))
+ (All [a]
+ (-> Nat (IO a) [(Channel a) (Sink a)]))
(let [[output sink] (channel [])]
(exec (io.run (loop [_ []]
(do io.monad
[value action
_ (:: sink feed value)]
(promise.await recur (promise.wait milli-seconds)))))
- output)))
+ [output sink])))
(def: #export (periodic milli-seconds)
- (-> Nat (Channel Any))
- (poll milli-seconds (io [])))
+ (-> Nat [(Channel Any) (Sink Any)])
+ (..poll milli-seconds (io [])))
(def: #export (iterate f init)
- (All [a] (-> (-> a (Promise (Maybe a))) a (Channel a)))
+ (All [s o] (-> (-> s (Promise (Maybe [s o]))) s (Channel o)))
(do promise.monad
[?next (f init)]
(case ?next
- (#.Some next)
- (wrap (#.Some [init (iterate f next)]))
+ (#.Some [state output])
+ (wrap (#.Some [output (iterate f state)]))
#.None
- (wrap (#.Some [init (wrap #.None)])))))
+ (wrap #.None))))
(def: (distinct' equivalence previous channel)
(All [a] (-> (Equivalence a) a (Channel a) (Channel a)))
diff --git a/stdlib/source/lux/control/security/policy.lux b/stdlib/source/lux/control/security/policy.lux
index d210f91e1..69489b0da 100644
--- a/stdlib/source/lux/control/security/policy.lux
+++ b/stdlib/source/lux/control/security/policy.lux
@@ -34,7 +34,9 @@
(type: #export (Delegation brand from to)
{#.doc (doc "Represents the act of delegating policy capacities.")}
- (All [value] (-> (Policy brand value from) (Policy brand value to))))
+ (All [value]
+ (-> (Policy brand value from)
+ (Policy brand value to))))
(def: #export (delegation downgrade upgrade)
{#.doc (doc "Delegating policy capacities.")}
diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux
index eaf7df755..1c18dcf63 100644
--- a/stdlib/source/lux/data/collection/list.lux
+++ b/stdlib/source/lux/data/collection/list.lux
@@ -19,7 +19,9 @@
## #Nil
## (#Cons a (List a)))
-(structure: #export fold (Fold List)
+(structure: #export fold
+ (Fold List)
+
(def: (fold f init xs)
(case xs
#.Nil
@@ -28,6 +30,15 @@
(#.Cons x xs')
(fold f (f x init) xs'))))
+(def: #export (folds f init inputs)
+ (All [a b] (-> (-> a b b) b (List a) (List b)))
+ (case inputs
+ #.Nil
+ (list init)
+
+ (#.Cons [head tail])
+ (#.Cons [init (folds f (f head init) tail)])))
+
(def: #export (reverse xs)
(All [a]
(-> (List a) (List a)))
@@ -274,6 +285,7 @@
(structure: #export (equivalence Equivalence<a>)
(All [a] (-> (Equivalence a) (Equivalence (List a))))
+
(def: (= xs ys)
(case [xs ys]
[#.Nil #.Nil]
@@ -287,7 +299,9 @@
#0
)))
-(structure: #export monoid (All [a] (Monoid (List a)))
+(structure: #export monoid
+ (All [a] (Monoid (List a)))
+
(def: identity #.Nil)
(def: (compose xs ys)
(case xs
@@ -296,7 +310,9 @@
(open: "." monoid)
-(structure: #export functor (Functor List)
+(structure: #export functor
+ (Functor List)
+
(def: (map f ma)
(case ma
#.Nil #.Nil
@@ -304,7 +320,9 @@
(open: "." ..functor)
-(structure: #export apply (Apply List)
+(structure: #export apply
+ (Apply List)
+
(def: &functor ..functor)
(def: (apply ff fa)
@@ -315,7 +333,9 @@
(#.Cons f ff')
(compose (map f fa) (apply ff' fa)))))
-(structure: #export monad (Monad List)
+(structure: #export monad
+ (Monad List)
+
(def: &functor ..functor)
(def: (wrap a)
diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux
index 3a8bd4482..660f6c85c 100644
--- a/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux
+++ b/stdlib/source/lux/target/jvm/bytecode/environment/limit/registry.lux
@@ -59,7 +59,7 @@
(def: #export equivalence
(Equivalence Registry)
- (:: equivalence.contravariant map-1
+ (:: equivalence.functor map
(|>> :representation)
/////unsigned.equivalence))
diff --git a/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux b/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux
index fe72f79a5..18ca09fb0 100644
--- a/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux
+++ b/stdlib/source/lux/target/jvm/bytecode/environment/limit/stack.lux
@@ -32,7 +32,7 @@
(def: #export equivalence
(Equivalence Stack)
- (:: equivalence.contravariant map-1
+ (:: equivalence.functor map
(|>> :representation)
/////unsigned.equivalence))
diff --git a/stdlib/source/lux/target/jvm/constant.lux b/stdlib/source/lux/target/jvm/constant.lux
index 91a72390a..3e225a7c2 100644
--- a/stdlib/source/lux/target/jvm/constant.lux
+++ b/stdlib/source/lux/target/jvm/constant.lux
@@ -51,7 +51,7 @@
(def: #export class-equivalence
(Equivalence Class)
- (:: equivalence.contravariant map-1
+ (:: equivalence.functor map
..index
//index.equivalence))
@@ -92,7 +92,7 @@
(All [kind]
(-> (Equivalence kind)
(Equivalence (Value kind))))
- (:: equivalence.contravariant map-1
+ (:: equivalence.functor map
(|>> :representation)
Equivalence<kind>))
diff --git a/stdlib/source/lux/target/jvm/index.lux b/stdlib/source/lux/target/jvm/index.lux
index 490667436..2922c74b1 100644
--- a/stdlib/source/lux/target/jvm/index.lux
+++ b/stdlib/source/lux/target/jvm/index.lux
@@ -29,7 +29,7 @@
(def: #export equivalence
(All [kind] (Equivalence (Index kind)))
- (:: equivalence.contravariant map-1
+ (:: equivalence.functor map
..value
//unsigned.equivalence))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
index 59a1cf2eb..27bc09652 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux
@@ -20,6 +20,7 @@
["." extension (#+ Extension)]]
[///
[arity (#+ Arity)]
+ [version (#+ Version)]
["." reference (#+ Register Variable Reference)]
["." phase]]])
@@ -387,9 +388,9 @@
#.var-bindings (list)})
(def: #export (info version host)
- (-> Text Text Info)
+ (-> Version Text Info)
{#.target host
- #.version version
+ #.version (%.nat version)
#.mode #.Build})
(def: #export (state info)
diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
index e08a6219f..304629c6f 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/phase/generation/jvm/runtime.lux
@@ -51,7 +51,7 @@
["#" phase]
[arity (#+ Arity)]
[reference (#+ Register)]
- [meta
+ ["." meta
[io (#+ lux-context)]
[archive (#+ Archive)]]]]]])
@@ -79,7 +79,10 @@
(def: #export (class-name [module id])
(-> generation.Context Text)
- (format lux-context "/" (%.nat module) "/" (%.nat id)))
+ (format lux-context
+ "/" (%.nat meta.version)
+ "/" (%.nat module)
+ "/" (%.nat id)))
(def: #export class (type.class "LuxRuntime" (list)))
diff --git a/stdlib/source/lux/tool/compiler/language/lux/version.lux b/stdlib/source/lux/tool/compiler/language/lux/version.lux
index 013cdc72e..53b3424ae 100644
--- a/stdlib/source/lux/tool/compiler/language/lux/version.lux
+++ b/stdlib/source/lux/tool/compiler/language/lux/version.lux
@@ -3,4 +3,6 @@
[////
[version (#+ Version)]])
-(def: #export version Version "0.6.0")
+(def: #export version
+ Version
+ 00,06,00)
diff --git a/stdlib/source/lux/tool/compiler/meta.lux b/stdlib/source/lux/tool/compiler/meta.lux
index dfa57dd4c..df3eb31a7 100644
--- a/stdlib/source/lux/tool/compiler/meta.lux
+++ b/stdlib/source/lux/tool/compiler/meta.lux
@@ -3,4 +3,6 @@
[//
[version (#+ Version)]])
-(def: #export version Version "0.1.0")
+(def: #export version
+ Version
+ 00,01,00)
diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux
index f95d713a4..37b47777d 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive.lux
@@ -13,12 +13,12 @@
[binary (#+ Binary)]
["." product]
["." name]
- ["." text ("#@." equivalence)
+ ["." text
["%" format (#+ format)]]
[format
["." binary (#+ Writer)]]
[number
- ["n" nat]]
+ ["n" nat ("#@." equivalence)]]
[collection
["." list ("#@." functor fold)]
["." dictionary (#+ Dictionary)]
@@ -196,14 +196,14 @@
(def: reader
(Parser ..Frozen)
($_ <>.and
- <b>.text
+ <b>.nat
<b>.nat
(<b>.list (<>.and <b>.text <b>.nat))))
(def: writer
(Writer ..Frozen)
($_ binary.and
- binary.text
+ binary.nat
binary.nat
(binary.list (binary.and binary.text binary.nat))))
@@ -221,8 +221,8 @@
(exception: #export (version-mismatch {expected Version} {actual Version})
(exception.report
- ["Expected" (%.text expected)]
- ["Actual" (%.text actual)]))
+ ["Expected" (%.nat expected)]
+ ["Actual" (%.nat actual)]))
(exception: #export corrupt-data)
@@ -252,7 +252,7 @@
(do try.monad
[[actual next reservations] (<b>.run ..reader binary)
_ (exception.assert ..version-mismatch [expected actual]
- (text@= expected actual))
+ (n@= expected actual))
_ (exception.assert ..corrupt-data []
(correct-reservations? reservations))]
(wrap (:abstraction
diff --git a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux
index 3d795ff50..95bfc166b 100644
--- a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux
+++ b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux
@@ -10,7 +10,9 @@
["." text
["%" format (#+ format)]]
[format
- ["." binary (#+ Writer)]]]]
+ ["." binary (#+ Writer)]]
+ [number
+ ["." nat]]]]
[////
[version (#+ Version)]])
@@ -20,18 +22,18 @@
(def: #export equivalence
(Equivalence Signature)
- (equivalence.product name.equivalence text.equivalence))
+ (equivalence.product name.equivalence nat.equivalence))
(def: #export (description signature)
(-> Signature Text)
- (format (%.name (get@ #name signature)) " " (get@ #version signature)))
+ (format (%.name (get@ #name signature)) " " (%.nat (get@ #version signature))))
(def: #export writer
(Writer Signature)
(binary.and (binary.and binary.text binary.text)
- binary.text))
+ binary.nat))
(def: #export parser
(Parser Signature)
(<>.and (<>.and <b>.text <b>.text)
- <b>.text))
+ <b>.nat))
diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
index 3cf3ed4c4..ef73d321d 100644
--- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux
+++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux
@@ -48,23 +48,29 @@
["Module ID" (%.nat module-id)]
["Error" error]))
-(def: #export (archive system host root)
+(def: (archive system host root)
(-> (file.System Promise) Host Path Path)
(format root (:: system separator) host))
-(def: #export (lux-archive system host root)
+(def: (unversioned-lux-archive system host root)
(-> (file.System Promise) Host Path Path)
(format (..archive system host root)
(:: system separator)
//.lux-context))
+(def: (versioned-lux-archive system host root)
+ (-> (file.System Promise) Host Path Path)
+ (format (..unversioned-lux-archive system host root)
+ (:: system separator)
+ (%.nat ///.version)))
+
(def: (module system host root module-id)
(-> (file.System Promise) Host Path archive.ID Path)
- (format (..lux-archive system host root)
+ (format (..versioned-lux-archive system host root)
(:: system separator)
(%.nat module-id)))
-(def: #export (artifact system host root module-id name extension)
+(def: (artifact system host root module-id name extension)
(-> (file.System Promise) Host Path archive.ID Text Text Path)
(format (..module system host root module-id)
(:: system separator)
@@ -79,7 +85,8 @@
(if module-exists?
(wrap (#try.Success []))
(do @
- [_ (file.get-directory @ system (..lux-archive system host root))
+ [_ (file.get-directory @ system (..unversioned-lux-archive system host root))
+ _ (file.get-directory @ system (..versioned-lux-archive system host root))
outcome (!.use (:: system create-directory) module)]
(case outcome
(#try.Success output)
diff --git a/stdlib/source/lux/tool/compiler/version.lux b/stdlib/source/lux/tool/compiler/version.lux
index d2c14c50b..3965b9b28 100644
--- a/stdlib/source/lux/tool/compiler/version.lux
+++ b/stdlib/source/lux/tool/compiler/version.lux
@@ -1,4 +1,5 @@
(.module:
[lux #*])
-(type: #export Version Text)
+(type: #export Version
+ Nat)
diff --git a/stdlib/source/test/lux/abstract/order.lux b/stdlib/source/test/lux/abstract/order.lux
index a92dd06ad..7157a6c01 100644
--- a/stdlib/source/test/lux/abstract/order.lux
+++ b/stdlib/source/test/lux/abstract/order.lux
@@ -4,6 +4,7 @@
[abstract
[monad (#+ do)]]
[data
+ ["." bit ("#@." equivalence)]
[number
["n" nat]]]
[math
@@ -21,6 +22,19 @@
(_.cover [/.Choice /.min /.max]
(n.< (/.max n.order left right)
(/.min n.order left right)))
+ (_.cover [/.Comparison /.>]
+ (not (bit@= (n.< left right)
+ (/.> n.order left right))))
+ (_.cover [/.<=]
+ (and (/.<= n.order left left)
+ (/.<= n.order right right)
+ (bit@= (:: n.order < left right)
+ (/.<= n.order left right))))
+ (_.cover [/.>=]
+ (and (/.>= n.order left left)
+ (/.>= n.order right right)
+ (bit@= (/.> n.order left right)
+ (/.>= n.order left right))))
)))
(def: #export (spec (^open "/@.") generator)
diff --git a/stdlib/source/test/lux/control/concurrency/atom.lux b/stdlib/source/test/lux/control/concurrency/atom.lux
index 1cf645530..8902f0a8f 100644
--- a/stdlib/source/test/lux/control/concurrency/atom.lux
+++ b/stdlib/source/test/lux/control/concurrency/atom.lux
@@ -1,39 +1,40 @@
(.module:
[lux #*
["_" test (#+ Test)]
- [abstract/monad (#+ do)]
- ["%" data/text/format (#+ format)]
- [math
- ["r" random]]
+ [abstract
+ [monad (#+ do)]]
[control
["." io]]
[data
[number
- ["n" nat]]]]
+ ["n" nat]]]
+ [math
+ ["." random]]]
{1
["." /]})
(def: #export test
Test
- (<| (_.context (%.name (name-of /.Atom)))
- (do r.monad
- [value r.nat
- swap-value r.nat
- set-value r.nat
+ (<| (_.covering /._)
+ (do random.monad
+ [value random.nat
+ swap-value random.nat
+ set-value random.nat
#let [box (/.atom value)]]
($_ _.and
- (_.test "Can obtain the value of an atom."
- (n.= value (io.run (/.read box))))
-
- (_.test "Can swap the value of an atom."
- (and (io.run (/.compare-and-swap value swap-value box))
- (n.= swap-value (io.run (/.read box)))))
-
- (_.test "Can update the value of an atom."
- (exec (io.run (/.update inc box))
- (n.= (inc swap-value) (io.run (/.read box)))))
-
- (_.test "Can immediately set the value of an atom."
- (exec (io.run (/.write set-value box))
- (n.= set-value (io.run (/.read box)))))
+ (_.cover [/.Atom /.atom /.read]
+ (n.= value
+ (io.run (/.read box))))
+ (_.cover [/.compare-and-swap]
+ (and (io.run (/.compare-and-swap value swap-value box))
+ (n.= swap-value
+ (io.run (/.read box)))))
+ (_.cover [/.update]
+ (exec (io.run (/.update inc box))
+ (n.= (inc swap-value)
+ (io.run (/.read box)))))
+ (_.cover [/.write]
+ (exec (io.run (/.write set-value box))
+ (n.= set-value
+ (io.run (/.read box)))))
))))
diff --git a/stdlib/source/test/lux/control/concurrency/frp.lux b/stdlib/source/test/lux/control/concurrency/frp.lux
index ab705bfce..f7f7427b6 100644
--- a/stdlib/source/test/lux/control/concurrency/frp.lux
+++ b/stdlib/source/test/lux/control/concurrency/frp.lux
@@ -1,59 +1,202 @@
(.module:
[lux #*
["_" test (#+ Test)]
- [abstract/monad (#+ do)]
+ [abstract
+ [monad (#+ do)]
+ {[0 #test]
+ [/
+ ["$." functor (#+ Injection Comparison)]
+ ["$." apply]
+ ["$." monad]]}]
[control
+ ["." try]
+ ["." exception]
["." io (#+ IO io)]]
[data
+ [text
+ ["%" format (#+ format)]]
[number
["n" nat]]
[collection
- ["." list ("#@." functor)]]]
+ ["." list ("#@." functor fold)]
+ ["." row (#+ Row)]]]
[math
- ["r" random]]]
+ ["." random]]]
{1
- ["." / (#+ Channel)
+ ["." /
[//
["." promise ("#@." monad)]
["." atom (#+ Atom atom)]]]})
+(def: injection
+ (Injection /.Channel)
+ (|>> promise.resolved
+ /.from-promise))
+
+(def: comparison
+ (Comparison /.Channel)
+ (function (_ == left right)
+ (case [(promise.poll left)
+ (promise.poll right)]
+ [(#.Some (#.Some [left _]))
+ (#.Some (#.Some [right _]))]
+ (== left right)
+
+ _
+ false)))
+
(def: #export test
Test
- (let [(^open "list@.") (list.equivalence n.equivalence)]
- (do r.monad
- [inputs (r.list 5 r.nat)
- sample r.nat]
- ($_ _.and
- (wrap (do promise.monad
- [output (|> inputs
- (/.sequential 0)
- (/.filter n.even?)
- /.consume)]
- (_.assert "Can filter a channel's elements."
- (list@= (list.filter n.even? inputs)
- output))))
- (wrap (do promise.monad
- [output (|> inputs
- (/.sequential 0)
- (:: /.functor map inc)
- /.consume)]
- (_.assert "Functor goes over every element in a channel."
- (list@= (list@map inc inputs)
- output))))
- (wrap (do promise.monad
- [output (/.consume (:: /.apply apply
- (/.sequential 0 (list inc))
- (/.sequential 0 (list sample))))]
- (_.assert "Apply works over all channel values."
- (list@= (list (inc sample))
- output))))
- (wrap (do promise.monad
- [output (/.consume
- (do /.monad
- [f (/.from-promise (promise@wrap inc))
- a (/.from-promise (promise@wrap sample))]
- (wrap (f a))))]
- (_.assert "Valid monad."
- (list@= (list (inc sample))
- output))))
- ))))
+ (<| (_.covering /._)
+ (let [(^open "list@.") (list.equivalence n.equivalence)]
+ (do random.monad
+ [inputs (random.list 5 random.nat)
+ sample random.nat
+ distint/0 random.nat
+ distint/1 (|> random.nat (random.filter (|>> (n.= distint/0) not)))
+ distint/2 (|> random.nat (random.filter (function (_ value)
+ (not (or (n.= distint/0 value)
+ (n.= distint/1 value))))))
+ shift random.nat]
+ ($_ _.and
+ (_.with-cover [/.functor]
+ ($functor.spec ..injection ..comparison /.functor))
+ (_.with-cover [/.apply]
+ ($apply.spec ..injection ..comparison /.apply))
+ (_.with-cover [/.monad]
+ ($monad.spec ..injection ..comparison /.monad))
+
+ (_.cover [/.Channel /.Sink /.channel]
+ (case (io.run
+ (do (try.with io.monad)
+ [#let [[channel sink] (/.channel [])]
+ _ (:: sink feed sample)
+ _ (:: sink close)]
+ (wrap channel)))
+ (#try.Success channel)
+ (case (promise.poll channel)
+ (#.Some (#.Some [actual _]))
+ (n.= sample actual)
+
+ _
+ false)
+
+ (#try.Failure error)
+ false))
+ (_.cover [/.channel-is-already-closed]
+ (case (io.run
+ (do (try.with io.monad)
+ [#let [[channel sink] (/.channel [])]
+ _ (:: sink close)]
+ (:: sink feed sample)))
+ (#try.Success _)
+ false
+
+ (#try.Failure error)
+ (exception.match? /.channel-is-already-closed error)))
+ (wrap (do promise.monad
+ [output (|> sample
+ promise.resolved
+ /.from-promise
+ /.consume)]
+ (_.claim [/.from-promise /.consume]
+ (list@= (list sample)
+ output))))
+ (wrap (do promise.monad
+ [output (|> inputs
+ (/.sequential 0)
+ /.consume)]
+ (_.claim [/.sequential]
+ (list@= inputs
+ output))))
+ (wrap (do promise.monad
+ [output (|> inputs
+ (/.sequential 0)
+ (/.filter n.even?)
+ /.consume)]
+ (_.claim [/.filter]
+ (list@= (list.filter n.even? inputs)
+ output))))
+ (wrap (do promise.monad
+ [#let [sink (: (Atom (Row Nat))
+ (atom.atom row.empty))
+ channel (/.sequential 0 inputs)]
+ _ (promise.future (/.listen (function (_ value)
+ (do io.monad
+ [_ (atom.update (row.add value) sink)]
+ (wrap [])))
+ channel))
+ output (/.consume channel)
+ listened (|> sink
+ atom.read
+ promise.future
+ (:: @ map row.to-list))]
+ (_.claim [/.listen]
+ (and (list@= inputs
+ output)
+ (list@= output
+ listened)))))
+ (wrap (do promise.monad
+ [actual (/.fold (function (_ input total)
+ (promise.resolved (n.+ input total)))
+ 0
+ (/.sequential 0 inputs))]
+ (_.claim [/.fold]
+ (n.= (list@fold n.+ 0 inputs)
+ actual))))
+ (wrap (do promise.monad
+ [actual (|> inputs
+ (/.sequential 0)
+ (/.folds (function (_ input total)
+ (promise.resolved (n.+ input total)))
+ 0)
+ /.consume)]
+ (_.claim [/.folds]
+ (list@= (list.folds n.+ 0 inputs)
+ actual))))
+ (wrap (do promise.monad
+ [actual (|> (list distint/0 distint/0 distint/0
+ distint/1
+ distint/2 distint/2)
+ (/.sequential 0)
+ (/.distinct n.equivalence)
+ /.consume)]
+ (_.claim [/.distinct]
+ (list@= (list distint/0 distint/1 distint/2)
+ actual))))
+ (wrap (do promise.monad
+ [#let [polling-delay 10
+ amount-of-polls 5
+ total-delay (n.* amount-of-polls polling-delay)
+ [channel sink] (/.poll polling-delay (: (IO Nat) (io.io sample)))]
+ _ (promise.schedule total-delay (io.io []))
+ _ (promise.future (:: sink close))
+ actual (/.consume channel)]
+ (_.claim [/.poll]
+ (and (list.every? (n.= sample) actual)
+ (n.>= amount-of-polls (list.size actual))))))
+ (wrap (do promise.monad
+ [#let [polling-delay 10
+ amount-of-polls 5
+ total-delay (n.* amount-of-polls polling-delay)
+ [channel sink] (/.periodic polling-delay)]
+ _ (promise.schedule total-delay (io.io []))
+ _ (promise.future (:: sink close))
+ actual (/.consume channel)]
+ (_.claim [/.periodic]
+ (n.>= amount-of-polls (list.size actual)))))
+ (wrap (do promise.monad
+ [#let [max-iterations 10]
+ actual (|> [0 sample]
+ (/.iterate (function (_ [iterations current])
+ (promise.resolved
+ (if (n.< max-iterations iterations)
+ (#.Some [[(inc iterations) (n.+ shift current)]
+ current])
+ #.None))))
+ /.consume)]
+ (_.claim [/.iterate]
+ (and (n.= max-iterations (list.size actual))
+ (list@= (list.folds n.+ sample (list.repeat (dec max-iterations) shift))
+ actual)))))
+ )))))
diff --git a/stdlib/source/test/lux/control/state.lux b/stdlib/source/test/lux/control/state.lux
index cb7c94b83..72284ba5c 100644
--- a/stdlib/source/test/lux/control/state.lux
+++ b/stdlib/source/test/lux/control/state.lux
@@ -18,7 +18,7 @@
[text
["%" format (#+ format)]]]
[math
- ["r" random]]]
+ ["." random]]]
{1
["." / (#+ State)]})
@@ -30,9 +30,9 @@
(n.= output)))
(def: basics
- (do r.monad
- [state r.nat
- value r.nat]
+ (do random.monad
+ [state random.nat
+ value random.nat]
($_ _.and
(_.cover [/.State /.get]
(with-conditions [state state]
@@ -58,7 +58,8 @@
(def: (injection value)
(All [s] (Injection (State s)))
- (function (_ state) [state value]))
+ (function (_ state)
+ [state value]))
(def: (comparison init)
(All [s] (-> s (Comparison (State s))))
@@ -68,9 +69,9 @@
(def: structures
Test
- (do r.monad
- [state r.nat
- value r.nat]
+ (do random.monad
+ [state random.nat
+ value random.nat]
($_ _.and
(_.with-cover [/.functor]
($functor.spec ..injection (..comparison state) /.functor))
@@ -82,8 +83,8 @@
(def: loops
Test
- (do r.monad
- [limit (|> r.nat (:: @ map (n.% 10)))
+ (do random.monad
+ [limit (|> random.nat (:: @ map (n.% 10)))
#let [condition (do /.monad
[state /.get]
(wrap (n.< limit state)))]]
@@ -104,10 +105,10 @@
(def: monad-transformer
Test
- (do r.monad
- [state r.nat
- left r.nat
- right r.nat]
+ (do random.monad
+ [state random.nat
+ left random.nat
+ right random.nat]
(let [(^open "io@.") io.monad]
(_.cover [/.State' /.with /.lift /.run']
(|> (: (/.State' io.IO Nat Nat)