diff options
26 files changed, 354 insertions, 145 deletions
diff --git a/documentation/research/transducer_stream_pipe.md b/documentation/research/transducer_stream_pipe.md index 4f789b55b..5ba3f040a 100644 --- a/documentation/research/transducer_stream_pipe.md +++ b/documentation/research/transducer_stream_pipe.md @@ -1,5 +1,6 @@ # Reference +1. [zug](https://sinusoid.es/zug/) 1. https://dev.to/greencoder/build-your-own-transducer-and-impress-your-cat---part-1-mhp 1. https://functional.works-hub.com/learn/reducers-and-transducers-introductory-d0cff 1. http://beerendlauwers.be/posts/2015-12-09-transducers.html diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index 59d722233..141e70184 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -28,7 +28,7 @@ [language [lux ["." generation]]] - [meta + ["." meta [io (#+ lux-context)] [archive [descriptor (#+ Module)] @@ -98,7 +98,10 @@ (def: #export (class-name [module-id artifact-id]) (-> generation.Context Text) - (format lux-context "." (%.nat module-id) ..class-path-separator (%.nat artifact-id))) + (format lux-context + ..class-path-separator (%.nat meta.version) + ..class-path-separator (%.nat module-id) + ..class-path-separator (%.nat artifact-id))) (def: (evaluate! library loader eval-class valueI) (-> Library java/lang/ClassLoader Text Inst (Try [Any Definition])) 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) |