From 216a12cd02337c83c889a667063e0c06f2944e65 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 25 Jan 2017 20:30:44 -0400 Subject: - Moved the lux/data/struct/* modules to lux/data/coll/*. - Did the same for the lux/codata/struct/* modules. - Moved lux/codata/io to lux/io. - Moved lux/control/effect to lux/effect. - Renamed "sample" functions to "this" functions. - Renamed "at" functions to "nth" functions. --- stdlib/source/lux.lux | 14 +- stdlib/source/lux/cli.lux | 4 +- stdlib/source/lux/codata/coll/stream.lux | 147 +++++ stdlib/source/lux/codata/cont.lux | 10 +- stdlib/source/lux/codata/io.lux | 57 -- stdlib/source/lux/codata/struct/stream.lux | 147 ----- stdlib/source/lux/compiler.lux | 2 +- stdlib/source/lux/concurrency/actor.lux | 10 +- stdlib/source/lux/concurrency/atom.lux | 2 +- stdlib/source/lux/concurrency/frp.lux | 6 +- stdlib/source/lux/concurrency/promise.lux | 6 +- stdlib/source/lux/concurrency/stm.lux | 8 +- stdlib/source/lux/control/comonad.lux | 2 +- stdlib/source/lux/control/effect.lux | 406 -------------- stdlib/source/lux/data/char.lux | 4 +- stdlib/source/lux/data/coll/array.lux | 225 ++++++++ stdlib/source/lux/data/coll/dict.lux | 687 +++++++++++++++++++++++ stdlib/source/lux/data/coll/list.lux | 504 +++++++++++++++++ stdlib/source/lux/data/coll/queue.lux | 80 +++ stdlib/source/lux/data/coll/set.lux | 85 +++ stdlib/source/lux/data/coll/stack.lux | 47 ++ stdlib/source/lux/data/coll/tree/rose.lux | 60 ++ stdlib/source/lux/data/coll/tree/zipper.lux | 197 +++++++ stdlib/source/lux/data/coll/vector.lux | 451 +++++++++++++++ stdlib/source/lux/data/format/json.lux | 22 +- stdlib/source/lux/data/struct/array.lux | 225 -------- stdlib/source/lux/data/struct/dict.lux | 687 ----------------------- stdlib/source/lux/data/struct/list.lux | 504 ----------------- stdlib/source/lux/data/struct/queue.lux | 80 --- stdlib/source/lux/data/struct/set.lux | 85 --- stdlib/source/lux/data/struct/stack.lux | 47 -- stdlib/source/lux/data/struct/tree/rose.lux | 60 -- stdlib/source/lux/data/struct/tree/zipper.lux | 197 ------- stdlib/source/lux/data/struct/vector.lux | 451 --------------- stdlib/source/lux/data/text.lux | 4 +- stdlib/source/lux/data/text/format.lux | 2 +- stdlib/source/lux/effect.lux | 406 ++++++++++++++ stdlib/source/lux/host.lux | 100 ++-- stdlib/source/lux/io.lux | 57 ++ stdlib/source/lux/lexer.lux | 14 +- stdlib/source/lux/lexer/regex.lux | 2 +- stdlib/source/lux/macro.lux | 4 +- stdlib/source/lux/macro/ast.lux | 2 +- stdlib/source/lux/macro/poly.lux | 4 +- stdlib/source/lux/macro/poly/eq.lux | 4 +- stdlib/source/lux/macro/poly/functor.lux | 4 +- stdlib/source/lux/macro/poly/text-encoder.lux | 4 +- stdlib/source/lux/macro/syntax.lux | 6 +- stdlib/source/lux/macro/syntax/common.lux | 22 +- stdlib/source/lux/math.lux | 4 +- stdlib/source/lux/math/complex.lux | 2 +- stdlib/source/lux/math/simple.lux | 2 +- stdlib/source/lux/pipe.lux | 2 +- stdlib/source/lux/random.lux | 16 +- stdlib/source/lux/test.lux | 8 +- stdlib/source/lux/type.lux | 4 +- stdlib/source/lux/type/auto.lux | 4 +- stdlib/source/lux/type/check.lux | 4 +- stdlib/test/test/lux.lux | 2 +- stdlib/test/test/lux/cli.lux | 4 +- stdlib/test/test/lux/codata/coll/stream.lux | 106 ++++ stdlib/test/test/lux/codata/cont.lux | 2 +- stdlib/test/test/lux/codata/env.lux | 2 +- stdlib/test/test/lux/codata/io.lux | 27 - stdlib/test/test/lux/codata/state.lux | 2 +- stdlib/test/test/lux/codata/struct/stream.lux | 106 ---- stdlib/test/test/lux/concurrency/actor.lux | 6 +- stdlib/test/test/lux/concurrency/atom.lux | 4 +- stdlib/test/test/lux/concurrency/frp.lux | 6 +- stdlib/test/test/lux/concurrency/promise.lux | 6 +- stdlib/test/test/lux/concurrency/stm.lux | 4 +- stdlib/test/test/lux/control/effect.lux | 77 --- stdlib/test/test/lux/data/bit.lux | 4 +- stdlib/test/test/lux/data/bool.lux | 2 +- stdlib/test/test/lux/data/char.lux | 4 +- stdlib/test/test/lux/data/coll/array.lux | 135 +++++ stdlib/test/test/lux/data/coll/dict.lux | 137 +++++ stdlib/test/test/lux/data/coll/list.lux | 226 ++++++++ stdlib/test/test/lux/data/coll/queue.lux | 55 ++ stdlib/test/test/lux/data/coll/set.lux | 68 +++ stdlib/test/test/lux/data/coll/stack.lux | 48 ++ stdlib/test/test/lux/data/coll/tree/rose.lux | 40 ++ stdlib/test/test/lux/data/coll/tree/zipper.lux | 128 +++++ stdlib/test/test/lux/data/coll/vector.lux | 78 +++ stdlib/test/test/lux/data/error.lux | 2 +- stdlib/test/test/lux/data/error/exception.lux | 2 +- stdlib/test/test/lux/data/format/json.lux | 8 +- stdlib/test/test/lux/data/ident.lux | 2 +- stdlib/test/test/lux/data/identity.lux | 2 +- stdlib/test/test/lux/data/log.lux | 2 +- stdlib/test/test/lux/data/maybe.lux | 2 +- stdlib/test/test/lux/data/number.lux | 2 +- stdlib/test/test/lux/data/product.lux | 2 +- stdlib/test/test/lux/data/struct/array.lux | 135 ----- stdlib/test/test/lux/data/struct/dict.lux | 137 ----- stdlib/test/test/lux/data/struct/list.lux | 226 -------- stdlib/test/test/lux/data/struct/queue.lux | 55 -- stdlib/test/test/lux/data/struct/set.lux | 68 --- stdlib/test/test/lux/data/struct/stack.lux | 48 -- stdlib/test/test/lux/data/struct/tree/rose.lux | 40 -- stdlib/test/test/lux/data/struct/tree/zipper.lux | 128 ----- stdlib/test/test/lux/data/struct/vector.lux | 78 --- stdlib/test/test/lux/data/sum.lux | 4 +- stdlib/test/test/lux/data/text.lux | 35 +- stdlib/test/test/lux/data/text/format.lux | 2 +- stdlib/test/test/lux/effect.lux | 77 +++ stdlib/test/test/lux/host.lux | 6 +- stdlib/test/test/lux/io.lux | 27 + stdlib/test/test/lux/lexer.lux | 4 +- stdlib/test/test/lux/lexer/regex.lux | 2 +- stdlib/test/test/lux/macro/ast.lux | 2 +- stdlib/test/test/lux/macro/poly/eq.lux | 2 +- stdlib/test/test/lux/macro/poly/functor.lux | 2 +- stdlib/test/test/lux/macro/poly/text-encoder.lux | 2 +- stdlib/test/test/lux/macro/syntax.lux | 10 +- stdlib/test/test/lux/math.lux | 4 +- stdlib/test/test/lux/math/complex.lux | 4 +- stdlib/test/test/lux/math/logic/continuous.lux | 2 +- stdlib/test/test/lux/math/ratio.lux | 4 +- stdlib/test/test/lux/math/simple.lux | 4 +- stdlib/test/test/lux/pipe.lux | 2 +- stdlib/test/test/lux/type.lux | 4 +- stdlib/test/test/lux/type/auto.lux | 4 +- stdlib/test/test/lux/type/check.lux | 4 +- stdlib/test/tests.lux | 28 +- 125 files changed, 4330 insertions(+), 4323 deletions(-) create mode 100644 stdlib/source/lux/codata/coll/stream.lux delete mode 100644 stdlib/source/lux/codata/io.lux delete mode 100644 stdlib/source/lux/codata/struct/stream.lux delete mode 100644 stdlib/source/lux/control/effect.lux create mode 100644 stdlib/source/lux/data/coll/array.lux create mode 100644 stdlib/source/lux/data/coll/dict.lux create mode 100644 stdlib/source/lux/data/coll/list.lux create mode 100644 stdlib/source/lux/data/coll/queue.lux create mode 100644 stdlib/source/lux/data/coll/set.lux create mode 100644 stdlib/source/lux/data/coll/stack.lux create mode 100644 stdlib/source/lux/data/coll/tree/rose.lux create mode 100644 stdlib/source/lux/data/coll/tree/zipper.lux create mode 100644 stdlib/source/lux/data/coll/vector.lux delete mode 100644 stdlib/source/lux/data/struct/array.lux delete mode 100644 stdlib/source/lux/data/struct/dict.lux delete mode 100644 stdlib/source/lux/data/struct/list.lux delete mode 100644 stdlib/source/lux/data/struct/queue.lux delete mode 100644 stdlib/source/lux/data/struct/set.lux delete mode 100644 stdlib/source/lux/data/struct/stack.lux delete mode 100644 stdlib/source/lux/data/struct/tree/rose.lux delete mode 100644 stdlib/source/lux/data/struct/tree/zipper.lux delete mode 100644 stdlib/source/lux/data/struct/vector.lux create mode 100644 stdlib/source/lux/effect.lux create mode 100644 stdlib/source/lux/io.lux create mode 100644 stdlib/test/test/lux/codata/coll/stream.lux delete mode 100644 stdlib/test/test/lux/codata/io.lux delete mode 100644 stdlib/test/test/lux/codata/struct/stream.lux delete mode 100644 stdlib/test/test/lux/control/effect.lux create mode 100644 stdlib/test/test/lux/data/coll/array.lux create mode 100644 stdlib/test/test/lux/data/coll/dict.lux create mode 100644 stdlib/test/test/lux/data/coll/list.lux create mode 100644 stdlib/test/test/lux/data/coll/queue.lux create mode 100644 stdlib/test/test/lux/data/coll/set.lux create mode 100644 stdlib/test/test/lux/data/coll/stack.lux create mode 100644 stdlib/test/test/lux/data/coll/tree/rose.lux create mode 100644 stdlib/test/test/lux/data/coll/tree/zipper.lux create mode 100644 stdlib/test/test/lux/data/coll/vector.lux delete mode 100644 stdlib/test/test/lux/data/struct/array.lux delete mode 100644 stdlib/test/test/lux/data/struct/dict.lux delete mode 100644 stdlib/test/test/lux/data/struct/list.lux delete mode 100644 stdlib/test/test/lux/data/struct/queue.lux delete mode 100644 stdlib/test/test/lux/data/struct/set.lux delete mode 100644 stdlib/test/test/lux/data/struct/stack.lux delete mode 100644 stdlib/test/test/lux/data/struct/tree/rose.lux delete mode 100644 stdlib/test/test/lux/data/struct/tree/zipper.lux delete mode 100644 stdlib/test/test/lux/data/struct/vector.lux create mode 100644 stdlib/test/test/lux/effect.lux create mode 100644 stdlib/test/test/lux/io.lux diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index bb53b987e..f86d8cdae 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -3234,7 +3234,7 @@ (list module) (list& (substring2 0 idx module) (split-module (substring1 (i.+ 1 idx) module)))))) -(def: (at idx xs) +(def: (nth idx xs) (All [a] (-> Int (List a) (Maybe a))) (case xs @@ -3244,7 +3244,7 @@ (#Cons x xs') (if (i.= idx 0) (#Some x) - (at (i.- 1 idx) xs') + (nth (i.- 1 idx) xs') ))) (def: (beta-reduce env type) @@ -3279,7 +3279,7 @@ (#LambdaT (beta-reduce env ?input) (beta-reduce env ?output)) (#BoundT idx) - (case (at (_lux_proc ["nat" "to-int"] [idx]) env) + (case (nth (_lux_proc ["nat" "to-int"] [idx]) env) (#Some bound) bound @@ -3870,7 +3870,7 @@ num-ups (length ups)] (if (i.= num-ups 0) (return module) - (case (at num-ups (split-module-contexts module-name)) + (case (nth num-ups (split-module-contexts module-name)) #None (fail (Text/append "Can't clean module: " module)) @@ -4491,7 +4491,7 @@ lux (lux (control (monad #as M #refer #all)) (data (text #open (\"Text/\" Monoid)) - (struct (list #open (\"List/\" Monad))) + (coll (list #open (\"List/\" Monad))) maybe (ident #open (\"Ident/\" Codec))) meta @@ -4502,7 +4502,7 @@ lux (lux (control [\"M\" monad #*]) (data [text \"Text/\" Monoid] - (struct [list \"List/\" Monad]) + (coll [list \"List/\" Monad]) maybe [ident \"Ident/\" Codec]) meta @@ -4735,7 +4735,7 @@ [#;ExQ]) (#;BoundT idx) - (default type (list;at idx env)) + (default type (list;nth idx env)) _ type diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index a8604180b..410cd42d5 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -8,11 +8,11 @@ (lux (control functor applicative monad) - (data (struct (list #as list #open ("List/" Monoid Monad))) + (data (coll (list #as list #open ("List/" Monoid Monad))) (text #as text #open ("Text/" Monoid)) error (sum #as sum)) - (codata [io]) + [io] [compiler #+ with-gensyms Functor Monad] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/codata/coll/stream.lux b/stdlib/source/lux/codata/coll/stream.lux new file mode 100644 index 000000000..eeee1ccc2 --- /dev/null +++ b/stdlib/source/lux/codata/coll/stream.lux @@ -0,0 +1,147 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + monad + comonad) + [compiler #+ with-gensyms] + (macro ["s" syntax #+ syntax: Syntax]) + (data (coll [list "List/" Monad]) + bool) + (codata [cont #+ @lazy Cont]))) + +## [Types] +(type: #export (Stream a) + {#;doc "An infinite stream of lazily-evaluated values."} + (Cont [a (Stream a)])) + +## [Utils] +(def: (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Stream a))) + (case xs + #;Nil (@lazy [x (cycle' init full init full)]) + (#;Cons x' xs') (@lazy [x (cycle' x' xs' init full)]))) + +## [Functions] +(def: #export (iterate f x) + {#;doc "Create a stream by applying a function to a value, and to its result, on and on..."} + (All [a] + (-> (-> a a) a (Stream a))) + (@lazy [x (iterate f (f x))])) + +(def: #export (repeat x) + {#;doc "Repeat a value forever."} + (All [a] + (-> a (Stream a))) + (@lazy [x (repeat x)])) + +(def: #export (cycle xs) + {#;doc "Go over the elements of a list forever. + + The list shouldn't be empty."} + (All [a] + (-> (List a) (Maybe (Stream a)))) + (case xs + #;Nil #;None + (#;Cons x xs') (#;Some (cycle' x xs' x xs')))) + +(do-template [ ] + [(def: #export ( s) + (All [a] (-> (Stream a) )) + (let [[h t] (cont;run s)] + ))] + + [head a h] + [tail (Stream a) t]) + +(def: #export (nth idx s) + (All [a] (-> Nat (Stream a) a)) + (let [[h t] (cont;run s)] + (if (n.> +0 idx) + (nth (n.dec idx) t) + h))) + +(do-template [ ] + [(def: #export ( pred xs) + (All [a] + (-> (Stream a) (List a))) + (let [[x xs'] (cont;run xs)] + (if + (list& x ( xs')) + (list)))) + + (def: #export ( pred xs) + (All [a] + (-> (Stream a) (Stream a))) + (let [[x xs'] (cont;run xs)] + (if + ( xs') + xs))) + + (def: #export ( pred xs) + (All [a] + (-> (Stream a) [(List a) (Stream a)])) + (let [[x xs'] (cont;run xs)] + (if + (let [[tail next] ( xs')] + [(#;Cons [x tail]) next]) + [(list) xs])))] + + [take-while drop-while split-while (-> a Bool) (pred x) pred] + [take drop split Nat (n.> +0 pred) (n.dec pred)] + ) + +(def: #export (unfold step init) + {#;doc "A stateful way of infinitely calculating the values of a stream."} + (All [a b] + (-> (-> a [a b]) a (Stream b))) + (let [[next x] (step init)] + (@lazy [x (unfold step next)]))) + +(def: #export (filter p xs) + (All [a] (-> (-> a Bool) (Stream a) (Stream a))) + (let [[x xs'] (cont;run xs)] + (if (p x) + (@lazy [x (filter p xs')]) + (filter p xs')))) + +(def: #export (partition p xs) + {#;doc "Split a stream in two based on a predicate. + + The left side contains all entries for which the predicate is true. + + The right side contains all entries for which the predicate is false."} + (All [a] (-> (-> a Bool) (Stream a) [(Stream a) (Stream a)])) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(struct: #export _ (Functor Stream) + (def: (map f fa) + (let [[h t] (cont;run fa)] + (@lazy [(f h) (map f t)])))) + +(struct: #export _ (CoMonad Stream) + (def: functor Functor) + (def: unwrap head) + (def: (split wa) + (let [[head tail] (cont;run wa)] + (@lazy [wa (split tail)])))) + +## [Pattern-matching] +(syntax: #export (^stream& [patterns (s;form (s;many s;any))] body [branches (s;some s;any)]) + {#;doc (doc "Allows destructuring of streams in pattern-matching expressions." + "Caveat emptor: Only use it for destructuring, and not for testing values within the streams." + (let [(^stream& x y z _tail) (some-stream-func 1 2 3)] + (func x y z)))} + (with-gensyms [g!s] + (let [body+ (` (let [(~@ (List/join (List/map (lambda [pattern] + (list (` [(~ pattern) (~ g!s)]) + (` (cont;run (~ g!s))))) + patterns)))] + (~ body)))] + (wrap (list& g!s body+ branches))))) diff --git a/stdlib/source/lux/codata/cont.lux b/stdlib/source/lux/codata/cont.lux index 7f1b787e1..f04b6a0ba 100644 --- a/stdlib/source/lux/codata/cont.lux +++ b/stdlib/source/lux/codata/cont.lux @@ -9,7 +9,7 @@ (control functor applicative monad) - (data (struct list))) + (data (coll list))) (.. function)) ## [Types] @@ -42,11 +42,17 @@ (k a)) k))) +(def: #export (continue f thunk) + {#;doc "Forces a continuation thunk to be evaluated."} + (All [i o] + (-> (-> i o) (Cont i o) o)) + (thunk f)) + (def: #export (run thunk) {#;doc "Forces a continuation thunk to be evaluated."} (All [a] (-> (Cont a) a)) - (thunk id)) + (continue id thunk)) ## [Structs] (struct: #export _ (Functor Cont) diff --git a/stdlib/source/lux/codata/io.lux b/stdlib/source/lux/codata/io.lux deleted file mode 100644 index 60ea73834..000000000 --- a/stdlib/source/lux/codata/io.lux +++ /dev/null @@ -1,57 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: {#;doc "A method for abstracting I/O and effectful computations to make it safe while writing pure functional code."} - lux - (lux (control functor - applicative - monad) - (data (struct list)))) - -## [Types] -(type: #export (IO a) - {#;doc "A type that represents synchronous, effectful computations that may interact with the outside world."} - (-> Void a)) - -## [Syntax] -(macro: #export (io tokens state) - {#;doc (doc "Delays the evaluation of an expression, by wrapping it in an IO 'thunk'." - "Great for wrapping effectful computations (which won't be performed until the IO is \"run\")." - (io (exec - (log! msg) - "Some value...")))} - (case tokens - (^ (list value)) - (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] - (#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) - - _ - (#;Left "Wrong syntax for io"))) - -## [Structures] -(struct: #export _ (Functor IO) - (def: (map f ma) - (io (f (ma (:! Void [])))))) - -(struct: #export _ (Applicative IO) - (def: functor Functor) - - (def: (wrap x) - (io x)) - - (def: (apply ff fa) - (io ((ff (:! Void [])) (fa (:! Void [])))))) - -(struct: #export _ (Monad IO) - (def: applicative Applicative) - - (def: (join mma) - (io ((mma (:! Void [])) (:! Void []))))) - -## [Functions] -(def: #export (run action) - {#;doc "A way to execute IO computations and perform their side-effects."} - (All [a] (-> (IO a) a)) - (action (:! Void []))) diff --git a/stdlib/source/lux/codata/struct/stream.lux b/stdlib/source/lux/codata/struct/stream.lux deleted file mode 100644 index 5691b0c69..000000000 --- a/stdlib/source/lux/codata/struct/stream.lux +++ /dev/null @@ -1,147 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control functor - monad - comonad) - [compiler #+ with-gensyms] - (macro ["s" syntax #+ syntax: Syntax]) - (data (struct [list "List/" Monad]) - bool) - (codata [cont #+ @lazy Cont]))) - -## [Types] -(type: #export (Stream a) - {#;doc "An infinite stream of lazily-evaluated values."} - (Cont [a (Stream a)])) - -## [Utils] -(def: (cycle' x xs init full) - (All [a] - (-> a (List a) a (List a) (Stream a))) - (case xs - #;Nil (@lazy [x (cycle' init full init full)]) - (#;Cons x' xs') (@lazy [x (cycle' x' xs' init full)]))) - -## [Functions] -(def: #export (iterate f x) - {#;doc "Create a stream by applying a function to a value, and to its result, on and on..."} - (All [a] - (-> (-> a a) a (Stream a))) - (@lazy [x (iterate f (f x))])) - -(def: #export (repeat x) - {#;doc "Repeat a value forever."} - (All [a] - (-> a (Stream a))) - (@lazy [x (repeat x)])) - -(def: #export (cycle xs) - {#;doc "Go over the elements of a list forever. - - The list shouldn't be empty."} - (All [a] - (-> (List a) (Maybe (Stream a)))) - (case xs - #;Nil #;None - (#;Cons x xs') (#;Some (cycle' x xs' x xs')))) - -(do-template [ ] - [(def: #export ( s) - (All [a] (-> (Stream a) )) - (let [[h t] (cont;run s)] - ))] - - [head a h] - [tail (Stream a) t]) - -(def: #export (at idx s) - (All [a] (-> Nat (Stream a) a)) - (let [[h t] (cont;run s)] - (if (n.> +0 idx) - (at (n.dec idx) t) - h))) - -(do-template [ ] - [(def: #export ( pred xs) - (All [a] - (-> (Stream a) (List a))) - (let [[x xs'] (cont;run xs)] - (if - (list& x ( xs')) - (list)))) - - (def: #export ( pred xs) - (All [a] - (-> (Stream a) (Stream a))) - (let [[x xs'] (cont;run xs)] - (if - ( xs') - xs))) - - (def: #export ( pred xs) - (All [a] - (-> (Stream a) [(List a) (Stream a)])) - (let [[x xs'] (cont;run xs)] - (if - (let [[tail next] ( xs')] - [(#;Cons [x tail]) next]) - [(list) xs])))] - - [take-while drop-while split-while (-> a Bool) (pred x) pred] - [take drop split Nat (n.> +0 pred) (n.dec pred)] - ) - -(def: #export (unfold step init) - {#;doc "A stateful way of infinitely calculating the values of a stream."} - (All [a b] - (-> (-> a [a b]) a (Stream b))) - (let [[next x] (step init)] - (@lazy [x (unfold step next)]))) - -(def: #export (filter p xs) - (All [a] (-> (-> a Bool) (Stream a) (Stream a))) - (let [[x xs'] (cont;run xs)] - (if (p x) - (@lazy [x (filter p xs')]) - (filter p xs')))) - -(def: #export (partition p xs) - {#;doc "Split a stream in two based on a predicate. - - The left side contains all entries for which the predicate is true. - - The right side contains all entries for which the predicate is false."} - (All [a] (-> (-> a Bool) (Stream a) [(Stream a) (Stream a)])) - [(filter p xs) (filter (complement p) xs)]) - -## [Structures] -(struct: #export _ (Functor Stream) - (def: (map f fa) - (let [[h t] (cont;run fa)] - (@lazy [(f h) (map f t)])))) - -(struct: #export _ (CoMonad Stream) - (def: functor Functor) - (def: unwrap head) - (def: (split wa) - (let [[head tail] (cont;run wa)] - (@lazy [wa (split tail)])))) - -## [Pattern-matching] -(syntax: #export (^stream& [patterns (s;form (s;many s;any))] body [branches (s;some s;any)]) - {#;doc (doc "Allows destructuring of streams in pattern-matching expressions." - "Caveat emptor: Only use it for destructuring, and not for testing values within the streams." - (let [(^stream& x y z _tail) (some-stream-func 1 2 3)] - (func x y z)))} - (with-gensyms [g!s] - (let [body+ (` (let [(~@ (List/join (List/map (lambda [pattern] - (list (` [(~ pattern) (~ g!s)]) - (` (cont;run (~ g!s))))) - patterns)))] - (~ body)))] - (wrap (list& g!s body+ branches))))) diff --git a/stdlib/source/lux/compiler.lux b/stdlib/source/lux/compiler.lux index 367217524..9f667ebce 100644 --- a/stdlib/source/lux/compiler.lux +++ b/stdlib/source/lux/compiler.lux @@ -9,7 +9,7 @@ (control functor applicative monad) - (data (struct [list #* "List/" Monoid Monad]) + (data (coll [list #* "List/" Monoid Monad]) [number] [text "Text/" Monoid Eq] [product] diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index e55386d9d..73529e987 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -6,11 +6,11 @@ (;module: {#;doc "The actor model of concurrency."} lux (lux (control monad) - (codata [io #- run] - function) + [io #- run] + (codata function) (data [error #- fail] text/format - (struct [list "List/" Monoid Monad]) + (coll [list "List/" Monoid Monad]) [product] [number "Nat/" Codec]) [compiler #+ with-gensyms] @@ -154,7 +154,7 @@ (def: method^ (Syntax Method) (s;form (do s;Monad - [_ (s;sample! (' method:)) + [_ (s;this! (' method:)) vars (s;default (list) (s;tuple (s;some s;local-symbol))) [name args] (s;form ($_ s;seq s;local-symbol @@ -171,7 +171,7 @@ (def: stop^ (Syntax AST) (s;form (do s;Monad - [_ (s;sample! (' stop:))] + [_ (s;this! (' stop:))] s;any))) (def: actor-decl^ diff --git a/stdlib/source/lux/concurrency/atom.lux b/stdlib/source/lux/concurrency/atom.lux index ae8c7fa21..c879db02d 100644 --- a/stdlib/source/lux/concurrency/atom.lux +++ b/stdlib/source/lux/concurrency/atom.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io #- run]) + (lux [io #- run] host)) (jvm-import (java.util.concurrent.atomic.AtomicReference V) diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux index 45b9e1839..14563e534 100644 --- a/stdlib/source/lux/concurrency/frp.lux +++ b/stdlib/source/lux/concurrency/frp.lux @@ -9,9 +9,9 @@ applicative monad eq) - (codata [io #- run] - function) - (data (struct [list]) + [io #- run] + (codata function) + (data (coll [list]) text/format) [compiler] (macro ["s" syntax #+ syntax: Syntax])) diff --git a/stdlib/source/lux/concurrency/promise.lux b/stdlib/source/lux/concurrency/promise.lux index 1d33ee4ee..60cffe2fe 100644 --- a/stdlib/source/lux/concurrency/promise.lux +++ b/stdlib/source/lux/concurrency/promise.lux @@ -5,12 +5,12 @@ (;module: lux - (lux (data (struct [list #* "" Functor]) + (lux (data (coll [list #* "" Functor]) number text/format error) - (codata [io #- run] - function) + [io #- run] + (codata function) (control functor applicative monad) diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index 06912a25a..b088bd607 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -8,10 +8,10 @@ (lux (control functor applicative monad) - (codata [io #- run]) - (data (struct [list #* "List/" Functor] - [dict #+ Dict] - ["Q" queue]) + [io #- run] + (data (coll [list #* "List/" Functor] + [dict #+ Dict] + ["Q" queue]) [product] [text] maybe diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux index 046511190..00d807ef1 100644 --- a/stdlib/source/lux/control/comonad.lux +++ b/stdlib/source/lux/control/comonad.lux @@ -6,7 +6,7 @@ (;module: lux ["F" ../functor] - [lux/data/struct/list #* "" Fold]) + [lux/data/coll/list #* "" Fold]) ## [Signatures] (sig: #export (CoMonad w) diff --git a/stdlib/source/lux/control/effect.lux b/stdlib/source/lux/control/effect.lux deleted file mode 100644 index 2b81ad543..000000000 --- a/stdlib/source/lux/control/effect.lux +++ /dev/null @@ -1,406 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: {#;doc "Algebraic effects."} - lux - (lux (control ["F" functor] - applicative - monad) - (codata [io #- run]) - (data (struct [list "List/" Monad Monoid]) - [number "Nat/" Codec] - text/format - error - [ident "Ident/" Eq] - [text]) - [compiler] - [macro] - (macro [ast] - ["s" syntax #+ syntax: Syntax] - (syntax [common])) - [type])) - -## [Type] -(type: #export (Eff F a) - {#;doc "A Free Monad implementation for algebraic effects."} - (#Pure a) - (#Effect (F (Eff F a)))) - -(sig: #export (Handler E M) - {#;doc "A way to interpret effects into arbitrary monads."} - (: (Monad M) - monad) - (: (All [a] (-> (E a) (M a))) - handle)) - -## [Values] -(struct: #export (Functor dsl) - (All [F] (-> (F;Functor F) (F;Functor (Eff F)))) - (def: (map f ea) - (case ea - (#Pure a) - (#Pure (f a)) - - (#Effect value) - (#Effect (:: dsl map (map f) value))))) - -(struct: #export (Applicative dsl) - (All [F] (-> (F;Functor F) (Applicative (Eff F)))) - (def: functor (Functor dsl)) - - (def: (wrap a) - (#Pure a)) - - (def: (apply ef ea) - (case [ef ea] - [(#Pure f) (#Pure a)] - (#Pure (f a)) - - [(#Pure f) (#Effect fa)] - (#Effect (:: dsl map - (:: (Functor dsl) map f) - fa)) - - [(#Effect ff) _] - (#Effect (:: dsl map - (lambda [f] (apply f ea)) - ff)) - ))) - -(struct: #export (Monad dsl) - (All [F] (-> (F;Functor F) (Monad (Eff F)))) - (def: applicative (Applicative dsl)) - - (def: (join efefa) - (case efefa - (#Pure efa) - (case efa - (#Pure a) - (#Pure a) - - (#Effect fa) - (#Effect fa)) - - (#Effect fefa) - (#Effect (:: dsl map - (:: (Monad dsl) join) - fefa)) - ))) - -(type: #hidden (|@ L R) - (All [a] (| (L a) (R a)))) - -(def: #hidden (combine-functors left right) - (All [L R] - (-> (F;Functor L) (F;Functor R) - (F;Functor (|@ L R)))) - (struct - (def: (map f l|r) - (case l|r - (+0 l) (+0 (:: left map f l)) - (+1 r) (+1 (:: right map f r))) - ))) - -(def: #hidden (combine-handlers Monad left right) - (All [L R M] - (-> (Monad M) - (Handler L M) (Handler R M) - (Handler (|@ L R) M))) - (struct - (def: monad Monad) - - (def: (handle l|r) - (case l|r - (#;Left l) (:: left handle l) - (#;Right r) (:: right handle r) - )))) - -## [Syntax] -(syntax: #export (|E [effects (s;many s;any)]) - {#;doc (doc "A way to combine smaller effect into a larger effect." - (type: EffABC (|E EffA EffB EffC)))} - (wrap (list (` ($_ ;;|@ (~@ effects)))))) - -(syntax: #export (|F [functors (s;many s;any)]) - {#;doc (doc "A way to combine smaller effect functors into a larger functor." - (def: Functor - (Functor EffABC) - (|F Functor Functor Functor)))} - (wrap (list (` ($_ ;;combine-functors (~@ functors)))))) - -(syntax: #export (|H monad [handlers (s;many s;any)]) - {#;doc (doc "A way to combine smaller effect handlers into a larger handler." - (def: Handler - (Handler EffABC io;IO) - (|H io;Monad - Handler Handler Handler)))} - (do @ - [g!combiner (compiler;gensym "")] - (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))] - ($_ (~ g!combiner) (~@ handlers)))))))) - -(type: Op - {#name Text - #inputs (List AST) - #output AST}) - -(def: op^ - (Syntax Op) - (s;form (s;either ($_ s;seq - s;local-symbol - (s;tuple (s;some s;any)) - s;any) - ($_ s;seq - s;local-symbol - (:: s;Monad wrap (list)) - s;any)))) - -(syntax: #export (effect: [exp-lvl common;export-level] - [name s;local-symbol] - [ops (s;many op^)]) - {#;doc (doc "Define effects by specifying which operations and constants a handler must provide." - (effect: #export EffA - (opA [Nat Text] Bool) - (fieldA Nat)) - - "In this case, 'opA' will be a function (-> Nat Text Bool)." - "'fieldA' will be a value provided by a handler.")} - (do @ - [g!output (compiler;gensym "g!output") - #let [op-types (List/map (lambda [op] - (let [g!tag (ast;tag ["" (get@ #name op)]) - g!inputs (` [(~@ (get@ #inputs op))]) - g!output (` (-> (~ (get@ #output op)) (~ g!output)))] - (` ((~ g!tag) (~ g!inputs) (~ g!output))))) - ops) - type-name (ast;symbol ["" name]) - type-def (` (type: (~@ (common;gen-export-level exp-lvl)) - ((~ type-name) (~ g!output)) - (~@ op-types))) - op-tags (List/map (|>. (get@ #name) [""] ast;tag (list) ast;tuple) - ops) - functor-def (` (struct: (~@ (common;gen-export-level exp-lvl)) (~' _) (F;Functor (~ type-name)) - (def: ((~' map) (~' f) (~' fa)) - (case (~' fa) - (^template [(~' )] - ((~' ) (~' params) (~' cont)) - ((~' ) (~' params) (. (~' f) (~' cont)))) - ((~@ op-tags)))) - )) - function-defs (List/map (lambda [op] - (let [g!name (ast;symbol ["" (get@ #name op)]) - g!tag (ast;tag ["" (get@ #name op)]) - g!params (: (List AST) - (case (list;size (get@ #inputs op)) - +0 (list) - s (|> (list;n.range +0 (n.dec s)) - (List/map (|>. Nat/encode - (format "_") - [""] - ast;symbol)))))] - (` (def: (~@ (common;gen-export-level exp-lvl)) ((~ g!name) (~@ g!params)) - (-> (~@ (get@ #inputs op)) - ((~ type-name) (~ (get@ #output op)))) - ((~ g!tag) [(~@ g!params)] ;id))))) - ops)]] - (wrap (list& type-def - functor-def - function-defs)))) - -(type: Translation - {#effect Ident - #target-type AST - #target-monad AST}) - -(def: translation^ - (Syntax Translation) - (s;form (do s;Monad - [_ (s;sample! (' =>))] - (s;seq s;symbol - (s;tuple (s;seq s;any - s;any)))))) - -(syntax: #export (handler: [exp-lvl common;export-level] - [name s;local-symbol] - [[effect target-type target-monad] translation^] - [defs (s;many (common;def *compiler*))]) - {#;doc (doc "Define effect handlers by implementing the operations and values of an effect." - (handler: _ - (=> EffA [IO Monad]) - (def: (opA length sample) - (:: Monad wrap (n.< length - (size sample)))) - - (def: fieldA (:: Monad wrap +10))) - - "Since a name for the handler was not specified, 'handler:' will generate the name as Handler.")} - (do @ - [(^@ effect [e-module _]) (compiler;un-alias effect) - g!input (compiler;gensym "g!input") - g!cont (compiler;gensym "g!cont") - g!value (compiler;gensym "value") - g!wrap (compiler;gensym "wrap") - #let [g!cases (|> defs - (List/map (lambda [def] - (let [g!tag (ast;tag [e-module (get@ #common;def-name def)]) - g!args (List/map (|>. [""] ast;symbol) - (get@ #common;def-args def)) - eff-calc (case (get@ #common;def-type def) - #;None - (get@ #common;def-value def) - - (#;Some type) - (` (: (~ type) (~ (get@ #common;def-value def))))) - invocation (case g!args - #;Nil - eff-calc - - _ - (` ((~ eff-calc) (~@ g!args))))] - (list (` ((~ g!tag) [(~@ g!args)] (~ g!cont))) - (` (do (~ target-monad) - [(~' #let) [(~ g!wrap) (~' wrap)] - (~ g!value) (~ invocation)] - ((~ g!wrap) ((~ g!cont) (~ g!value))))) - )))) - List/join)]] - (wrap (list (` (struct: (~@ (common;gen-export-level exp-lvl)) (~ (ast;symbol ["" name])) - (;;Handler (~ (ast;symbol effect)) (~ target-type)) - (def: (~' monad) (~ target-monad)) - - (def: ((~' handle) (~ g!input)) - (case (~ g!input) - (~@ g!cases)) - ))))))) - -(def: #export (with-handler handler body) - {#;doc "Handles an effectful computation with the given handler to produce a monadic value."} - (All [E M a] (-> (Handler E M) (Eff E a) (M a))) - (case body - (#Pure value) - (:: handler wrap value) - - (#Effect effect) - (do (get@ #monad handler) - [result (:: handler handle effect)] - (with-handler handler result)) - )) - -(def: (un-apply type-app) - (-> Type Type) - (case type-app - (#;AppT effect value) - effect - - _ - (error! (format "Wrong type format: " (%type type-app))))) - -(def: (clean-effect effect) - (-> Type Type) - (case effect - (#;UnivQ env body) - (#;UnivQ (list) body) - - _ - (error! (format "Wrong effect format: " (%type effect))))) - -(def: g!functor AST (ast;symbol ["" "\t@E\t"])) - -(syntax: #export (doE functor [bindings (s;tuple (s;some s;any))] body) - {#;doc (doc "An alternative to the 'do' macro for monads." - (with-handler Handler - (doE Functor - [a (lift fieldA) - b (lift fieldB) - c (lift fieldC)] - (wrap ($_ n.+ a b c)))))} - (do @ - [g!output (compiler;gensym "")] - (wrap (list (` (let [(~ g!functor) (~ functor)] - (do (Monad (~ g!functor)) - [(~@ bindings) - (~ g!output) (~ body)] - (#;;Pure (~ g!output))))))))) - -(def: (flatten-effect-stack stack) - (-> Type (List Type)) - (case stack - (#;SumT left right) - (List/append (flatten-effect-stack left) - (flatten-effect-stack right)) - - (^ (#;AppT branches (#;VarT _))) - (flatten-effect-stack branches) - - (^ (#;AppT (#;AppT (#;NamedT (ident-for ;;|@) _) - left) - right)) - (#;Cons left (flatten-effect-stack right)) - - (^ (#;AppT (#;AppT (#;NamedT (ident-for ;;Eff) _) - effect) - param)) - (list effect) - - _ - (list stack) - )) - -(def: (same-effect? expected actual) - (case [expected actual] - [(#;NamedT e-name _) (#;NamedT a-name _)] - (Ident/= e-name a-name) - - _ - false)) - -(def: (nest-effect idx total base) - (-> Nat Nat AST AST) - (cond (n.= +0 idx) - (` (+0 (~ base))) - - (n.> +2 total) - (` (+1 (~ (nest-effect (n.dec idx) (n.dec total) base)))) - - ## else - (` (+1 (~ base))) - )) - -(syntax: #export (lift [value (s;alt s;symbol - s;any)]) - {#;doc (doc "A way to (automatically) lift effectful fields and operations from simple effects into the larger space of composite effects." - (with-handler Handler - (doE Functor - [a (lift fieldA) - b (lift fieldB) - c (lift fieldC)] - (wrap ($_ n.+ a b c)))))} - (case value - (#;Left var) - (do @ - [input (compiler;find-type var) - output compiler;expected-type] - (case [input output] - (^=> [(#;AppT eff0 _) (#;AppT stackT0 recT0)] - [(type;apply-type stackT0 recT0) (#;Some unfoldT0)] - [stackT0 (^ (#;AppT (#;NamedT (ident-for ;;Eff) _) - stackT1))] - [(type;apply-type stackT1 recT0) (#;Some unfoldT1)] - [(flatten-effect-stack unfoldT1) stack] - [(|> stack list;enumerate - (list;find (lambda [[idx effect]] - (same-effect? effect eff0)))) - (#;Some [idx _])]) - (wrap (list (` (#;;Effect (:: (~ g!functor) (~' map) (~' wrap) - (~ (nest-effect idx (list;size stack) (ast;symbol var)))))))) - - _ - (compiler;fail (format "Invalid type to lift: " (%type output))))) - - (#;Right node) - (do @ - [g!value (compiler;gensym "")] - (wrap (list (` (let [(~ g!value) (~ node)] - (;;lift (~ g!value))))))))) diff --git a/stdlib/source/lux/data/char.lux b/stdlib/source/lux/data/char.lux index 9c9baaf20..49c247f93 100644 --- a/stdlib/source/lux/data/char.lux +++ b/stdlib/source/lux/data/char.lux @@ -65,13 +65,13 @@ (or (n.= +4 size) (n.= +5 size))) (if (n.= +4 size) - (case (text;at +2 y) + (case (text;nth +2 y) #;None (#;Left (Text/append "Wrong syntax for Char: " y)) (#;Some char) (#;Right char)) - (case [(text;at +2 y) (text;at +3 y)] + (case [(text;nth +2 y) (text;nth +3 y)] [(#;Some #"\\") (#;Some char)] (case char #"t" (#;Right #"\t") diff --git a/stdlib/source/lux/data/coll/array.lux b/stdlib/source/lux/data/coll/array.lux new file mode 100644 index 000000000..f95754262 --- /dev/null +++ b/stdlib/source/lux/data/coll/array.lux @@ -0,0 +1,225 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monoid + functor + applicative + monad + eq + fold) + (data error + (coll [list "List/" Fold]) + [product]) + )) + +## [Types] +(type: #export (Array a) + {#;doc "Mutable arrays."} + (#;HostT "#Array" (#;Cons a #;Nil))) + +## [Functions] +(def: #export (new size) + (All [a] (-> Nat (Array a))) + (_lux_proc ["array" "new"] [size])) + +(def: #export (size xs) + (All [a] (-> (Array a) Nat)) + (_lux_proc ["array" "size"] [xs])) + +(def: #export (get i xs) + (All [a] + (-> Nat (Array a) (Maybe a))) + (_lux_proc ["array" "get"] [xs i])) + +(def: #export (put i x xs) + (All [a] + (-> Nat a (Array a) (Array a))) + (_lux_proc ["array" "put"] [xs i x])) + +(def: #export (remove i xs) + (All [a] + (-> Nat (Array a) (Array a))) + (_lux_proc ["array" "remove"] [xs i])) + +(def: #export (copy length src-start src-array dest-start dest-array) + (All [a] (-> Nat Nat (Array a) Nat (Array a) + (Array a))) + (if (n.= +0 length) + dest-array + (List/fold (lambda [offset target] + (case (get (n.+ offset src-start) src-array) + #;None + target + + (#;Some value) + (put (n.+ offset dest-start) value target))) + dest-array + (list;n.range +0 (n.dec length))))) + +(def: #export (occupied array) + {#;doc "Finds out how many cells in an array are occupied."} + (All [a] (-> (Array a) Nat)) + (List/fold (lambda [idx count] + (case (get idx array) + #;None + count + + (#;Some _) + (n.inc count))) + +0 + (list;indices (size array)))) + +(def: #export (vacant array) + {#;doc "Finds out how many cells in an array are vacant."} + (All [a] (-> (Array a) Nat)) + (n.- (occupied array) (size array))) + +(def: #export (filter p xs) + (All [a] + (-> (-> a Bool) (Array a) (Array a))) + (List/fold (: (-> Nat (Array ($ +0)) (Array ($ +0))) + (lambda [idx xs'] + (case (get idx xs) + #;None + xs' + + (#;Some x) + (if (p x) + xs' + (remove idx xs'))))) + xs + (list;indices (size xs)))) + +(def: #export (find p xs) + (All [a] + (-> (-> a Bool) (Array a) (Maybe a))) + (let [arr-size (size xs)] + (loop [idx +0] + (if (n.< arr-size idx) + (case (get idx xs) + #;None + (recur (n.inc idx)) + + (#;Some x) + (if (p x) + (#;Some x) + (recur (n.inc idx)))) + #;None)))) + +(def: #export (find+ p xs) + {#;doc "Just like 'find', but with access to the index of each value."} + (All [a] + (-> (-> Nat a Bool) (Array a) (Maybe [Nat a]))) + (let [arr-size (size xs)] + (loop [idx +0] + (if (n.< arr-size idx) + (case (get idx xs) + #;None + (recur (n.inc idx)) + + (#;Some x) + (if (p idx x) + (#;Some [idx x]) + (recur (n.inc idx)))) + #;None)))) + +(def: #export (clone xs) + (All [a] (-> (Array a) (Array a))) + (let [arr-size (size xs)] + (List/fold (lambda [idx ys] + (case (get idx xs) + #;None + ys + + (#;Some x) + (put idx x ys))) + (new arr-size) + (list;indices arr-size)))) + +(def: #export (from-list xs) + (All [a] (-> (List a) (Array a))) + (product;right (List/fold (lambda [x [idx arr]] + [(n.inc idx) (put idx x arr)]) + [+0 (new (list;size xs))] + xs))) + +(def: #export (to-list array) + (All [a] (-> (Array a) (List a))) + (let [_size (size array)] + (product;right (List/fold (lambda [_ [idx tail]] + (case (get idx array) + (#;Some head) + [(n.dec idx) (#;Cons head tail)] + + #;None + [(n.dec idx) tail])) + [(n.dec _size) #;Nil] + (list;repeat _size []) + )))) + +## [Structures] +(struct: #export (Eq Eq) + (All [a] (-> (Eq a) (Eq (Array a)))) + (def: (= xs ys) + (let [sxs (size xs) + sxy (size ys)] + (and (n.= sxy sxs) + (List/fold (lambda [idx prev] + (and prev + (case [(get idx xs) (get idx ys)] + [#;None #;None] + true + + [(#;Some x) (#;Some y)] + (:: Eq = x y) + + _ + false))) + true + (list;n.range +0 (n.dec sxs))))) + )) + +(struct: #export Monoid (All [a] + (Monoid (Array a))) + (def: unit (new +0)) + + (def: (append xs ys) + (let [sxs (size xs) + sxy (size ys)] + (|> (new (n.+ sxy sxs)) + (copy sxs +0 xs +0) + (copy sxy +0 ys sxs))))) + +(struct: #export _ (Functor Array) + (def: (map f ma) + (let [arr-size (size ma)] + (if (n.= +0 arr-size) + (new arr-size) + (List/fold (: (-> Nat (Array ($ +1)) (Array ($ +1))) + (lambda [idx mb] + (case (get idx ma) + #;None + mb + + (#;Some x) + (put idx (f x) mb)))) + (new arr-size) + (list;n.range +0 (n.dec arr-size))))))) + +(struct: #export _ (Fold Array) + (def: (fold f init xs) + (let [arr-size (size xs)] + (loop [so-far init + idx +0] + (if (n.< arr-size idx) + (case (get idx xs) + #;None + (recur so-far (n.inc idx)) + + (#;Some value) + (recur (f value so-far) (n.inc idx))) + so-far))))) diff --git a/stdlib/source/lux/data/coll/dict.lux b/stdlib/source/lux/data/coll/dict.lux new file mode 100644 index 000000000..fe77d0bea --- /dev/null +++ b/stdlib/source/lux/data/coll/dict.lux @@ -0,0 +1,687 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control hash + eq) + (data maybe + (coll [list "List/" Fold Functor Monoid] + [array #+ Array "Array/" Functor Fold]) + [bit] + [product] + text/format + [number]) + )) + +## This implementation of Hash Array Mapped Trie (HAMT) is based on +## Clojure's PersistentHashMap implementation. +## That one is further based on Phil Bagwell's Hash Array Mapped Trie. + +## [Utils] +## Bitmaps are used to figure out which branches on a #Base node are +## populated. The number of bits that are 1s in a bitmap signal the +## size of the #Base node. +(type: BitMap Nat) + +## Represents the position of a node in a BitMap. +## It's meant to be a single bit set on a 32-bit word. +## The position of the bit reflects whether an entry in an analogous +## position exists within a #Base, as reflected in it's BitMap. +(type: BitPosition Nat) + +## An index into an array. +(type: Index Nat) + +## A hash-code derived from a key during tree-traversal. +(type: Hash-Code Nat) + +## Represents the nesting level of a leaf or node, when looking-it-up +## while exploring the tree. +## Changes in levels are done by right-shifting the hashes of keys by +## the appropriate multiple of the branching-exponent. +## A shift of 0 means root level. +## A shift of (* branching-exponent 1) means level 2. +## A shift of (* branching-exponent N) means level N+1. +(type: Level Nat) + +## Nodes for the tree data-structure that organizes the data inside +## Dicts. +(type: (Node k v) + (#Hierarchy Nat (Array (Node k v))) + (#Base BitMap + (Array (Either (Node k v) + [k v]))) + (#Collisions Hash-Code (Array [k v]))) + +## #Hierarchy nodes are meant to point down only to lower-level nodes. +(type: (Hierarchy k v) + [Nat (Array (Node k v))]) + +## #Base nodes may point down to other nodes, but also to leaves, +## which are KV pairs. +(type: (Base k v) + (Array (Either (Node k v) + [k v]))) + +## #Collisions are collections of KV-pairs for which the key is +## different on each case, but their hashes are all the same (thus +## causing a collision). +(type: (Collisions k v) + (Array [k v])) + +## That bitmap for an empty #Base is 0. +## Which is the same as 0000 0000 0000 0000 0000 0000 0000 0000. +## Or 0x00000000. +## Which is 32 zeroes, since the branching factor is 32. +(def: clean-bitmap + BitMap + +0) + +## Bitmap position (while looking inside #Base nodes) is determined by +## getting 5 bits from a hash of the key being looked up and using +## them as an index into the array inside #Base. +## Since the data-structure can have multiple levels (and the hash has +## more than 5 bits), the binary-representation of the hash is shifted +## by 5 positions on each step (2^5 = 32, which is the branching +## factor). +## The initial shifting level, though, is 0 (which corresponds to the +## shift in the shallowest node on the tree, which is the root node). +(def: root-level + Level + +0) + +## The exponent to which 2 must be elevated, to reach the branching +## factor of the data-structure. +(def: branching-exponent + Nat + +5) + +## The threshold on which #Hierarchy nodes are demoted to #Base nodes, +## which is 1/4 of the branching factor (or a left-shift 2). +(def: demotion-threshold + Nat + (bit;<< (n.- +2 branching-exponent) +1)) + +## The threshold on which #Base nodes are promoted to #Hierarchy nodes, +## which is 1/2 of the branching factor (or a left-shift 1). +(def: promotion-threshold + Nat + (bit;<< (n.- +1 branching-exponent) +1)) + +## The size of hierarchy-nodes, which is 2^(branching-exponent). +(def: hierarchy-nodes-size + Nat + (bit;<< branching-exponent +1)) + +## The cannonical empty node, which is just an empty #Base node. +(def: empty + Node + (#Base clean-bitmap (array;new +0))) + +## Expands a copy of the array, to have 1 extra slot, which is used +## for storing the value. +(def: (insert! idx value old-array) + (All [a] (-> Index a (Array a) (Array a))) + (let [old-size (array;size old-array)] + (|> (: (Array ($ +0)) + (array;new (n.inc old-size))) + (array;copy idx +0 old-array +0) + (array;put idx value) + (array;copy (n.- idx old-size) idx old-array (n.inc idx))))) + +## Creates a copy of an array with an index set to a particular value. +(def: (update! idx value array) + (All [a] (-> Index a (Array a) (Array a))) + (|> array array;clone (array;put idx value))) + +## Creates a clone of the array, with an empty position at index. +(def: (vacant! idx array) + (All [a] (-> Index (Array a) (Array a))) + (|> array array;clone (array;remove idx))) + +## Shrinks a copy of the array by removing the space at index. +(def: (remove! idx array) + (All [a] (-> Index (Array a) (Array a))) + (let [new-size (n.dec (array;size array))] + (|> (array;new new-size) + (array;copy idx +0 array +0) + (array;copy (n.- idx new-size) (n.inc idx) array idx)))) + +## Given a top-limit for indices, produces all indices in [0, R). +(def: indices-for + (-> Nat (List Index)) + (|>. n.dec (list;n.range +0))) + +## Increases the level-shift by the branching-exponent, to explore +## levels further down the tree. +(def: level-up + (-> Level Level) + (n.+ branching-exponent)) + +(def: hierarchy-mask BitMap (n.dec hierarchy-nodes-size)) + +## Gets the branching-factor sized section of the hash corresponding +## to a particular level, and uses that as an index into the array. +(def: (level-index level hash) + (-> Level Hash-Code Index) + (bit;& hierarchy-mask + (bit;>>> level hash))) + +## A mechanism to go from indices to bit-positions. +(def: (->bit-position index) + (-> Index BitPosition) + (bit;<< index +1)) + +## The bit-position within a base that a given hash-code would have. +(def: (bit-position level hash) + (-> Level Hash-Code BitPosition) + (->bit-position (level-index level hash))) + +(def: (bit-position-is-set? bit bitmap) + (-> BitPosition BitMap Bool) + (not (n.= clean-bitmap (bit;& bit bitmap)))) + +## Figures out whether a bitmap only contains a single bit-position. +(def: only-bit-position? + (-> BitPosition BitMap Bool) + n.=) + +(def: (set-bit-position bit bitmap) + (-> BitPosition BitMap BitMap) + (bit;| bit bitmap)) + +(def: unset-bit-position + (-> BitPosition BitMap BitMap) + bit;^) + +## Figures out the size of a bitmap-indexed array by counting all the +## 1s within the bitmap. +(def: bitmap-size + (-> BitMap Nat) + bit;count) + +## A mask that, for a given bit position, only allows all the 1s prior +## to it, which would indicate the bitmap-size (and, thus, index) +## associated with it. +(def: bit-position-mask + (-> BitPosition BitMap) + n.dec) + +## The index on the base array, based on it's bit-position. +(def: (base-index bit-position bitmap) + (-> BitPosition BitMap Index) + (bitmap-size (bit;& (bit-position-mask bit-position) + bitmap))) + +## Produces the index of a KV-pair within a #Collisions node. +(def: (collision-index Hash key colls) + (All [K V] (-> (Hash K) K (Collisions K V) (Maybe Index))) + (:: Monad map product;left + (array;find+ (lambda [idx [key' val']] + (:: Hash = key key')) + colls))) + +## When #Hierarchy nodes grow too small, they're demoted to #Base +## nodes to save space. +(def: (demote-hierarchy except-idx [h-size h-array]) + (All [k v] (-> Index (Hierarchy k v) [BitMap (Base k v)])) + (product;right (List/fold (lambda [idx [insertion-idx node]] + (let [[bitmap base] node] + (case (array;get idx h-array) + #;None [insertion-idx node] + (#;Some sub-node) (if (n.= except-idx idx) + [insertion-idx node] + [(n.inc insertion-idx) + [(set-bit-position (->bit-position idx) bitmap) + (array;put insertion-idx (#;Left sub-node) base)]]) + ))) + [+0 [clean-bitmap + (: (Base ($ +0) ($ +1)) + (array;new (n.dec h-size)))]] + (list;indices (array;size h-array))))) + +## When #Base nodes grow too large, they're promoted to #Hierarchy to +## add some depth to the tree and help keep it's balance. +(def: (promote-base put' Hash level bitmap base) + (All [K V] + (-> (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V)) + (Hash K) Level + BitMap (Base K V) + (Array (Node K V)))) + (product;right (List/fold (lambda [hierarchy-idx (^@ default [base-idx h-array])] + (if (bit-position-is-set? (->bit-position hierarchy-idx) + bitmap) + [(n.inc base-idx) + (case (array;get base-idx base) + (#;Some (#;Left sub-node)) + (array;put hierarchy-idx sub-node h-array) + + (#;Some (#;Right [key' val'])) + (array;put hierarchy-idx + (put' (level-up level) (:: Hash hash key') key' val' Hash empty) + h-array) + + #;None + (undefined))] + default)) + [+0 + (: (Array (Node ($ +0) ($ +1))) + (array;new hierarchy-nodes-size))] + (indices-for hierarchy-nodes-size)))) + +## All empty nodes look the same (a #Base node with clean bitmap is +## used). +## So, this test is introduced to detect them. +(def: (empty?' node) + (All [K V] (-> (Node K V) Bool)) + (case node + (^~ (#Base ;;clean-bitmap _)) + true + + _ + false)) + +(def: (put' level hash key val Hash node) + (All [K V] (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V))) + (case node + ## For #Hierarchy nodes, I check whether I can add the element to + ## a sub-node. If impossible, I introduced a new singleton sub-node. + (#Hierarchy _size hierarchy) + (let [idx (level-index level hash) + [_size' sub-node] (: [Nat (Node ($ +0) ($ +1))] + (case (array;get idx hierarchy) + (#;Some sub-node) + [_size sub-node] + + _ + [(n.inc _size) empty]))] + (#Hierarchy _size' + (update! idx (put' (level-up level) hash key val Hash sub-node) + hierarchy))) + + ## For #Base nodes, I check if the corresponding BitPosition has + ## already been used. + (#Base bitmap base) + (let [bit (bit-position level hash)] + (if (bit-position-is-set? bit bitmap) + ## If so... + (let [idx (base-index bit bitmap)] + (case (array;get idx base) + #;None + (undefined) + + ## If it's being used by a node, I add the KV to it. + (#;Some (#;Left sub-node)) + (let [sub-node' (put' (level-up level) hash key val Hash sub-node)] + (#Base bitmap (update! idx (#;Left sub-node') base))) + + ## Otherwise, if it's being used by a KV, I compare the keys. + (#;Some (#;Right key' val')) + (if (:: Hash = key key') + ## If the same key is found, I replace the value. + (#Base bitmap (update! idx (#;Right key val) base)) + ## Otherwise, I compare the hashes of the keys. + (#Base bitmap (update! idx + (#;Left (let [hash' (:: Hash hash key')] + (if (n.= hash hash') + ## If the hashes are + ## the same, a new + ## #Collisions node + ## is added. + (#Collisions hash (|> (: (Array [($ +0) ($ +1)]) + (array;new +2)) + (array;put +0 [key' val']) + (array;put +1 [key val]))) + ## Otherwise, I can + ## just keep using + ## #Base nodes, so I + ## add both KV pairs + ## to the empty one. + (let [next-level (level-up level)] + (|> empty + (put' next-level hash' key' val' Hash) + (put' next-level hash key val Hash)))))) + base))))) + ## However, if the BitPosition has not been used yet, I check + ## whether this #Base node is ready for a promotion. + (let [base-count (bitmap-size bitmap)] + (if (n.>= promotion-threshold base-count) + ## If so, I promote it to a #Hierarchy node, and add the new + ## KV-pair as a singleton node to it. + (#Hierarchy (n.inc base-count) + (|> (promote-base put' Hash level bitmap base) + (array;put (level-index level hash) + (put' (level-up level) hash key val Hash empty)))) + ## Otherwise, I just resize the #Base node to accommodate the + ## new KV-pair. + (#Base (set-bit-position bit bitmap) + (insert! (base-index bit bitmap) (#;Right [key val]) base)))))) + + ## For #Collisions nodes, I compare the hashes. + (#Collisions _hash _colls) + (if (n.= hash _hash) + ## If they're equal, that means the new KV contributes to the + ## collisions. + (case (collision-index Hash key _colls) + ## If the key was already present in the collisions-list, it's + ## value gets updated. + (#;Some coll-idx) + (#Collisions _hash (update! coll-idx [key val] _colls)) + + ## Otherwise, the KV-pair is added to the collisions-list. + #;None + (#Collisions _hash (insert! (array;size _colls) [key val] _colls))) + ## If the hashes are not equal, I create a new #Base node that + ## contains the old #Collisions node, plus the new KV-pair. + (|> (#Base (bit-position level _hash) + (|> (: (Base ($ +0) ($ +1)) + (array;new +1)) + (array;put +0 (#;Left node)))) + (put' level hash key val Hash))) + )) + +(def: (remove' level hash key Hash node) + (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Node K V))) + (case node + ## For #Hierarchy nodes, find out if there's a valid sub-node for + ## the Hash-Code. + (#Hierarchy h-size h-array) + (let [idx (level-index level hash)] + (case (array;get idx h-array) + ## If not, there's nothing to remove. + #;None + node + + ## But if there is, try to remove the key from the sub-node. + (#;Some sub-node) + (let [sub-node' (remove' (level-up level) hash key Hash sub-node)] + ## Then check if a removal was actually done. + (if (is sub-node sub-node') + ## If not, then there's nothing to change here either. + node + ## But if the sub-removal yielded an empty sub-node... + (if (empty?' sub-node') + ## Check if it's due time for a demotion. + (if (n.<= demotion-threshold h-size) + ## If so, perform it. + (#Base (demote-hierarchy idx [h-size h-array])) + ## Otherwise, just clear the space. + (#Hierarchy (n.dec h-size) (vacant! idx h-array))) + ## But if the sub-removal yielded a non-empty node, then + ## just update the hiearchy branch. + (#Hierarchy h-size (update! idx sub-node' h-array))))))) + + ## For #Base nodes, check whether the BitPosition is set. + (#Base bitmap base) + (let [bit (bit-position level hash)] + (if (bit-position-is-set? bit bitmap) + (let [idx (base-index bit bitmap)] + (case (array;get idx base) + #;None + (undefined) + + ## If set, check if it's a sub-node, and remove the KV + ## from it. + (#;Some (#;Left sub-node)) + (let [sub-node' (remove' (level-up level) hash key Hash sub-node)] + ## Verify that it was removed. + (if (is sub-node sub-node') + ## If not, there's also nothing to change here. + node + ## But if it came out empty... + (if (empty?' sub-node') + ### ... figure out whether that's the only position left. + (if (only-bit-position? bit bitmap) + ## If so, removing it leaves this node empty too. + empty + ## But if not, then just unset the position and + ## remove the node. + (#Base (unset-bit-position bit bitmap) + (remove! idx base))) + ## But, if it didn't come out empty, then the + ## position is kept, and the node gets updated. + (#Base bitmap + (update! idx (#;Left sub-node') base))))) + + ## If, however, there was a KV pair instead of a sub-node. + (#;Some (#;Right [key' val'])) + ## Check if the keys match. + (if (:: Hash = key key') + ## If so, remove the KV pair and unset the BitPosition. + (#Base (unset-bit-position bit bitmap) + (remove! idx base)) + ## Otherwise, there's nothing to remove. + node))) + ## If the BitPosition is not set, there's nothing to remove. + node)) + + ## For #Collisions nodes, It need to find out if the key already existst. + (#Collisions _hash _colls) + (case (collision-index Hash key _colls) + ## If not, then there's nothing to remove. + #;None + node + + ## But if so, then check the size of the collisions list. + (#;Some idx) + (if (n.= +1 (array;size _colls)) + ## If there's only one left, then removing it leaves us with + ## an empty node. + empty + ## Otherwise, just shrink the array by removing the KV pair. + (#Collisions _hash (remove! idx _colls)))) + )) + +(def: (get' level hash key Hash node) + (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Maybe V))) + (case node + ## For #Hierarchy nodes, just look-up the key on its children. + (#Hierarchy _size hierarchy) + (case (array;get (level-index level hash) hierarchy) + #;None #;None + (#;Some sub-node) (get' (level-up level) hash key Hash sub-node)) + + ## For #Base nodes, check the leaves, and recursively check the branches. + (#Base bitmap base) + (let [bit (bit-position level hash)] + (if (bit-position-is-set? bit bitmap) + (case (array;get (base-index bit bitmap) base) + #;None + (undefined) + + (#;Some (#;Left sub-node)) + (get' (level-up level) hash key Hash sub-node) + + (#;Some (#;Right [key' val'])) + (if (:: Hash = key key') + (#;Some val') + #;None)) + #;None)) + + ## For #Collisions nodes, do a linear scan of all the known KV-pairs. + (#Collisions _hash _colls) + (:: Monad map product;right + (array;find (|>. product;left (:: Hash = key)) + _colls)) + )) + +(def: (size' node) + (All [K V] (-> (Node K V) Nat)) + (case node + (#Hierarchy _size hierarchy) + (Array/fold n.+ +0 (Array/map size' hierarchy)) + + (#Base _ base) + (Array/fold n.+ +0 (Array/map (lambda [sub-node'] + (case sub-node' + (#;Left sub-node) (size' sub-node) + (#;Right _) +1)) + base)) + + (#Collisions hash colls) + (array;size colls) + )) + +(def: (entries' node) + (All [K V] (-> (Node K V) (List [K V]))) + (case node + (#Hierarchy _size hierarchy) + (Array/fold (lambda [sub-node tail] (List/append (entries' sub-node) tail)) + #;Nil + hierarchy) + + (#Base bitmap base) + (Array/fold (lambda [branch tail] + (case branch + (#;Left sub-node) + (List/append (entries' sub-node) tail) + + (#;Right [key' val']) + (#;Cons [key' val'] tail))) + #;Nil + base) + + (#Collisions hash colls) + (Array/fold (lambda [[key' val'] tail] (#;Cons [key' val'] tail)) + #;Nil + colls))) + +## [Exports] +(type: #export (Dict k v) + {#;doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."} + {#hash (Hash k) + #root (Node k v)}) + +(def: #export (new Hash) + (All [K V] (-> (Hash K) (Dict K V))) + {#hash Hash + #root empty}) + +(def: #export (put key val dict) + (All [K V] (-> K V (Dict K V) (Dict K V))) + (let [[Hash node] dict] + [Hash (put' root-level (:: Hash hash key) key val Hash node)])) + +(def: #export (remove key dict) + (All [K V] (-> K (Dict K V) (Dict K V))) + (let [[Hash node] dict] + [Hash (remove' root-level (:: Hash hash key) key Hash node)])) + +(def: #export (get key dict) + (All [K V] (-> K (Dict K V) (Maybe V))) + (let [[Hash node] dict] + (get' root-level (:: Hash hash key) key Hash node))) + +(def: #export (contains? key table) + (All [K V] (-> K (Dict K V) Bool)) + (case (get key table) + #;None false + (#;Some _) true)) + +(def: #export (put~ key val table) + {#;doc "Only puts the KV-pair if the key is not already present."} + (All [K V] (-> K V (Dict K V) (Dict K V))) + (if (contains? key table) + table + (put key val table))) + +(def: #export (update key f table) + {#;doc "Transforms the value located at key (if available), using the given function."} + (All [K V] (-> K (-> V V) (Dict K V) (Dict K V))) + (case (get key table) + #;None + table + + (#;Some val) + (put key (f val) table))) + +(def: #export size + (All [K V] (-> (Dict K V) Nat)) + (|>. product;right size')) + +(def: #export empty? + (All [K V] (-> (Dict K V) Bool)) + (|>. size (n.= +0))) + +(def: #export (entries dict) + (All [K V] (-> (Dict K V) (List [K V]))) + (entries' (product;right dict))) + +(def: #export (from-list Hash kvs) + (All [K V] (-> (Hash K) (List [K V]) (Dict K V))) + (List/fold (lambda [[k v] dict] + (put k v dict)) + (new Hash) + kvs)) + +(do-template [ ] + [(def: #export ( dict) + (All [K V] (-> (Dict K V) (List ))) + (|> dict entries (List/map )))] + + [keys K product;left] + [values V product;right] + ) + +(def: #export (merge dict2 dict1) + {#;doc "Merges 2 dictionaries. + + If any collisions with keys occur, the values of dict2 will overwrite those of dict1."} + (All [K V] (-> (Dict K V) (Dict K V) (Dict K V))) + (List/fold (lambda [[key val] dict] (put key val dict)) + dict1 + (entries dict2))) + +(def: #export (merge-with f dict2 dict1) + {#;doc "Merges 2 dictionaries. + + If any collisions with keys occur, a new value will be computed by applying 'f' to the values of dict2 and dict1."} + (All [K V] (-> (-> V V V) (Dict K V) (Dict K V) (Dict K V))) + (List/fold (lambda [[key val2] dict] + (case (get key dict) + #;None + (put key val2 dict) + + (#;Some val1) + (put key (f val2 val1) dict))) + dict1 + (entries dict2))) + +(def: #export (re-bind from-key to-key dict) + (All [K V] (-> K K (Dict K V) (Dict K V))) + (case (get from-key dict) + #;None + dict + + (#;Some val) + (|> dict + (remove from-key) + (put to-key val)))) + +(def: #export (select keys dict) + {#;doc "Creates a sub-set of the given dict, with only the specified keys."} + (All [K V] (-> (List K) (Dict K V) (Dict K V))) + (let [[Hash _] dict] + (List/fold (lambda [key new-dict] + (case (get key dict) + #;None new-dict + (#;Some val) (put key val new-dict))) + (new Hash) + keys))) + +## [Structures] +(struct: #export (Eq Eq) (All [k v] (-> (Eq v) (Eq (Dict k v)))) + (def: (= test subject) + (and (n.= (size test) + (size subject)) + (list;every? (lambda [k] + (case [(get k test) (get k subject)] + [(#;Some tk) (#;Some sk)] + (:: Eq = tk sk) + + _ + false)) + (keys test))))) diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux new file mode 100644 index 000000000..9b0328b16 --- /dev/null +++ b/stdlib/source/lux/data/coll/list.lux @@ -0,0 +1,504 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monoid + functor + applicative + ["M" monad #*] + eq + [fold]) + (data [number "Int/" Number Codec] + bool + [product]) + codata/function)) + +## [Types] +## (type: (List a) +## #Nil +## (#Cons a (List a))) + +## [Functions] +(struct: #export _ (fold;Fold List) + (def: (fold f init xs) + (case xs + #;Nil + init + + (#;Cons [x xs']) + (fold f (f x init) xs')))) + +(open Fold) + +(def: #export (reverse xs) + (All [a] + (-> (List a) (List a))) + (fold (lambda [head tail] (#;Cons head tail)) + #;Nil + xs)) + +(def: #export (filter p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + (#;Cons [x (filter p xs')]) + (filter p xs')))) + +(def: #export (partition p xs) + {#;doc "Divide the list into all elements that satisfy a predicate, and all elements that don't."} + (All [a] (-> (-> a Bool) (List a) [(List a) (List a)])) + [(filter p xs) (filter (complement p) xs)]) + +(def: #export (as-pairs xs) + {#;doc "Cut the list into pairs of 2. + + Caveat emptor: If the list has an uneven number of elements, the last one will be skipped."} + (All [a] (-> (List a) (List [a a]))) + (case xs + (^ (#;Cons [x1 (#;Cons [x2 xs'])])) + (#;Cons [[x1 x2] (as-pairs xs')]) + + _ + #;Nil)) + +(do-template [ ] + [(def: #export ( n xs) + (All [a] + (-> Nat (List a) (List a))) + (if (n.> +0 n) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + ) + ))] + + [take (#;Cons [x (take (n.dec n) xs')]) #;Nil] + [drop (drop (n.dec n) xs') xs] + ) + +(do-template [ ] + [(def: #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) (List a))) + (case xs + #;Nil + #;Nil + + (#;Cons [x xs']) + (if (p x) + + )))] + + [take-while (#;Cons [x (take-while p xs')]) #;Nil] + [drop-while (drop-while p xs') xs] + ) + +(def: #export (split n xs) + (All [a] + (-> Nat (List a) [(List a) (List a)])) + (if (n.> +0 n) + (case xs + #;Nil + [#;Nil #;Nil] + + (#;Cons [x xs']) + (let [[tail rest] (split (n.dec n) xs')] + [(#;Cons [x tail]) rest])) + [#;Nil xs])) + +(def: (split-with' p ys xs) + (All [a] + (-> (-> a Bool) (List a) (List a) [(List a) (List a)])) + (case xs + #;Nil + [ys xs] + + (#;Cons [x xs']) + (if (p x) + (split-with' p (#;Cons [x ys]) xs') + [ys xs]))) + +(def: #export (split-with p xs) + {#;doc "Segment the list by using a predicate to tell when to cut."} + (All [a] + (-> (-> a Bool) (List a) [(List a) (List a)])) + (let [[ys' xs'] (split-with' p #;Nil xs)] + [(reverse ys') xs'])) + +(def: #export (split-all n xs) + {#;doc "Segment the list in chunks of size n."} + (All [a] (-> Nat (List a) (List (List a)))) + (case xs + #;Nil + (list) + + _ + (let [[pre post] (split n xs)] + (#;Cons pre (split-all n post))))) + +(def: #export (repeat n x) + {#;doc "A list of the value x, repeated n times."} + (All [a] + (-> Nat a (List a))) + (if (n.> +0 n) + (#;Cons [x (repeat (n.dec n) x)]) + #;Nil)) + +(def: (iterate' f x) + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#;Some x') + (list& x (iterate' f x')) + + #;None + (list))) + +(def: #export (iterate f x) + {#;doc "Generates a list element by element until the function returns #;None."} + (All [a] + (-> (-> a (Maybe a)) a (List a))) + (case (f x) + (#;Some x') + (list& x (iterate' f x')) + + #;None + (list x))) + +(def: #export (find p xs) + {#;doc "Returns the first value in the list for which the predicate is true."} + (All [a] + (-> (-> a Bool) (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (if (p x) + (#;Some x) + (find p xs')))) + +(def: #export (interpose sep xs) + {#;doc "Puts a value between every two elements in the list."} + (All [a] + (-> a (List a) (List a))) + (case xs + #;Nil + xs + + (#;Cons [x #;Nil]) + xs + + (#;Cons [x xs']) + (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) + +(def: #export (size list) + (All [a] (-> (List a) Nat)) + (fold (lambda [_ acc] (n.+ +1 acc)) +0 list)) + +(do-template [ ] + [(def: #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (fold (lambda [_2 _1] ( _1 (p _2))) xs))] + + [every? true and] + [any? false or]) + +(def: #export (nth i xs) + {#;doc "Fetches the element at the specified index."} + (All [a] + (-> Nat (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons [x xs']) + (if (n.= +0 i) + (#;Some x) + (nth (n.dec i) xs')))) + +## [Structures] +(struct: #export (Eq Eq) + (All [a] (-> (Eq a) (Eq (List a)))) + (def: (= xs ys) + (case [xs ys] + [#;Nil #;Nil] + true + + [(#;Cons x xs') (#;Cons y ys')] + (and (:: Eq = x y) + (= xs' ys')) + + [_ _] + false + ))) + +(struct: #export Monoid (All [a] + (Monoid (List a))) + (def: unit #;Nil) + (def: (append xs ys) + (case xs + #;Nil ys + (#;Cons x xs') (#;Cons x (append xs' ys))))) + +(open Monoid) + +(struct: #export _ (Functor List) + (def: (map f ma) + (case ma + #;Nil #;Nil + (#;Cons a ma') (#;Cons (f a) (map f ma'))))) + +(open Functor) + +(struct: #export _ (Applicative List) + (def: functor Functor) + + (def: (wrap a) + (#;Cons a #;Nil)) + + (def: (apply ff fa) + (case ff + #;Nil + #;Nil + + (#;Cons f ff') + (append (map f fa) (apply ff' fa))))) + +(struct: #export _ (Monad List) + (def: applicative Applicative) + + (def: join (|>. reverse (fold append unit)))) + +## [Functions] +(def: #export (sort < xs) + (All [a] (-> (-> a a Bool) (List a) (List a))) + (case xs + #;Nil + (list) + + (#;Cons x xs') + (let [[pre post] (fold (lambda [x' [pre post]] + (if (< x x') + [(#;Cons x' pre) post] + [pre (#;Cons x' post)])) + [(list) (list)] + xs')] + ($_ append (sort < pre) (list x) (sort < post))))) + +(do-template [ ] + [(def: #export ( from to) + {#;doc "Generates an inclusive interval of values [from, to]."} + (-> (List )) + (if ( to from) + (list& from ( ( from) to)) + (list)))] + + [i.range Int i.<= i.inc] + [n.range Nat n.<= n.inc] + ) + +(def: #export (empty? xs) + (All [a] (-> (List a) Bool)) + (case xs + #;Nil true + _ false)) + +(def: #export (member? eq xs x) + (All [a] (-> (Eq a) (List a) a Bool)) + (case xs + #;Nil false + (#;Cons x' xs') (or (:: eq = x x') + (member? eq xs' x)))) + +(do-template [ ] + [(def: #export ( xs) + {#;doc } + (All [a] (-> (List a) (Maybe ))) + (case xs + #;Nil + #;None + + (#;Cons x xs') + (#;Some )))] + + [head a x "Returns the first element of a list."] + [tail (List a) xs' "For a list of size N, returns the N-1 elements after the first one."] + ) + +## [Syntax] +(def: (symbol$ name) + (-> Text AST) + [["" -1 -1] (#;SymbolS "" name)]) + +(macro: #export (zip tokens state) + {#;doc (doc "Create list zippers with the specified number of input lists." + (def: #export zip2 (zip 2)) + (def: #export zip3 (zip 3)) + ((zip 3) xs ys zs))} + (case tokens + (^ (list [_ (#;IntS num-lists)])) + (if (i.> 0 num-lists) + (let [(^open) Functor + indices (i.range 0 (i.dec num-lists)) + type-vars (: (List AST) (map (. symbol$ Int/encode) indices)) + zip-type (` (All [(~@ type-vars)] + (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) + type-vars)) + (List [(~@ type-vars)])))) + vars+lists (|> indices + (map i.inc) + (map (lambda [idx] + [(symbol$ (Int/encode idx)) + (symbol$ (Int/encode (Int/negate idx)))]))) + pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (symbol$ "\tstep\t") + g!blank (symbol$ "\t_\t") + list-vars (map product;right vars+lists) + code (` (: (~ zip-type) + (lambda (~ g!step) [(~@ list-vars)] + (case [(~@ list-vars)] + (~ pattern) + (#;Cons [(~@ (map product;left vars+lists))] + ((~ g!step) (~@ list-vars))) + + (~ g!blank) + #;Nil))))] + (#;Right [state (list code)])) + (#;Left "Can't zip 0 lists.")) + + _ + (#;Left "Wrong syntax for zip"))) + +(def: #export zip2 (zip 2)) +(def: #export zip3 (zip 3)) + +(macro: #export (zip-with tokens state) + {#;doc (doc "Create list zippers with the specified number of input lists." + (def: #export zip2-with (zip-with 2)) + (def: #export zip3-with (zip-with 3)) + ((zip-with 2) i.+ xs ys))} + (case tokens + (^ (list [_ (#;IntS num-lists)])) + (if (i.> 0 num-lists) + (let [(^open) Functor + indices (i.range 0 (i.dec num-lists)) + g!return-type (symbol$ "\treturn-type\t") + g!func (symbol$ "\tfunc\t") + type-vars (: (List AST) (map (. symbol$ Int/encode) indices)) + zip-type (` (All [(~@ type-vars) (~ g!return-type)] + (-> (-> (~@ type-vars) (~ g!return-type)) + (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) + type-vars)) + (List (~ g!return-type))))) + vars+lists (|> indices + (map i.inc) + (map (lambda [idx] + [(symbol$ (Int/encode idx)) + (symbol$ (Int/encode (Int/negate idx)))]))) + pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) + vars+lists))]) + g!step (symbol$ "\tstep\t") + g!blank (symbol$ "\t_\t") + list-vars (map product;right vars+lists) + code (` (: (~ zip-type) + (lambda (~ g!step) [(~ g!func) (~@ list-vars)] + (case [(~@ list-vars)] + (~ pattern) + (#;Cons ((~ g!func) (~@ (map product;left vars+lists))) + ((~ g!step) (~ g!func) (~@ list-vars))) + + (~ g!blank) + #;Nil))))] + (#;Right [state (list code)])) + (#;Left "Can't zip-with 0 lists.")) + + _ + (#;Left "Wrong syntax for zip-with"))) + +(def: #export zip2-with (zip-with 2)) +(def: #export zip3-with (zip-with 3)) + +(def: #export (last xs) + (All [a] (-> (List a) (Maybe a))) + (case xs + #;Nil + #;None + + (#;Cons x #;Nil) + (#;Some x) + + (#;Cons x xs') + (last xs'))) + +(def: #export (inits xs) + {#;doc "For a list of size N, returns the first N-1 elements. + + Empty lists will result in a #;None value being returned instead."} + (All [a] (-> (List a) (Maybe (List a)))) + (case xs + #;Nil + #;None + + (#;Cons x #;Nil) + (#;Some #;Nil) + + (#;Cons x xs') + (case (inits xs') + #;None + (undefined) + + (#;Some tail) + (#;Some (#;Cons x tail))) + )) + +(def: #export (concat xss) + (All [a] (-> (List (List a)) (List a))) + (:: Monad join xss)) + +(struct: #export (ListT Monad) + (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) + (def: applicative (compA (get@ #M;applicative Monad) Applicative)) + (def: (join MlMla) + (do Monad + [lMla MlMla + lla (: (($ +0) (List (List ($ +1)))) + (seqM @ lMla))] + (wrap (concat lla))))) + +(def: #export (lift-list Monad) + (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) + (liftM Monad (:: Monad wrap))) + +(def: (enumerate' idx xs) + (All [a] (-> Nat (List a) (List [Nat a]))) + (case xs + #;Nil + #;Nil + + (#;Cons x xs') + (#;Cons [idx x] (enumerate' (n.inc idx) xs')))) + +(def: #export (enumerate xs) + {#;doc "Pairs every element in the list with it's index, starting at 0."} + (All [a] (-> (List a) (List [Nat a]))) + (enumerate' +0 xs)) + +(def: #export (indices size) + {#;doc "Produces all the valid indices for a given size."} + (All [a] (-> Nat (List Nat))) + (if (n.= +0 size) + (list) + (|> size n.dec (n.range +0)))) diff --git a/stdlib/source/lux/data/coll/queue.lux b/stdlib/source/lux/data/coll/queue.lux new file mode 100644 index 000000000..4dcac337c --- /dev/null +++ b/stdlib/source/lux/data/coll/queue.lux @@ -0,0 +1,80 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control eq) + (data (coll [list "List/" Monoid])))) + +## [Types] +(type: #export (Queue a) + {#front (List a) + #rear (List a)}) + +## [Values] +(def: #export empty + Queue + {#front (list) + #rear (list)}) + +(def: #export (from-list entries) + (All [a] (-> (List a) (Queue a))) + {#front entries + #rear (list)}) + +(def: #export (to-list queue) + (All [a] (-> (Queue a) (List a))) + (let [(^slots [#front #rear]) queue] + (List/append front (list;reverse rear)))) + +(def: #export peek + (All [a] (-> (Queue a) (Maybe a))) + (|>. (get@ #front) list;head)) + +(def: #export (size queue) + (All [a] (-> (Queue a) Nat)) + (let [(^slots [#front #rear]) queue] + (n.+ (list;size front) + (list;size rear)))) + +(def: #export empty? + (All [a] (-> (Queue a) Bool)) + (|>. (get@ [#front]) list;empty?)) + +(def: #export (member? a/Eq queue member) + (All [a] (-> (Eq a) (Queue a) a Bool)) + (let [(^slots [#front #rear]) queue] + (or (list;member? a/Eq front member) + (list;member? a/Eq rear member)))) + +(def: #export (pop queue) + (All [a] (-> (Queue a) (Queue a))) + (case (get@ #front queue) + (^ (list)) ## Empty... + queue + + (^ (list _)) ## Front has dried up... + (|> queue + (set@ #front (list;reverse (get@ #rear queue))) + (set@ #rear (list))) + + (^ (list& _ front')) ## Consume front! + (|> queue + (set@ #front front')))) + +(def: #export (push val queue) + (All [a] (-> a (Queue a) (Queue a))) + (case (get@ #front queue) + #;Nil + (set@ #front (list val) queue) + + _ + (update@ #rear (|>. (#;Cons val)) queue))) + +## [Structures] +(struct: #export (Eq Eq) + (All [a] (-> (Eq a) (Eq (Queue a)))) + (def: (= qx qy) + (:: (list;Eq Eq) = (to-list qx) (to-list qy)))) diff --git a/stdlib/source/lux/data/coll/set.lux b/stdlib/source/lux/data/coll/set.lux new file mode 100644 index 000000000..952e8f055 --- /dev/null +++ b/stdlib/source/lux/data/coll/set.lux @@ -0,0 +1,85 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad + eq + [hash #*]) + (data (coll [dict] + [list "List/" Fold Functor])) + (codata function))) + +## [Types] +(type: #export (Set a) + (dict;Dict a a)) + +## [Values] +(def: #export (new Hash) + (All [a] (-> (Hash a) (Set a))) + (dict;new Hash)) + +(def: #export (add elem set) + (All [a] (-> a (Set a) (Set a))) + (dict;put elem elem set)) + +(def: #export (remove elem set) + (All [a] (-> a (Set a) (Set a))) + (dict;remove elem set)) + +(def: #export (member? set elem) + (All [a] (-> (Set a) a Bool)) + (dict;contains? elem set)) + +(def: #export to-list + (All [a] (-> (Set a) (List a))) + dict;keys) + +(def: #export (from-list Hash xs) + (All [a] (-> (Hash a) (List a) (Set a))) + (List/fold add (new Hash) xs)) + +(def: #export (union xs yx) + (All [a] (-> (Set a) (Set a) (Set a))) + (dict;merge xs yx)) + +(def: #export (difference sub base) + (All [a] (-> (Set a) (Set a) (Set a))) + (List/fold remove base (to-list sub))) + +(def: #export (intersection filter base) + (All [a] (-> (Set a) (Set a) (Set a))) + (dict;select (dict;keys filter) base)) + +(def: #export (size set) + (All [a] (-> (Set a) Nat)) + (dict;size set)) + +(def: #export (empty? set) + (All [a] (-> (Set a) Bool)) + (n.= +0 (dict;size set))) + +(def: #export (sub? super sub) + (All [a] (-> (Set a) (Set a) Bool)) + (list;every? (member? super) (to-list sub))) + +(def: #export (super? sub super) + (All [a] (-> (Set a) (Set a) Bool)) + (sub? super sub)) + +## [Structures] +(struct: #export Eq (All [a] (Eq (Set a))) + (def: (= (^@ test [Hash _]) subject) + (:: (list;Eq (get@ #hash;eq Hash)) = (to-list test) (to-list subject)))) + +(struct: #export Hash (All [a] (Hash (Set a))) + (def: eq Eq) + + (def: (hash (^@ set [Hash _])) + (List/fold (lambda [elem acc] (n.+ (:: Hash hash elem) acc)) + +0 + (to-list set)))) diff --git a/stdlib/source/lux/data/coll/stack.lux b/stdlib/source/lux/data/coll/stack.lux new file mode 100644 index 000000000..05364b832 --- /dev/null +++ b/stdlib/source/lux/data/coll/stack.lux @@ -0,0 +1,47 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (data (coll [list])))) + +## [Types] +(type: #export (Stack a) + (List a)) + +## [Values] +(def: #export empty + Stack + (list)) + +(def: #export (size stack) + (All [a] (-> (Stack a) Nat)) + (list;size stack)) + +(def: #export (empty? stack) + (All [a] (-> (Stack a) Bool)) + (list;empty? stack)) + +(def: #export (peek stack) + (All [a] (-> (Stack a) (Maybe a))) + (case stack + #;Nil + #;None + + (#;Cons value _) + (#;Some value))) + +(def: #export (pop stack) + (All [a] (-> (Stack a) (Stack a))) + (case stack + #;Nil + #;Nil + + (#;Cons _ stack') + stack')) + +(def: #export (push value stack) + (All [a] (-> a (Stack a) (Stack a))) + (#;Cons value stack)) diff --git a/stdlib/source/lux/data/coll/tree/rose.lux b/stdlib/source/lux/data/coll/tree/rose.lux new file mode 100644 index 000000000..4c4f873d5 --- /dev/null +++ b/stdlib/source/lux/data/coll/tree/rose.lux @@ -0,0 +1,60 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control monad + eq) + (data (coll [list "" Monad])) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## [Types] +(type: #export (Tree a) + {#value a + #children (List (Tree a))}) + +## [Values] +(def: #export (flatten tree) + (All [a] (-> (Tree a) (List a))) + (#;Cons (get@ #value tree) + (join (map flatten (get@ #children tree))))) + +(def: #export (leaf value) + (All [a] (-> a (Tree a))) + {#value value + #children (list)}) + +(def: #export (branch value children) + (All [a] (-> a (List (Tree a)) (Tree a))) + {#value value + #children children}) + +## [Syntax] +(type: #rec Tree-AST + [AST (List Tree-AST)]) + +(def: (tree^ _) + (-> Unit (Syntax Tree-AST)) + (s;either (s;record (s;seq s;any (s;tuple (s;some (lambda [state] ((tree^ []) state)))))) + (s;seq s;any (:: s;Monad wrap (list))))) + +(syntax: #export (tree type [root (tree^ [])]) + {#;doc (doc "Tree literals." + (tree Int 10) + (tree Int {10 [20 + {30 []} + 40]}))} + (wrap (list (` (: (Tree (~ type)) + (~ (loop [[value children] root] + (` {#value (~ value) + #children (list (~@ (map recur children)))})))))))) + +## [Structs] +(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Tree a)))) + (def: (= tx ty) + (and (:: Eq = (get@ #value tx) (get@ #value ty)) + (:: (list;Eq (Eq Eq)) = (get@ #children tx) (get@ #children ty))))) diff --git a/stdlib/source/lux/data/coll/tree/zipper.lux b/stdlib/source/lux/data/coll/tree/zipper.lux new file mode 100644 index 000000000..c154ed19c --- /dev/null +++ b/stdlib/source/lux/data/coll/tree/zipper.lux @@ -0,0 +1,197 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (data (coll [list "" Monad Fold "List/" Monoid] + (tree [rose #+ Tree]) + [stack #+ Stack])) + [compiler] + (macro [ast] + ["s" syntax #+ syntax: Syntax]))) + +## Adapted from the clojure.zip namespace in the Clojure standard library. + +## [Types] +(type: #export (Zipper a) + {#;doc "Tree zippers, for easy navigation and editing over trees."} + {#parent (Maybe (Zipper a)) + #lefts (Stack (Tree a)) + #rights (Stack (Tree a)) + #node (Tree a)}) + +## [Values] +(def: #export (from-tree tree) + (All [a] (-> (Tree a) (Zipper a))) + {#parent #;None + #lefts stack;empty + #rights stack;empty + #node tree}) + +(def: #export (to-tree zipper) + (All [a] (-> (Zipper a) (Tree a))) + (get@ #node zipper)) + +(def: #export (value zipper) + (All [a] (-> (Zipper a) a)) + (|> zipper (get@ #node) (get@ #rose;value))) + +(def: #export (children zipper) + (All [a] (-> (Zipper a) (List (Tree a)))) + (|> zipper (get@ #node) (get@ #rose;children))) + +(def: #export (branch? zipper) + (All [a] (-> (Zipper a) Bool)) + (|> zipper children list;empty? not)) + +(def: #export (leaf? zipper) + (All [a] (-> (Zipper a) Bool)) + (|> zipper branch? not)) + +(def: #export (parent zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (get@ #parent zipper)) + +(def: #export (down zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (children zipper) + #;Nil + zipper + + (#;Cons chead ctail) + {#parent (#;Some zipper) + #lefts stack;empty + #rights ctail + #node chead})) + +(def: #export (up zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ #parent zipper) + #;None + zipper + + (#;Some parent) + (|> parent + (update@ #node (: (-> (Tree ($ +0)) (Tree ($ +0))) + (lambda [node] + (set@ #rose;children (List/append (list;reverse (get@ #lefts zipper)) + (#;Cons (get@ #node zipper) + (get@ #rights zipper))) + node))))))) + +(def: #export (root zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (loop [zipper zipper] + (case (get@ #parent zipper) + #;None zipper + (#;Some _) (recur (up zipper))))) + +(do-template [ ] + [(def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ zipper) + #;Nil + zipper + + (#;Cons next side') + (|> zipper + (update@ (lambda [op-side] + (#;Cons (get@ #node zipper) op-side))) + (set@ side') + (set@ #node next)))) + + (def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (fold (lambda [_] ) zipper (get@ zipper)))] + + [right rightmost #rights #lefts] + [left leftmost #lefts #rights] + ) + +(def: #export (set value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (set@ [#node #rose;value] value zipper)) + +(def: #export (update f zipper) + (All [a] (-> (-> a a) (Zipper a) (Zipper a))) + (update@ [#node #rose;value] f zipper)) + +(def: #export (prepend-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #rose;children] + (lambda [children] + (#;Cons (rose;tree ($ +0) {value []}) + children)) + zipper)) + +(def: #export (append-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #rose;children] + (lambda [children] + (List/append children + (list (rose;tree ($ +0) {value []})))) + zipper)) + +(def: #export (remove zipper) + (All [a] (-> (Zipper a) (Maybe (Zipper a)))) + (case (get@ #lefts zipper) + #;Nil + (case (get@ #parent zipper) + #;None + #;None + + (#;Some next) + (#;Some (|> next + (update@ [#node #rose;children] (|>. list;tail (default (list))))))) + + (#;Cons next side) + (#;Some (|> zipper + (set@ #lefts side) + (set@ #node next))))) + +(do-template [ ] + [(def: #export ( value zipper) + (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) + (case (get@ #parent zipper) + #;None + #;None + + _ + (#;Some (|> zipper + (update@ (lambda [side] + (#;Cons (rose;tree ($ +0) {value []}) + side)))))))] + + [insert-left #lefts] + [insert-right #rights] + ) + +(do-template [ ] + [(def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (case (get@ zipper) + #;Nil + ( zipper) + + _ + ( zipper)))] + + [next #rights right down] + [prev #lefts left up] + ) + +(def: #export (end? zipper) + (All [a] (-> (Zipper a) Bool)) + (and (list;empty? (get@ #rights zipper)) + (list;empty? (children zipper)))) + +(def: #export (root? zipper) + (All [a] (-> (Zipper a) Bool)) + (case (get@ #parent zipper) + #;None + true + + _ + false)) diff --git a/stdlib/source/lux/data/coll/vector.lux b/stdlib/source/lux/data/coll/vector.lux new file mode 100644 index 000000000..1dbceb97e --- /dev/null +++ b/stdlib/source/lux/data/coll/vector.lux @@ -0,0 +1,451 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control functor + applicative + monad + eq + monoid + fold) + (data maybe + (coll [list "List/" Fold Functor Monoid] + [array #+ Array "Array/" Functor Fold]) + [bit] + [number "Int/" Number] + [product]) + [compiler #+ with-gensyms] + (macro [ast] + ["s" syntax #+ syntax: Syntax]) + [pipe] + )) + +## This implementation of vectors is based on Clojure's +## PersistentVector implementation. + +## [Utils] +(type: (Node a) + (#Base (Array a)) + (#Hierarchy (Array (Node a)))) + +(type: (Base a) (Array a)) +(type: (Hierarchy a) (Array (Node a))) + +(type: Level Nat) + +(type: Index Nat) + +(def: branching-exponent + Nat + +5) + +(def: root-level + Level + +0) + +(do-template [ ] + [(def: + (-> Level Level) + ( branching-exponent))] + + [level-up n.+] + [level-down n.-] + ) + +(def: full-node-size + Nat + (bit;<< branching-exponent +1)) + +(def: branch-idx-mask + Nat + (n.dec full-node-size)) + +(def: branch-idx + (-> Index Index) + (bit;& branch-idx-mask)) + +(def: (new-hierarchy _) + (All [a] (-> Top (Hierarchy a))) + (array;new full-node-size)) + +(def: (tail-off vec-size) + (-> Nat Nat) + (if (n.< full-node-size vec-size) + +0 + (|> (n.dec vec-size) + (bit;>>> branching-exponent) + (bit;<< branching-exponent)))) + +(def: (new-path level tail) + (All [a] (-> Level (Base a) (Node a))) + (if (n.= +0 level) + (#Base tail) + (|> (: (Hierarchy ($ +0)) + (new-hierarchy [])) + (array;put +0 (new-path (level-down level) tail)) + #Hierarchy))) + +(def: (new-tail singleton) + (All [a] (-> a (Base a))) + (|> (: (Base ($ +0)) + (array;new +1)) + (array;put +0 singleton))) + +(def: (push-tail size level tail parent) + (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a))) + (let [sub-idx (branch-idx (bit;>>> level (n.dec size))) + ## If we're currently on a bottom node + sub-node (if (n.= branching-exponent level) + ## Just add the tail to it + (#Base tail) + ## Otherwise, check whether there's a vacant spot + (case (array;get sub-idx parent) + ## If so, set the path to the tail + #;None + (new-path (level-down level) tail) + ## If not, push the tail onto the sub-node. + (#;Some (#Hierarchy sub-node)) + (#Hierarchy (push-tail size (level-down level) tail sub-node)) + + _ + (undefined)) + )] + (|> (array;clone parent) + (array;put sub-idx sub-node)))) + +(def: (expand-tail val tail) + (All [a] (-> a (Base a) (Base a))) + (let [tail-size (array;size tail)] + (|> (: (Base ($ +0)) + (array;new (n.inc tail-size))) + (array;copy tail-size +0 tail +0) + (array;put tail-size val) + ))) + +(def: (put' level idx val hierarchy) + (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a))) + (let [sub-idx (branch-idx (bit;>>> level idx))] + (case (array;get sub-idx hierarchy) + (#;Some (#Hierarchy sub-node)) + (|> (array;clone hierarchy) + (array;put sub-idx (#Hierarchy (put' (level-down level) idx val sub-node)))) + + (^=> (#;Some (#Base base)) + (n.= +0 (level-down level))) + (|> (array;clone hierarchy) + (array;put sub-idx (|> (array;clone base) + (array;put (branch-idx idx) val) + #Base))) + + _ + (undefined)))) + +(def: (pop-tail size level hierarchy) + (All [a] (-> Nat Level (Hierarchy a) (Maybe (Hierarchy a)))) + (let [sub-idx (branch-idx (bit;>>> level (n.- +2 size)))] + (cond (n.= +0 sub-idx) + #;None + + (n.> branching-exponent level) + (do Monad + [base|hierarchy (array;get sub-idx hierarchy) + sub (case base|hierarchy + (#Hierarchy sub) + (pop-tail size (level-down level) sub) + + (#Base _) + (undefined))] + (|> (array;clone hierarchy) + (array;put sub-idx (#Hierarchy sub)) + #;Some)) + + ## Else... + (|> (array;clone hierarchy) + (array;remove sub-idx) + #;Some) + ))) + +(def: (to-list' node) + (All [a] (-> (Node a) (List a))) + (case node + (#Base base) + (array;to-list base) + + (#Hierarchy hierarchy) + (|> hierarchy + array;to-list + list;reverse + (List/fold (lambda [sub acc] (List/append (to-list' sub) acc)) + #;Nil)))) + +## [Types] +(type: #export (Vector a) + {#level Level + #size Nat + #root (Hierarchy a) + #tail (Base a)}) + +## [Exports] +(def: #export empty + Vector + {#level (level-up root-level) + #size +0 + #root (array;new full-node-size) + #tail (array;new +0)}) + +(def: #export (size vector) + (All [a] (-> (Vector a) Nat)) + (get@ #size vector)) + +(def: #export (add val vec) + (All [a] (-> a (Vector a) (Vector a))) + ## Check if there is room in the tail. + (let [vec-size (get@ #size vec)] + (if (|> vec-size (n.- (tail-off vec-size)) (n.< full-node-size)) + ## If so, append to it. + (|> vec + (update@ #size n.inc) + (update@ #tail (expand-tail val))) + ## Otherwise, push tail into the tree + ## -------------------------------------------------------- + ## Will the root experience an overflow with this addition? + (|> (if (n.> (bit;<< (get@ #level vec) +1) + (bit;>>> branching-exponent vec-size)) + ## If so, a brand-new root must be established, that is + ## 1-level taller. + (|> vec + (set@ #root (|> (: (Hierarchy ($ +0)) + (new-hierarchy [])) + (array;put +0 (#Hierarchy (get@ #root vec))) + (array;put +1 (new-path (get@ #level vec) (get@ #tail vec))))) + (update@ #level level-up)) + ## Otherwise, just push the current tail onto the root. + (|> vec + (update@ #root (push-tail vec-size (get@ #level vec) (get@ #tail vec))))) + ## Finally, update the size of the Vector and grow a new + ## tail with the new element as it's sole member. + (update@ #size n.inc) + (set@ #tail (new-tail val))) + ))) + +(def: (base-for idx vec) + (All [a] (-> Index (Vector a) (Maybe (Base a)))) + (let [vec-size (get@ #size vec)] + (if (and (n.>= +0 idx) + (n.< vec-size idx)) + (if (n.>= (tail-off vec-size) idx) + (#;Some (get@ #tail vec)) + (loop [level (get@ #level vec) + hierarchy (get@ #root vec)] + (case [(n.> branching-exponent level) + (array;get (branch-idx (bit;>>> level idx)) hierarchy)] + [true (#;Some (#Hierarchy sub))] + (recur (level-down level) sub) + + [false (#;Some (#Base base))] + (#;Some base) + + [_ #;None] + #;None + + _ + (error! "Incorrect vector structure.")))) + #;None))) + +(def: #export (nth idx vec) + (All [a] (-> Nat (Vector a) (Maybe a))) + (do Monad + [base (base-for idx vec)] + (array;get (branch-idx idx) base))) + +(def: #export (put idx val vec) + (All [a] (-> Nat a (Vector a) (Vector a))) + (let [vec-size (get@ #size vec)] + (if (and (n.>= +0 idx) + (n.< vec-size idx)) + (if (n.>= (tail-off vec-size) idx) + (|> vec + (update@ #tail (: (-> (Base ($ +0)) (Base ($ +0))) + (|>. array;clone (array;put (branch-idx idx) val))))) + (|> vec + (update@ #root (put' (get@ #level vec) idx val)))) + vec))) + +(def: #export (update idx f vec) + (All [a] (-> Nat (-> a a) (Vector a) (Vector a))) + (case (nth idx vec) + (#;Some val) + (put idx (f val) vec) + + #;None + vec)) + +(def: #export (pop vec) + (All [a] (-> (Vector a) (Vector a))) + (case (get@ #size vec) + +0 + empty + + +1 + empty + + vec-size + (if (|> vec-size (n.- (tail-off vec-size)) (n.> +1)) + (let [old-tail (get@ #tail vec) + new-tail-size (n.dec (array;size old-tail))] + (|> vec + (update@ #size n.dec) + (set@ #tail (|> (array;new new-tail-size) + (array;copy new-tail-size +0 old-tail +0))))) + (default (undefined) + (do Monad + [new-tail (base-for (n.- +2 vec-size) vec) + #let [[level' root'] (: [Level (Hierarchy ($ +0))] + (let [init-level (get@ #level vec)] + (loop [level init-level + root (: (Hierarchy ($ +0)) + (default (new-hierarchy []) + (pop-tail vec-size init-level (get@ #root vec))))] + (if (n.> branching-exponent level) + (case [(array;get +1 root) (array;get +0 root)] + [#;None (#;Some (#Hierarchy sub-node))] + (recur (level-down level) sub-node) + + [#;None (#;Some (#Base _))] + (undefined) + + _ + [level root]) + [level root]))))]] + (wrap (|> vec + (update@ #size n.dec) + (set@ #level level') + (set@ #root root') + (set@ #tail new-tail)))))) + )) + +(def: #export (to-list vec) + (All [a] (-> (Vector a) (List a))) + (List/append (to-list' (#Hierarchy (get@ #root vec))) + (to-list' (#Base (get@ #tail vec))))) + +(def: #export (from-list list) + (All [a] (-> (List a) (Vector a))) + (List/fold add + (: (Vector ($ +0)) + empty) + list)) + +(def: #export (member? a/Eq vec val) + (All [a] (-> (Eq a) (Vector a) a Bool)) + (list;member? a/Eq (to-list vec) val)) + +(def: #export empty? + (All [a] (-> (Vector a) Bool)) + (|>. (get@ #size) (n.= +0))) + +## [Syntax] +(syntax: #export (vector [elems (s;some s;any)]) + {#;doc (doc "Vector literals." + (vector 10 20 30 40))} + (wrap (list (` (from-list (list (~@ elems))))))) + +## [Structures] +(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Node a)))) + (def: (= v1 v2) + (case [v1 v2] + [(#Base b1) (#Base b2)] + (:: (array;Eq Eq) = b1 b2) + + [(#Hierarchy h1) (#Hierarchy h2)] + (:: (array;Eq (Eq Eq)) = h1 h2) + ))) + +(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Vector a)))) + (def: (= v1 v2) + (and (n.= (get@ #size v1) (get@ #size v2)) + (let [(^open "Node/") (Eq Eq)] + (and (Node/= (#Base (get@ #tail v1)) + (#Base (get@ #tail v2))) + (Node/= (#Hierarchy (get@ #root v1)) + (#Hierarchy (get@ #root v2)))))))) + +(struct: _ (Fold Node) + (def: (fold f init xs) + (case xs + (#Base base) + (Array/fold f init base) + + (#Hierarchy hierarchy) + (Array/fold (lambda [node init'] (fold f init' node)) + init + hierarchy)) + )) + +(struct: #export _ (Fold Vector) + (def: (fold f init xs) + (let [(^open) Fold] + (fold f + (fold f + init + (#Hierarchy (get@ #root xs))) + (#Base (get@ #tail xs)))) + )) + +(struct: #export Monoid (All [a] + (Monoid (Vector a))) + (def: unit empty) + (def: (append xs ys) + (List/fold add xs (to-list ys)))) + +(struct: _ (Functor Node) + (def: (map f xs) + (case xs + (#Base base) + (#Base (Array/map f base)) + + (#Hierarchy hierarchy) + (#Hierarchy (Array/map (map f) hierarchy))) + )) + +(struct: #export _ (Functor Vector) + (def: (map f xs) + {#level (get@ #level xs) + #size (get@ #size xs) + #root (|> xs (get@ #root) (Array/map (:: Functor map f))) + #tail (|> xs (get@ #tail) (Array/map f)) + })) + +(struct: #export _ (Applicative Vector) + (def: functor Functor) + + (def: (wrap x) + (vector x)) + + (def: (apply ff fa) + (let [(^open) Functor + (^open) Fold + (^open) Monoid + results (map (lambda [f] (map f fa)) + ff)] + (fold append unit results))) + ) + +(struct: #export _ (Monad Vector) + (def: applicative Applicative) + + (def: join + (let [(^open) Fold + (^open) Monoid] + (fold (lambda [post pre] (append pre post)) unit))) + ) + +(def: #export (reverse xs) + (All [a] + (-> (Vector a) (Vector a))) + (let [(^open) Fold + (^open) Monoid] + (fold add unit xs))) diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index 66ad6c093..0c61b958b 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -21,9 +21,9 @@ [error #- fail] [sum] [product] - (struct [list "" Fold "List/" Monad] - [vector #+ Vector vector "Vector/" Monad] - [dict #+ Dict])) + (coll [list "" Fold "List/" Monad] + [vector #+ Vector vector "Vector/" Monad] + [dict #+ Dict])) (codata [function]) [compiler #+ Monad with-gensyms] (macro [syntax #+ syntax:] @@ -544,13 +544,13 @@ _ (#;Left (format "JSON value is not an object: " (show-json json)))))) -(def: #export (at idx parser) +(def: #export (nth idx parser) {#;doc "Parses an element inside a JSON array."} (All [a] (-> Nat (Parser a) (Parser a))) (lambda [json] (case json (#Array values) - (case (vector;at idx values) + (case (vector;nth idx values) (#;Some value) (case (parser value) (#;Right output) @@ -689,8 +689,8 @@ (and prev (default false (do Monad - [x' (vector;at idx xs) - y' (vector;at idx ys)] + [x' (vector;nth idx xs) + y' (vector;nth idx ys)] (wrap (= x' y')))))) true (list;indices (vector;size xs)))) @@ -734,7 +734,7 @@ parsers (|> parts (list;zip2 (list;indices array-size)) (List/map (lambda [[idx parser]] - (` (at (~ (ast;nat idx)) (~ parser))))))] + (` (nth (~ (ast;nat idx)) (~ parser))))))] (wrap (list (` ($_ seq (~@ parsers)))))) (#ObjectShape kvs) @@ -757,7 +757,7 @@ parsers (|> parts (list;zip2 (list;indices array-size)) (List/map (lambda [[idx parser]] - (` (at (~ (ast;nat idx)) (~ parser))))))] + (` (nth (~ (ast;nat idx)) (~ parser))))))] (wrap (list (` (ensure (array-size! (~ (ast;nat array-size))) ($_ seq (~@ parsers))))))) @@ -998,8 +998,8 @@ [#let [tag (ast;tag name)] decoder (Codec//decode new-*env* :case:)] (wrap (list (` (do Monad - [(~ g!_) (;;at +0 (;;text! (~ (ast;text (product;right name))))) - (~ g!_) (;;at +1 (~ decoder))] + [(~ g!_) (;;nth +0 (;;text! (~ (ast;text (product;right name))))) + (~ g!_) (;;nth +1 (~ decoder))] ((~ (' wrap)) ((~ tag) (~ g!_))))))))) members) #let [:x:+ (case g!vars diff --git a/stdlib/source/lux/data/struct/array.lux b/stdlib/source/lux/data/struct/array.lux deleted file mode 100644 index fa52df9f1..000000000 --- a/stdlib/source/lux/data/struct/array.lux +++ /dev/null @@ -1,225 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control monoid - functor - applicative - monad - eq - fold) - (data error - (struct [list "List/" Fold]) - [product]) - )) - -## [Types] -(type: #export (Array a) - {#;doc "Mutable arrays."} - (#;HostT "#Array" (#;Cons a #;Nil))) - -## [Functions] -(def: #export (new size) - (All [a] (-> Nat (Array a))) - (_lux_proc ["array" "new"] [size])) - -(def: #export (size xs) - (All [a] (-> (Array a) Nat)) - (_lux_proc ["array" "size"] [xs])) - -(def: #export (get i xs) - (All [a] - (-> Nat (Array a) (Maybe a))) - (_lux_proc ["array" "get"] [xs i])) - -(def: #export (put i x xs) - (All [a] - (-> Nat a (Array a) (Array a))) - (_lux_proc ["array" "put"] [xs i x])) - -(def: #export (remove i xs) - (All [a] - (-> Nat (Array a) (Array a))) - (_lux_proc ["array" "remove"] [xs i])) - -(def: #export (copy length src-start src-array dest-start dest-array) - (All [a] (-> Nat Nat (Array a) Nat (Array a) - (Array a))) - (if (n.= +0 length) - dest-array - (List/fold (lambda [offset target] - (case (get (n.+ offset src-start) src-array) - #;None - target - - (#;Some value) - (put (n.+ offset dest-start) value target))) - dest-array - (list;n.range +0 (n.dec length))))) - -(def: #export (occupied array) - {#;doc "Finds out how many cells in an array are occupied."} - (All [a] (-> (Array a) Nat)) - (List/fold (lambda [idx count] - (case (get idx array) - #;None - count - - (#;Some _) - (n.inc count))) - +0 - (list;indices (size array)))) - -(def: #export (vacant array) - {#;doc "Finds out how many cells in an array are vacant."} - (All [a] (-> (Array a) Nat)) - (n.- (occupied array) (size array))) - -(def: #export (filter p xs) - (All [a] - (-> (-> a Bool) (Array a) (Array a))) - (List/fold (: (-> Nat (Array ($ +0)) (Array ($ +0))) - (lambda [idx xs'] - (case (get idx xs) - #;None - xs' - - (#;Some x) - (if (p x) - xs' - (remove idx xs'))))) - xs - (list;indices (size xs)))) - -(def: #export (find p xs) - (All [a] - (-> (-> a Bool) (Array a) (Maybe a))) - (let [arr-size (size xs)] - (loop [idx +0] - (if (n.< arr-size idx) - (case (get idx xs) - #;None - (recur (n.inc idx)) - - (#;Some x) - (if (p x) - (#;Some x) - (recur (n.inc idx)))) - #;None)))) - -(def: #export (find+ p xs) - {#;doc "Just like 'find', but with access to the index of each value."} - (All [a] - (-> (-> Nat a Bool) (Array a) (Maybe [Nat a]))) - (let [arr-size (size xs)] - (loop [idx +0] - (if (n.< arr-size idx) - (case (get idx xs) - #;None - (recur (n.inc idx)) - - (#;Some x) - (if (p idx x) - (#;Some [idx x]) - (recur (n.inc idx)))) - #;None)))) - -(def: #export (clone xs) - (All [a] (-> (Array a) (Array a))) - (let [arr-size (size xs)] - (List/fold (lambda [idx ys] - (case (get idx xs) - #;None - ys - - (#;Some x) - (put idx x ys))) - (new arr-size) - (list;indices arr-size)))) - -(def: #export (from-list xs) - (All [a] (-> (List a) (Array a))) - (product;right (List/fold (lambda [x [idx arr]] - [(n.inc idx) (put idx x arr)]) - [+0 (new (list;size xs))] - xs))) - -(def: #export (to-list array) - (All [a] (-> (Array a) (List a))) - (let [_size (size array)] - (product;right (List/fold (lambda [_ [idx tail]] - (case (get idx array) - (#;Some head) - [(n.dec idx) (#;Cons head tail)] - - #;None - [(n.dec idx) tail])) - [(n.dec _size) #;Nil] - (list;repeat _size []) - )))) - -## [Structures] -(struct: #export (Eq Eq) - (All [a] (-> (Eq a) (Eq (Array a)))) - (def: (= xs ys) - (let [sxs (size xs) - sxy (size ys)] - (and (n.= sxy sxs) - (List/fold (lambda [idx prev] - (and prev - (case [(get idx xs) (get idx ys)] - [#;None #;None] - true - - [(#;Some x) (#;Some y)] - (:: Eq = x y) - - _ - false))) - true - (list;n.range +0 (n.dec sxs))))) - )) - -(struct: #export Monoid (All [a] - (Monoid (Array a))) - (def: unit (new +0)) - - (def: (append xs ys) - (let [sxs (size xs) - sxy (size ys)] - (|> (new (n.+ sxy sxs)) - (copy sxs +0 xs +0) - (copy sxy +0 ys sxs))))) - -(struct: #export _ (Functor Array) - (def: (map f ma) - (let [arr-size (size ma)] - (if (n.= +0 arr-size) - (new arr-size) - (List/fold (: (-> Nat (Array ($ +1)) (Array ($ +1))) - (lambda [idx mb] - (case (get idx ma) - #;None - mb - - (#;Some x) - (put idx (f x) mb)))) - (new arr-size) - (list;n.range +0 (n.dec arr-size))))))) - -(struct: #export _ (Fold Array) - (def: (fold f init xs) - (let [arr-size (size xs)] - (loop [so-far init - idx +0] - (if (n.< arr-size idx) - (case (get idx xs) - #;None - (recur so-far (n.inc idx)) - - (#;Some value) - (recur (f value so-far) (n.inc idx))) - so-far))))) diff --git a/stdlib/source/lux/data/struct/dict.lux b/stdlib/source/lux/data/struct/dict.lux deleted file mode 100644 index 3b153d229..000000000 --- a/stdlib/source/lux/data/struct/dict.lux +++ /dev/null @@ -1,687 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control hash - eq) - (data maybe - (struct [list "List/" Fold Functor Monoid] - [array #+ Array "Array/" Functor Fold]) - [bit] - [product] - text/format - [number]) - )) - -## This implementation of Hash Array Mapped Trie (HAMT) is based on -## Clojure's PersistentHashMap implementation. -## That one is further based on Phil Bagwell's Hash Array Mapped Trie. - -## [Utils] -## Bitmaps are used to figure out which branches on a #Base node are -## populated. The number of bits that are 1s in a bitmap signal the -## size of the #Base node. -(type: BitMap Nat) - -## Represents the position of a node in a BitMap. -## It's meant to be a single bit set on a 32-bit word. -## The position of the bit reflects whether an entry in an analogous -## position exists within a #Base, as reflected in it's BitMap. -(type: BitPosition Nat) - -## An index into an array. -(type: Index Nat) - -## A hash-code derived from a key during tree-traversal. -(type: Hash-Code Nat) - -## Represents the nesting level of a leaf or node, when looking-it-up -## while exploring the tree. -## Changes in levels are done by right-shifting the hashes of keys by -## the appropriate multiple of the branching-exponent. -## A shift of 0 means root level. -## A shift of (* branching-exponent 1) means level 2. -## A shift of (* branching-exponent N) means level N+1. -(type: Level Nat) - -## Nodes for the tree data-structure that organizes the data inside -## Dicts. -(type: (Node k v) - (#Hierarchy Nat (Array (Node k v))) - (#Base BitMap - (Array (Either (Node k v) - [k v]))) - (#Collisions Hash-Code (Array [k v]))) - -## #Hierarchy nodes are meant to point down only to lower-level nodes. -(type: (Hierarchy k v) - [Nat (Array (Node k v))]) - -## #Base nodes may point down to other nodes, but also to leaves, -## which are KV pairs. -(type: (Base k v) - (Array (Either (Node k v) - [k v]))) - -## #Collisions are collections of KV-pairs for which the key is -## different on each case, but their hashes are all the same (thus -## causing a collision). -(type: (Collisions k v) - (Array [k v])) - -## That bitmap for an empty #Base is 0. -## Which is the same as 0000 0000 0000 0000 0000 0000 0000 0000. -## Or 0x00000000. -## Which is 32 zeroes, since the branching factor is 32. -(def: clean-bitmap - BitMap - +0) - -## Bitmap position (while looking inside #Base nodes) is determined by -## getting 5 bits from a hash of the key being looked up and using -## them as an index into the array inside #Base. -## Since the data-structure can have multiple levels (and the hash has -## more than 5 bits), the binary-representation of the hash is shifted -## by 5 positions on each step (2^5 = 32, which is the branching -## factor). -## The initial shifting level, though, is 0 (which corresponds to the -## shift in the shallowest node on the tree, which is the root node). -(def: root-level - Level - +0) - -## The exponent to which 2 must be elevated, to reach the branching -## factor of the data-structure. -(def: branching-exponent - Nat - +5) - -## The threshold on which #Hierarchy nodes are demoted to #Base nodes, -## which is 1/4 of the branching factor (or a left-shift 2). -(def: demotion-threshold - Nat - (bit;<< (n.- +2 branching-exponent) +1)) - -## The threshold on which #Base nodes are promoted to #Hierarchy nodes, -## which is 1/2 of the branching factor (or a left-shift 1). -(def: promotion-threshold - Nat - (bit;<< (n.- +1 branching-exponent) +1)) - -## The size of hierarchy-nodes, which is 2^(branching-exponent). -(def: hierarchy-nodes-size - Nat - (bit;<< branching-exponent +1)) - -## The cannonical empty node, which is just an empty #Base node. -(def: empty - Node - (#Base clean-bitmap (array;new +0))) - -## Expands a copy of the array, to have 1 extra slot, which is used -## for storing the value. -(def: (insert! idx value old-array) - (All [a] (-> Index a (Array a) (Array a))) - (let [old-size (array;size old-array)] - (|> (: (Array ($ +0)) - (array;new (n.inc old-size))) - (array;copy idx +0 old-array +0) - (array;put idx value) - (array;copy (n.- idx old-size) idx old-array (n.inc idx))))) - -## Creates a copy of an array with an index set to a particular value. -(def: (update! idx value array) - (All [a] (-> Index a (Array a) (Array a))) - (|> array array;clone (array;put idx value))) - -## Creates a clone of the array, with an empty position at index. -(def: (vacant! idx array) - (All [a] (-> Index (Array a) (Array a))) - (|> array array;clone (array;remove idx))) - -## Shrinks a copy of the array by removing the space at index. -(def: (remove! idx array) - (All [a] (-> Index (Array a) (Array a))) - (let [new-size (n.dec (array;size array))] - (|> (array;new new-size) - (array;copy idx +0 array +0) - (array;copy (n.- idx new-size) (n.inc idx) array idx)))) - -## Given a top-limit for indices, produces all indices in [0, R). -(def: indices-for - (-> Nat (List Index)) - (|>. n.dec (list;n.range +0))) - -## Increases the level-shift by the branching-exponent, to explore -## levels further down the tree. -(def: level-up - (-> Level Level) - (n.+ branching-exponent)) - -(def: hierarchy-mask BitMap (n.dec hierarchy-nodes-size)) - -## Gets the branching-factor sized section of the hash corresponding -## to a particular level, and uses that as an index into the array. -(def: (level-index level hash) - (-> Level Hash-Code Index) - (bit;& hierarchy-mask - (bit;>>> level hash))) - -## A mechanism to go from indices to bit-positions. -(def: (->bit-position index) - (-> Index BitPosition) - (bit;<< index +1)) - -## The bit-position within a base that a given hash-code would have. -(def: (bit-position level hash) - (-> Level Hash-Code BitPosition) - (->bit-position (level-index level hash))) - -(def: (bit-position-is-set? bit bitmap) - (-> BitPosition BitMap Bool) - (not (n.= clean-bitmap (bit;& bit bitmap)))) - -## Figures out whether a bitmap only contains a single bit-position. -(def: only-bit-position? - (-> BitPosition BitMap Bool) - n.=) - -(def: (set-bit-position bit bitmap) - (-> BitPosition BitMap BitMap) - (bit;| bit bitmap)) - -(def: unset-bit-position - (-> BitPosition BitMap BitMap) - bit;^) - -## Figures out the size of a bitmap-indexed array by counting all the -## 1s within the bitmap. -(def: bitmap-size - (-> BitMap Nat) - bit;count) - -## A mask that, for a given bit position, only allows all the 1s prior -## to it, which would indicate the bitmap-size (and, thus, index) -## associated with it. -(def: bit-position-mask - (-> BitPosition BitMap) - n.dec) - -## The index on the base array, based on it's bit-position. -(def: (base-index bit-position bitmap) - (-> BitPosition BitMap Index) - (bitmap-size (bit;& (bit-position-mask bit-position) - bitmap))) - -## Produces the index of a KV-pair within a #Collisions node. -(def: (collision-index Hash key colls) - (All [K V] (-> (Hash K) K (Collisions K V) (Maybe Index))) - (:: Monad map product;left - (array;find+ (lambda [idx [key' val']] - (:: Hash = key key')) - colls))) - -## When #Hierarchy nodes grow too small, they're demoted to #Base -## nodes to save space. -(def: (demote-hierarchy except-idx [h-size h-array]) - (All [k v] (-> Index (Hierarchy k v) [BitMap (Base k v)])) - (product;right (List/fold (lambda [idx [insertion-idx node]] - (let [[bitmap base] node] - (case (array;get idx h-array) - #;None [insertion-idx node] - (#;Some sub-node) (if (n.= except-idx idx) - [insertion-idx node] - [(n.inc insertion-idx) - [(set-bit-position (->bit-position idx) bitmap) - (array;put insertion-idx (#;Left sub-node) base)]]) - ))) - [+0 [clean-bitmap - (: (Base ($ +0) ($ +1)) - (array;new (n.dec h-size)))]] - (list;indices (array;size h-array))))) - -## When #Base nodes grow too large, they're promoted to #Hierarchy to -## add some depth to the tree and help keep it's balance. -(def: (promote-base put' Hash level bitmap base) - (All [K V] - (-> (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V)) - (Hash K) Level - BitMap (Base K V) - (Array (Node K V)))) - (product;right (List/fold (lambda [hierarchy-idx (^@ default [base-idx h-array])] - (if (bit-position-is-set? (->bit-position hierarchy-idx) - bitmap) - [(n.inc base-idx) - (case (array;get base-idx base) - (#;Some (#;Left sub-node)) - (array;put hierarchy-idx sub-node h-array) - - (#;Some (#;Right [key' val'])) - (array;put hierarchy-idx - (put' (level-up level) (:: Hash hash key') key' val' Hash empty) - h-array) - - #;None - (undefined))] - default)) - [+0 - (: (Array (Node ($ +0) ($ +1))) - (array;new hierarchy-nodes-size))] - (indices-for hierarchy-nodes-size)))) - -## All empty nodes look the same (a #Base node with clean bitmap is -## used). -## So, this test is introduced to detect them. -(def: (empty?' node) - (All [K V] (-> (Node K V) Bool)) - (case node - (^~ (#Base ;;clean-bitmap _)) - true - - _ - false)) - -(def: (put' level hash key val Hash node) - (All [K V] (-> Level Hash-Code K V (Hash K) (Node K V) (Node K V))) - (case node - ## For #Hierarchy nodes, I check whether I can add the element to - ## a sub-node. If impossible, I introduced a new singleton sub-node. - (#Hierarchy _size hierarchy) - (let [idx (level-index level hash) - [_size' sub-node] (: [Nat (Node ($ +0) ($ +1))] - (case (array;get idx hierarchy) - (#;Some sub-node) - [_size sub-node] - - _ - [(n.inc _size) empty]))] - (#Hierarchy _size' - (update! idx (put' (level-up level) hash key val Hash sub-node) - hierarchy))) - - ## For #Base nodes, I check if the corresponding BitPosition has - ## already been used. - (#Base bitmap base) - (let [bit (bit-position level hash)] - (if (bit-position-is-set? bit bitmap) - ## If so... - (let [idx (base-index bit bitmap)] - (case (array;get idx base) - #;None - (undefined) - - ## If it's being used by a node, I add the KV to it. - (#;Some (#;Left sub-node)) - (let [sub-node' (put' (level-up level) hash key val Hash sub-node)] - (#Base bitmap (update! idx (#;Left sub-node') base))) - - ## Otherwise, if it's being used by a KV, I compare the keys. - (#;Some (#;Right key' val')) - (if (:: Hash = key key') - ## If the same key is found, I replace the value. - (#Base bitmap (update! idx (#;Right key val) base)) - ## Otherwise, I compare the hashes of the keys. - (#Base bitmap (update! idx - (#;Left (let [hash' (:: Hash hash key')] - (if (n.= hash hash') - ## If the hashes are - ## the same, a new - ## #Collisions node - ## is added. - (#Collisions hash (|> (: (Array [($ +0) ($ +1)]) - (array;new +2)) - (array;put +0 [key' val']) - (array;put +1 [key val]))) - ## Otherwise, I can - ## just keep using - ## #Base nodes, so I - ## add both KV pairs - ## to the empty one. - (let [next-level (level-up level)] - (|> empty - (put' next-level hash' key' val' Hash) - (put' next-level hash key val Hash)))))) - base))))) - ## However, if the BitPosition has not been used yet, I check - ## whether this #Base node is ready for a promotion. - (let [base-count (bitmap-size bitmap)] - (if (n.>= promotion-threshold base-count) - ## If so, I promote it to a #Hierarchy node, and add the new - ## KV-pair as a singleton node to it. - (#Hierarchy (n.inc base-count) - (|> (promote-base put' Hash level bitmap base) - (array;put (level-index level hash) - (put' (level-up level) hash key val Hash empty)))) - ## Otherwise, I just resize the #Base node to accommodate the - ## new KV-pair. - (#Base (set-bit-position bit bitmap) - (insert! (base-index bit bitmap) (#;Right [key val]) base)))))) - - ## For #Collisions nodes, I compare the hashes. - (#Collisions _hash _colls) - (if (n.= hash _hash) - ## If they're equal, that means the new KV contributes to the - ## collisions. - (case (collision-index Hash key _colls) - ## If the key was already present in the collisions-list, it's - ## value gets updated. - (#;Some coll-idx) - (#Collisions _hash (update! coll-idx [key val] _colls)) - - ## Otherwise, the KV-pair is added to the collisions-list. - #;None - (#Collisions _hash (insert! (array;size _colls) [key val] _colls))) - ## If the hashes are not equal, I create a new #Base node that - ## contains the old #Collisions node, plus the new KV-pair. - (|> (#Base (bit-position level _hash) - (|> (: (Base ($ +0) ($ +1)) - (array;new +1)) - (array;put +0 (#;Left node)))) - (put' level hash key val Hash))) - )) - -(def: (remove' level hash key Hash node) - (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Node K V))) - (case node - ## For #Hierarchy nodes, find out if there's a valid sub-node for - ## the Hash-Code. - (#Hierarchy h-size h-array) - (let [idx (level-index level hash)] - (case (array;get idx h-array) - ## If not, there's nothing to remove. - #;None - node - - ## But if there is, try to remove the key from the sub-node. - (#;Some sub-node) - (let [sub-node' (remove' (level-up level) hash key Hash sub-node)] - ## Then check if a removal was actually done. - (if (is sub-node sub-node') - ## If not, then there's nothing to change here either. - node - ## But if the sub-removal yielded an empty sub-node... - (if (empty?' sub-node') - ## Check if it's due time for a demotion. - (if (n.<= demotion-threshold h-size) - ## If so, perform it. - (#Base (demote-hierarchy idx [h-size h-array])) - ## Otherwise, just clear the space. - (#Hierarchy (n.dec h-size) (vacant! idx h-array))) - ## But if the sub-removal yielded a non-empty node, then - ## just update the hiearchy branch. - (#Hierarchy h-size (update! idx sub-node' h-array))))))) - - ## For #Base nodes, check whether the BitPosition is set. - (#Base bitmap base) - (let [bit (bit-position level hash)] - (if (bit-position-is-set? bit bitmap) - (let [idx (base-index bit bitmap)] - (case (array;get idx base) - #;None - (undefined) - - ## If set, check if it's a sub-node, and remove the KV - ## from it. - (#;Some (#;Left sub-node)) - (let [sub-node' (remove' (level-up level) hash key Hash sub-node)] - ## Verify that it was removed. - (if (is sub-node sub-node') - ## If not, there's also nothing to change here. - node - ## But if it came out empty... - (if (empty?' sub-node') - ### ... figure out whether that's the only position left. - (if (only-bit-position? bit bitmap) - ## If so, removing it leaves this node empty too. - empty - ## But if not, then just unset the position and - ## remove the node. - (#Base (unset-bit-position bit bitmap) - (remove! idx base))) - ## But, if it didn't come out empty, then the - ## position is kept, and the node gets updated. - (#Base bitmap - (update! idx (#;Left sub-node') base))))) - - ## If, however, there was a KV pair instead of a sub-node. - (#;Some (#;Right [key' val'])) - ## Check if the keys match. - (if (:: Hash = key key') - ## If so, remove the KV pair and unset the BitPosition. - (#Base (unset-bit-position bit bitmap) - (remove! idx base)) - ## Otherwise, there's nothing to remove. - node))) - ## If the BitPosition is not set, there's nothing to remove. - node)) - - ## For #Collisions nodes, It need to find out if the key already existst. - (#Collisions _hash _colls) - (case (collision-index Hash key _colls) - ## If not, then there's nothing to remove. - #;None - node - - ## But if so, then check the size of the collisions list. - (#;Some idx) - (if (n.= +1 (array;size _colls)) - ## If there's only one left, then removing it leaves us with - ## an empty node. - empty - ## Otherwise, just shrink the array by removing the KV pair. - (#Collisions _hash (remove! idx _colls)))) - )) - -(def: (get' level hash key Hash node) - (All [K V] (-> Level Hash-Code K (Hash K) (Node K V) (Maybe V))) - (case node - ## For #Hierarchy nodes, just look-up the key on its children. - (#Hierarchy _size hierarchy) - (case (array;get (level-index level hash) hierarchy) - #;None #;None - (#;Some sub-node) (get' (level-up level) hash key Hash sub-node)) - - ## For #Base nodes, check the leaves, and recursively check the branches. - (#Base bitmap base) - (let [bit (bit-position level hash)] - (if (bit-position-is-set? bit bitmap) - (case (array;get (base-index bit bitmap) base) - #;None - (undefined) - - (#;Some (#;Left sub-node)) - (get' (level-up level) hash key Hash sub-node) - - (#;Some (#;Right [key' val'])) - (if (:: Hash = key key') - (#;Some val') - #;None)) - #;None)) - - ## For #Collisions nodes, do a linear scan of all the known KV-pairs. - (#Collisions _hash _colls) - (:: Monad map product;right - (array;find (|>. product;left (:: Hash = key)) - _colls)) - )) - -(def: (size' node) - (All [K V] (-> (Node K V) Nat)) - (case node - (#Hierarchy _size hierarchy) - (Array/fold n.+ +0 (Array/map size' hierarchy)) - - (#Base _ base) - (Array/fold n.+ +0 (Array/map (lambda [sub-node'] - (case sub-node' - (#;Left sub-node) (size' sub-node) - (#;Right _) +1)) - base)) - - (#Collisions hash colls) - (array;size colls) - )) - -(def: (entries' node) - (All [K V] (-> (Node K V) (List [K V]))) - (case node - (#Hierarchy _size hierarchy) - (Array/fold (lambda [sub-node tail] (List/append (entries' sub-node) tail)) - #;Nil - hierarchy) - - (#Base bitmap base) - (Array/fold (lambda [branch tail] - (case branch - (#;Left sub-node) - (List/append (entries' sub-node) tail) - - (#;Right [key' val']) - (#;Cons [key' val'] tail))) - #;Nil - base) - - (#Collisions hash colls) - (Array/fold (lambda [[key' val'] tail] (#;Cons [key' val'] tail)) - #;Nil - colls))) - -## [Exports] -(type: #export (Dict k v) - {#;doc "A dictionary implemented as a Hash-Array Mapped Trie (HAMT)."} - {#hash (Hash k) - #root (Node k v)}) - -(def: #export (new Hash) - (All [K V] (-> (Hash K) (Dict K V))) - {#hash Hash - #root empty}) - -(def: #export (put key val dict) - (All [K V] (-> K V (Dict K V) (Dict K V))) - (let [[Hash node] dict] - [Hash (put' root-level (:: Hash hash key) key val Hash node)])) - -(def: #export (remove key dict) - (All [K V] (-> K (Dict K V) (Dict K V))) - (let [[Hash node] dict] - [Hash (remove' root-level (:: Hash hash key) key Hash node)])) - -(def: #export (get key dict) - (All [K V] (-> K (Dict K V) (Maybe V))) - (let [[Hash node] dict] - (get' root-level (:: Hash hash key) key Hash node))) - -(def: #export (contains? key table) - (All [K V] (-> K (Dict K V) Bool)) - (case (get key table) - #;None false - (#;Some _) true)) - -(def: #export (put~ key val table) - {#;doc "Only puts the KV-pair if the key is not already present."} - (All [K V] (-> K V (Dict K V) (Dict K V))) - (if (contains? key table) - table - (put key val table))) - -(def: #export (update key f table) - {#;doc "Transforms the value located at key (if available), using the given function."} - (All [K V] (-> K (-> V V) (Dict K V) (Dict K V))) - (case (get key table) - #;None - table - - (#;Some val) - (put key (f val) table))) - -(def: #export size - (All [K V] (-> (Dict K V) Nat)) - (|>. product;right size')) - -(def: #export empty? - (All [K V] (-> (Dict K V) Bool)) - (|>. size (n.= +0))) - -(def: #export (entries dict) - (All [K V] (-> (Dict K V) (List [K V]))) - (entries' (product;right dict))) - -(def: #export (from-list Hash kvs) - (All [K V] (-> (Hash K) (List [K V]) (Dict K V))) - (List/fold (lambda [[k v] dict] - (put k v dict)) - (new Hash) - kvs)) - -(do-template [ ] - [(def: #export ( dict) - (All [K V] (-> (Dict K V) (List ))) - (|> dict entries (List/map )))] - - [keys K product;left] - [values V product;right] - ) - -(def: #export (merge dict2 dict1) - {#;doc "Merges 2 dictionaries. - - If any collisions with keys occur, the values of dict2 will overwrite those of dict1."} - (All [K V] (-> (Dict K V) (Dict K V) (Dict K V))) - (List/fold (lambda [[key val] dict] (put key val dict)) - dict1 - (entries dict2))) - -(def: #export (merge-with f dict2 dict1) - {#;doc "Merges 2 dictionaries. - - If any collisions with keys occur, a new value will be computed by applying 'f' to the values of dict2 and dict1."} - (All [K V] (-> (-> V V V) (Dict K V) (Dict K V) (Dict K V))) - (List/fold (lambda [[key val2] dict] - (case (get key dict) - #;None - (put key val2 dict) - - (#;Some val1) - (put key (f val2 val1) dict))) - dict1 - (entries dict2))) - -(def: #export (re-bind from-key to-key dict) - (All [K V] (-> K K (Dict K V) (Dict K V))) - (case (get from-key dict) - #;None - dict - - (#;Some val) - (|> dict - (remove from-key) - (put to-key val)))) - -(def: #export (select keys dict) - {#;doc "Creates a sub-set of the given dict, with only the specified keys."} - (All [K V] (-> (List K) (Dict K V) (Dict K V))) - (let [[Hash _] dict] - (List/fold (lambda [key new-dict] - (case (get key dict) - #;None new-dict - (#;Some val) (put key val new-dict))) - (new Hash) - keys))) - -## [Structures] -(struct: #export (Eq Eq) (All [k v] (-> (Eq v) (Eq (Dict k v)))) - (def: (= test subject) - (and (n.= (size test) - (size subject)) - (list;every? (lambda [k] - (case [(get k test) (get k subject)] - [(#;Some tk) (#;Some sk)] - (:: Eq = tk sk) - - _ - false)) - (keys test))))) diff --git a/stdlib/source/lux/data/struct/list.lux b/stdlib/source/lux/data/struct/list.lux deleted file mode 100644 index 3228e1d78..000000000 --- a/stdlib/source/lux/data/struct/list.lux +++ /dev/null @@ -1,504 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control monoid - functor - applicative - ["M" monad #*] - eq - [fold]) - (data [number "Int/" Number Codec] - bool - [product]) - codata/function)) - -## [Types] -## (type: (List a) -## #Nil -## (#Cons a (List a))) - -## [Functions] -(struct: #export _ (fold;Fold List) - (def: (fold f init xs) - (case xs - #;Nil - init - - (#;Cons [x xs']) - (fold f (f x init) xs')))) - -(open Fold) - -(def: #export (reverse xs) - (All [a] - (-> (List a) (List a))) - (fold (lambda [head tail] (#;Cons head tail)) - #;Nil - xs)) - -(def: #export (filter p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - (if (p x) - (#;Cons [x (filter p xs')]) - (filter p xs')))) - -(def: #export (partition p xs) - {#;doc "Divide the list into all elements that satisfy a predicate, and all elements that don't."} - (All [a] (-> (-> a Bool) (List a) [(List a) (List a)])) - [(filter p xs) (filter (complement p) xs)]) - -(def: #export (as-pairs xs) - {#;doc "Cut the list into pairs of 2. - - Caveat emptor: If the list has an uneven number of elements, the last one will be skipped."} - (All [a] (-> (List a) (List [a a]))) - (case xs - (^ (#;Cons [x1 (#;Cons [x2 xs'])])) - (#;Cons [[x1 x2] (as-pairs xs')]) - - _ - #;Nil)) - -(do-template [ ] - [(def: #export ( n xs) - (All [a] - (-> Nat (List a) (List a))) - (if (n.> +0 n) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - ) - ))] - - [take (#;Cons [x (take (n.dec n) xs')]) #;Nil] - [drop (drop (n.dec n) xs') xs] - ) - -(do-template [ ] - [(def: #export ( p xs) - (All [a] - (-> (-> a Bool) (List a) (List a))) - (case xs - #;Nil - #;Nil - - (#;Cons [x xs']) - (if (p x) - - )))] - - [take-while (#;Cons [x (take-while p xs')]) #;Nil] - [drop-while (drop-while p xs') xs] - ) - -(def: #export (split n xs) - (All [a] - (-> Nat (List a) [(List a) (List a)])) - (if (n.> +0 n) - (case xs - #;Nil - [#;Nil #;Nil] - - (#;Cons [x xs']) - (let [[tail rest] (split (n.dec n) xs')] - [(#;Cons [x tail]) rest])) - [#;Nil xs])) - -(def: (split-with' p ys xs) - (All [a] - (-> (-> a Bool) (List a) (List a) [(List a) (List a)])) - (case xs - #;Nil - [ys xs] - - (#;Cons [x xs']) - (if (p x) - (split-with' p (#;Cons [x ys]) xs') - [ys xs]))) - -(def: #export (split-with p xs) - {#;doc "Segment the list by using a predicate to tell when to cut."} - (All [a] - (-> (-> a Bool) (List a) [(List a) (List a)])) - (let [[ys' xs'] (split-with' p #;Nil xs)] - [(reverse ys') xs'])) - -(def: #export (split-all n xs) - {#;doc "Segment the list in chunks of size n."} - (All [a] (-> Nat (List a) (List (List a)))) - (case xs - #;Nil - (list) - - _ - (let [[pre post] (split n xs)] - (#;Cons pre (split-all n post))))) - -(def: #export (repeat n x) - {#;doc "A list of the value x, repeated n times."} - (All [a] - (-> Nat a (List a))) - (if (n.> +0 n) - (#;Cons [x (repeat (n.dec n) x)]) - #;Nil)) - -(def: (iterate' f x) - (All [a] - (-> (-> a (Maybe a)) a (List a))) - (case (f x) - (#;Some x') - (list& x (iterate' f x')) - - #;None - (list))) - -(def: #export (iterate f x) - {#;doc "Generates a list element by element until the function returns #;None."} - (All [a] - (-> (-> a (Maybe a)) a (List a))) - (case (f x) - (#;Some x') - (list& x (iterate' f x')) - - #;None - (list x))) - -(def: #export (find p xs) - {#;doc "Returns the first value in the list for which the predicate is true."} - (All [a] - (-> (-> a Bool) (List a) (Maybe a))) - (case xs - #;Nil - #;None - - (#;Cons [x xs']) - (if (p x) - (#;Some x) - (find p xs')))) - -(def: #export (interpose sep xs) - {#;doc "Puts a value between every two elements in the list."} - (All [a] - (-> a (List a) (List a))) - (case xs - #;Nil - xs - - (#;Cons [x #;Nil]) - xs - - (#;Cons [x xs']) - (#;Cons [x (#;Cons [sep (interpose sep xs')])]))) - -(def: #export (size list) - (All [a] (-> (List a) Nat)) - (fold (lambda [_ acc] (n.+ +1 acc)) +0 list)) - -(do-template [ ] - [(def: #export ( p xs) - (All [a] - (-> (-> a Bool) (List a) Bool)) - (fold (lambda [_2 _1] ( _1 (p _2))) xs))] - - [every? true and] - [any? false or]) - -(def: #export (at i xs) - {#;doc "Fetches the element at the specified index."} - (All [a] - (-> Nat (List a) (Maybe a))) - (case xs - #;Nil - #;None - - (#;Cons [x xs']) - (if (n.= +0 i) - (#;Some x) - (at (n.dec i) xs')))) - -## [Structures] -(struct: #export (Eq Eq) - (All [a] (-> (Eq a) (Eq (List a)))) - (def: (= xs ys) - (case [xs ys] - [#;Nil #;Nil] - true - - [(#;Cons x xs') (#;Cons y ys')] - (and (:: Eq = x y) - (= xs' ys')) - - [_ _] - false - ))) - -(struct: #export Monoid (All [a] - (Monoid (List a))) - (def: unit #;Nil) - (def: (append xs ys) - (case xs - #;Nil ys - (#;Cons x xs') (#;Cons x (append xs' ys))))) - -(open Monoid) - -(struct: #export _ (Functor List) - (def: (map f ma) - (case ma - #;Nil #;Nil - (#;Cons a ma') (#;Cons (f a) (map f ma'))))) - -(open Functor) - -(struct: #export _ (Applicative List) - (def: functor Functor) - - (def: (wrap a) - (#;Cons a #;Nil)) - - (def: (apply ff fa) - (case ff - #;Nil - #;Nil - - (#;Cons f ff') - (append (map f fa) (apply ff' fa))))) - -(struct: #export _ (Monad List) - (def: applicative Applicative) - - (def: join (|>. reverse (fold append unit)))) - -## [Functions] -(def: #export (sort < xs) - (All [a] (-> (-> a a Bool) (List a) (List a))) - (case xs - #;Nil - (list) - - (#;Cons x xs') - (let [[pre post] (fold (lambda [x' [pre post]] - (if (< x x') - [(#;Cons x' pre) post] - [pre (#;Cons x' post)])) - [(list) (list)] - xs')] - ($_ append (sort < pre) (list x) (sort < post))))) - -(do-template [ ] - [(def: #export ( from to) - {#;doc "Generates an inclusive interval of values [from, to]."} - (-> (List )) - (if ( to from) - (list& from ( ( from) to)) - (list)))] - - [i.range Int i.<= i.inc] - [n.range Nat n.<= n.inc] - ) - -(def: #export (empty? xs) - (All [a] (-> (List a) Bool)) - (case xs - #;Nil true - _ false)) - -(def: #export (member? eq xs x) - (All [a] (-> (Eq a) (List a) a Bool)) - (case xs - #;Nil false - (#;Cons x' xs') (or (:: eq = x x') - (member? eq xs' x)))) - -(do-template [ ] - [(def: #export ( xs) - {#;doc } - (All [a] (-> (List a) (Maybe ))) - (case xs - #;Nil - #;None - - (#;Cons x xs') - (#;Some )))] - - [head a x "Returns the first element of a list."] - [tail (List a) xs' "For a list of size N, returns the N-1 elements after the first one."] - ) - -## [Syntax] -(def: (symbol$ name) - (-> Text AST) - [["" -1 -1] (#;SymbolS "" name)]) - -(macro: #export (zip tokens state) - {#;doc (doc "Create list zippers with the specified number of input lists." - (def: #export zip2 (zip 2)) - (def: #export zip3 (zip 3)) - ((zip 3) xs ys zs))} - (case tokens - (^ (list [_ (#;IntS num-lists)])) - (if (i.> 0 num-lists) - (let [(^open) Functor - indices (i.range 0 (i.dec num-lists)) - type-vars (: (List AST) (map (. symbol$ Int/encode) indices)) - zip-type (` (All [(~@ type-vars)] - (-> (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) - type-vars)) - (List [(~@ type-vars)])))) - vars+lists (|> indices - (map i.inc) - (map (lambda [idx] - [(symbol$ (Int/encode idx)) - (symbol$ (Int/encode (Int/negate idx)))]))) - pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) - vars+lists))]) - g!step (symbol$ "\tstep\t") - g!blank (symbol$ "\t_\t") - list-vars (map product;right vars+lists) - code (` (: (~ zip-type) - (lambda (~ g!step) [(~@ list-vars)] - (case [(~@ list-vars)] - (~ pattern) - (#;Cons [(~@ (map product;left vars+lists))] - ((~ g!step) (~@ list-vars))) - - (~ g!blank) - #;Nil))))] - (#;Right [state (list code)])) - (#;Left "Can't zip 0 lists.")) - - _ - (#;Left "Wrong syntax for zip"))) - -(def: #export zip2 (zip 2)) -(def: #export zip3 (zip 3)) - -(macro: #export (zip-with tokens state) - {#;doc (doc "Create list zippers with the specified number of input lists." - (def: #export zip2-with (zip-with 2)) - (def: #export zip3-with (zip-with 3)) - ((zip-with 2) i.+ xs ys))} - (case tokens - (^ (list [_ (#;IntS num-lists)])) - (if (i.> 0 num-lists) - (let [(^open) Functor - indices (i.range 0 (i.dec num-lists)) - g!return-type (symbol$ "\treturn-type\t") - g!func (symbol$ "\tfunc\t") - type-vars (: (List AST) (map (. symbol$ Int/encode) indices)) - zip-type (` (All [(~@ type-vars) (~ g!return-type)] - (-> (-> (~@ type-vars) (~ g!return-type)) - (~@ (map (: (-> AST AST) (lambda [var] (` (List (~ var))))) - type-vars)) - (List (~ g!return-type))))) - vars+lists (|> indices - (map i.inc) - (map (lambda [idx] - [(symbol$ (Int/encode idx)) - (symbol$ (Int/encode (Int/negate idx)))]))) - pattern (` [(~@ (map (lambda [[v vs]] (` (#;Cons (~ v) (~ vs)))) - vars+lists))]) - g!step (symbol$ "\tstep\t") - g!blank (symbol$ "\t_\t") - list-vars (map product;right vars+lists) - code (` (: (~ zip-type) - (lambda (~ g!step) [(~ g!func) (~@ list-vars)] - (case [(~@ list-vars)] - (~ pattern) - (#;Cons ((~ g!func) (~@ (map product;left vars+lists))) - ((~ g!step) (~ g!func) (~@ list-vars))) - - (~ g!blank) - #;Nil))))] - (#;Right [state (list code)])) - (#;Left "Can't zip-with 0 lists.")) - - _ - (#;Left "Wrong syntax for zip-with"))) - -(def: #export zip2-with (zip-with 2)) -(def: #export zip3-with (zip-with 3)) - -(def: #export (last xs) - (All [a] (-> (List a) (Maybe a))) - (case xs - #;Nil - #;None - - (#;Cons x #;Nil) - (#;Some x) - - (#;Cons x xs') - (last xs'))) - -(def: #export (inits xs) - {#;doc "For a list of size N, returns the first N-1 elements. - - Empty lists will result in a #;None value being returned instead."} - (All [a] (-> (List a) (Maybe (List a)))) - (case xs - #;Nil - #;None - - (#;Cons x #;Nil) - (#;Some #;Nil) - - (#;Cons x xs') - (case (inits xs') - #;None - (undefined) - - (#;Some tail) - (#;Some (#;Cons x tail))) - )) - -(def: #export (concat xss) - (All [a] (-> (List (List a)) (List a))) - (:: Monad join xss)) - -(struct: #export (ListT Monad) - (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) - (def: applicative (compA (get@ #M;applicative Monad) Applicative)) - (def: (join MlMla) - (do Monad - [lMla MlMla - lla (: (($ +0) (List (List ($ +1)))) - (seqM @ lMla))] - (wrap (concat lla))))) - -(def: #export (lift-list Monad) - (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) - (liftM Monad (:: Monad wrap))) - -(def: (enumerate' idx xs) - (All [a] (-> Nat (List a) (List [Nat a]))) - (case xs - #;Nil - #;Nil - - (#;Cons x xs') - (#;Cons [idx x] (enumerate' (n.inc idx) xs')))) - -(def: #export (enumerate xs) - {#;doc "Pairs every element in the list with it's index, starting at 0."} - (All [a] (-> (List a) (List [Nat a]))) - (enumerate' +0 xs)) - -(def: #export (indices size) - {#;doc "Produces all the valid indices for a given size."} - (All [a] (-> Nat (List Nat))) - (if (n.= +0 size) - (list) - (|> size n.dec (n.range +0)))) diff --git a/stdlib/source/lux/data/struct/queue.lux b/stdlib/source/lux/data/struct/queue.lux deleted file mode 100644 index 1c7fcdc3e..000000000 --- a/stdlib/source/lux/data/struct/queue.lux +++ /dev/null @@ -1,80 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control eq) - (data (struct [list "List/" Monoid])))) - -## [Types] -(type: #export (Queue a) - {#front (List a) - #rear (List a)}) - -## [Values] -(def: #export empty - Queue - {#front (list) - #rear (list)}) - -(def: #export (from-list entries) - (All [a] (-> (List a) (Queue a))) - {#front entries - #rear (list)}) - -(def: #export (to-list queue) - (All [a] (-> (Queue a) (List a))) - (let [(^slots [#front #rear]) queue] - (List/append front (list;reverse rear)))) - -(def: #export peek - (All [a] (-> (Queue a) (Maybe a))) - (|>. (get@ #front) list;head)) - -(def: #export (size queue) - (All [a] (-> (Queue a) Nat)) - (let [(^slots [#front #rear]) queue] - (n.+ (list;size front) - (list;size rear)))) - -(def: #export empty? - (All [a] (-> (Queue a) Bool)) - (|>. (get@ [#front]) list;empty?)) - -(def: #export (member? a/Eq queue member) - (All [a] (-> (Eq a) (Queue a) a Bool)) - (let [(^slots [#front #rear]) queue] - (or (list;member? a/Eq front member) - (list;member? a/Eq rear member)))) - -(def: #export (pop queue) - (All [a] (-> (Queue a) (Queue a))) - (case (get@ #front queue) - (^ (list)) ## Empty... - queue - - (^ (list _)) ## Front has dried up... - (|> queue - (set@ #front (list;reverse (get@ #rear queue))) - (set@ #rear (list))) - - (^ (list& _ front')) ## Consume front! - (|> queue - (set@ #front front')))) - -(def: #export (push val queue) - (All [a] (-> a (Queue a) (Queue a))) - (case (get@ #front queue) - #;Nil - (set@ #front (list val) queue) - - _ - (update@ #rear (|>. (#;Cons val)) queue))) - -## [Structures] -(struct: #export (Eq Eq) - (All [a] (-> (Eq a) (Eq (Queue a)))) - (def: (= qx qy) - (:: (list;Eq Eq) = (to-list qx) (to-list qy)))) diff --git a/stdlib/source/lux/data/struct/set.lux b/stdlib/source/lux/data/struct/set.lux deleted file mode 100644 index 711ae4553..000000000 --- a/stdlib/source/lux/data/struct/set.lux +++ /dev/null @@ -1,85 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control functor - applicative - monad - eq - [hash #*]) - (data (struct [dict] - [list "List/" Fold Functor])) - (codata function))) - -## [Types] -(type: #export (Set a) - (dict;Dict a a)) - -## [Values] -(def: #export (new Hash) - (All [a] (-> (Hash a) (Set a))) - (dict;new Hash)) - -(def: #export (add elem set) - (All [a] (-> a (Set a) (Set a))) - (dict;put elem elem set)) - -(def: #export (remove elem set) - (All [a] (-> a (Set a) (Set a))) - (dict;remove elem set)) - -(def: #export (member? set elem) - (All [a] (-> (Set a) a Bool)) - (dict;contains? elem set)) - -(def: #export to-list - (All [a] (-> (Set a) (List a))) - dict;keys) - -(def: #export (from-list Hash xs) - (All [a] (-> (Hash a) (List a) (Set a))) - (List/fold add (new Hash) xs)) - -(def: #export (union xs yx) - (All [a] (-> (Set a) (Set a) (Set a))) - (dict;merge xs yx)) - -(def: #export (difference sub base) - (All [a] (-> (Set a) (Set a) (Set a))) - (List/fold remove base (to-list sub))) - -(def: #export (intersection filter base) - (All [a] (-> (Set a) (Set a) (Set a))) - (dict;select (dict;keys filter) base)) - -(def: #export (size set) - (All [a] (-> (Set a) Nat)) - (dict;size set)) - -(def: #export (empty? set) - (All [a] (-> (Set a) Bool)) - (n.= +0 (dict;size set))) - -(def: #export (sub? super sub) - (All [a] (-> (Set a) (Set a) Bool)) - (list;every? (member? super) (to-list sub))) - -(def: #export (super? sub super) - (All [a] (-> (Set a) (Set a) Bool)) - (sub? super sub)) - -## [Structures] -(struct: #export Eq (All [a] (Eq (Set a))) - (def: (= (^@ test [Hash _]) subject) - (:: (list;Eq (get@ #hash;eq Hash)) = (to-list test) (to-list subject)))) - -(struct: #export Hash (All [a] (Hash (Set a))) - (def: eq Eq) - - (def: (hash (^@ set [Hash _])) - (List/fold (lambda [elem acc] (n.+ (:: Hash hash elem) acc)) - +0 - (to-list set)))) diff --git a/stdlib/source/lux/data/struct/stack.lux b/stdlib/source/lux/data/struct/stack.lux deleted file mode 100644 index e62a74590..000000000 --- a/stdlib/source/lux/data/struct/stack.lux +++ /dev/null @@ -1,47 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (data (struct [list])))) - -## [Types] -(type: #export (Stack a) - (List a)) - -## [Values] -(def: #export empty - Stack - (list)) - -(def: #export (size stack) - (All [a] (-> (Stack a) Nat)) - (list;size stack)) - -(def: #export (empty? stack) - (All [a] (-> (Stack a) Bool)) - (list;empty? stack)) - -(def: #export (peek stack) - (All [a] (-> (Stack a) (Maybe a))) - (case stack - #;Nil - #;None - - (#;Cons value _) - (#;Some value))) - -(def: #export (pop stack) - (All [a] (-> (Stack a) (Stack a))) - (case stack - #;Nil - #;Nil - - (#;Cons _ stack') - stack')) - -(def: #export (push value stack) - (All [a] (-> a (Stack a) (Stack a))) - (#;Cons value stack)) diff --git a/stdlib/source/lux/data/struct/tree/rose.lux b/stdlib/source/lux/data/struct/tree/rose.lux deleted file mode 100644 index 8620e46a7..000000000 --- a/stdlib/source/lux/data/struct/tree/rose.lux +++ /dev/null @@ -1,60 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control monad - eq) - (data (struct [list "" Monad])) - [compiler] - (macro [ast] - ["s" syntax #+ syntax: Syntax]))) - -## [Types] -(type: #export (Tree a) - {#value a - #children (List (Tree a))}) - -## [Values] -(def: #export (flatten tree) - (All [a] (-> (Tree a) (List a))) - (#;Cons (get@ #value tree) - (join (map flatten (get@ #children tree))))) - -(def: #export (leaf value) - (All [a] (-> a (Tree a))) - {#value value - #children (list)}) - -(def: #export (branch value children) - (All [a] (-> a (List (Tree a)) (Tree a))) - {#value value - #children children}) - -## [Syntax] -(type: #rec Tree-AST - [AST (List Tree-AST)]) - -(def: (tree^ _) - (-> Unit (Syntax Tree-AST)) - (s;either (s;record (s;seq s;any (s;tuple (s;some (lambda [state] ((tree^ []) state)))))) - (s;seq s;any (:: s;Monad wrap (list))))) - -(syntax: #export (tree type [root (tree^ [])]) - {#;doc (doc "Tree literals." - (tree Int 10) - (tree Int {10 [20 - {30 []} - 40]}))} - (wrap (list (` (: (Tree (~ type)) - (~ (loop [[value children] root] - (` {#value (~ value) - #children (list (~@ (map recur children)))})))))))) - -## [Structs] -(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Tree a)))) - (def: (= tx ty) - (and (:: Eq = (get@ #value tx) (get@ #value ty)) - (:: (list;Eq (Eq Eq)) = (get@ #children tx) (get@ #children ty))))) diff --git a/stdlib/source/lux/data/struct/tree/zipper.lux b/stdlib/source/lux/data/struct/tree/zipper.lux deleted file mode 100644 index 74dbd024f..000000000 --- a/stdlib/source/lux/data/struct/tree/zipper.lux +++ /dev/null @@ -1,197 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (data (struct [list "" Monad Fold "List/" Monoid] - (tree [rose #+ Tree]) - [stack #+ Stack])) - [compiler] - (macro [ast] - ["s" syntax #+ syntax: Syntax]))) - -## Adapted from the clojure.zip namespace in the Clojure standard library. - -## [Types] -(type: #export (Zipper a) - {#;doc "Tree zippers, for easy navigation and editing over trees."} - {#parent (Maybe (Zipper a)) - #lefts (Stack (Tree a)) - #rights (Stack (Tree a)) - #node (Tree a)}) - -## [Values] -(def: #export (from-tree tree) - (All [a] (-> (Tree a) (Zipper a))) - {#parent #;None - #lefts stack;empty - #rights stack;empty - #node tree}) - -(def: #export (to-tree zipper) - (All [a] (-> (Zipper a) (Tree a))) - (get@ #node zipper)) - -(def: #export (value zipper) - (All [a] (-> (Zipper a) a)) - (|> zipper (get@ #node) (get@ #rose;value))) - -(def: #export (children zipper) - (All [a] (-> (Zipper a) (List (Tree a)))) - (|> zipper (get@ #node) (get@ #rose;children))) - -(def: #export (branch? zipper) - (All [a] (-> (Zipper a) Bool)) - (|> zipper children list;empty? not)) - -(def: #export (leaf? zipper) - (All [a] (-> (Zipper a) Bool)) - (|> zipper branch? not)) - -(def: #export (parent zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (get@ #parent zipper)) - -(def: #export (down zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (children zipper) - #;Nil - zipper - - (#;Cons chead ctail) - {#parent (#;Some zipper) - #lefts stack;empty - #rights ctail - #node chead})) - -(def: #export (up zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ #parent zipper) - #;None - zipper - - (#;Some parent) - (|> parent - (update@ #node (: (-> (Tree ($ +0)) (Tree ($ +0))) - (lambda [node] - (set@ #rose;children (List/append (list;reverse (get@ #lefts zipper)) - (#;Cons (get@ #node zipper) - (get@ #rights zipper))) - node))))))) - -(def: #export (root zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (loop [zipper zipper] - (case (get@ #parent zipper) - #;None zipper - (#;Some _) (recur (up zipper))))) - -(do-template [ ] - [(def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ zipper) - #;Nil - zipper - - (#;Cons next side') - (|> zipper - (update@ (lambda [op-side] - (#;Cons (get@ #node zipper) op-side))) - (set@ side') - (set@ #node next)))) - - (def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (fold (lambda [_] ) zipper (get@ zipper)))] - - [right rightmost #rights #lefts] - [left leftmost #lefts #rights] - ) - -(def: #export (set value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (set@ [#node #rose;value] value zipper)) - -(def: #export (update f zipper) - (All [a] (-> (-> a a) (Zipper a) (Zipper a))) - (update@ [#node #rose;value] f zipper)) - -(def: #export (prepend-child value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #rose;children] - (lambda [children] - (#;Cons (rose;tree ($ +0) {value []}) - children)) - zipper)) - -(def: #export (append-child value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #rose;children] - (lambda [children] - (List/append children - (list (rose;tree ($ +0) {value []})))) - zipper)) - -(def: #export (remove zipper) - (All [a] (-> (Zipper a) (Maybe (Zipper a)))) - (case (get@ #lefts zipper) - #;Nil - (case (get@ #parent zipper) - #;None - #;None - - (#;Some next) - (#;Some (|> next - (update@ [#node #rose;children] (|>. list;tail (default (list))))))) - - (#;Cons next side) - (#;Some (|> zipper - (set@ #lefts side) - (set@ #node next))))) - -(do-template [ ] - [(def: #export ( value zipper) - (All [a] (-> a (Zipper a) (Maybe (Zipper a)))) - (case (get@ #parent zipper) - #;None - #;None - - _ - (#;Some (|> zipper - (update@ (lambda [side] - (#;Cons (rose;tree ($ +0) {value []}) - side)))))))] - - [insert-left #lefts] - [insert-right #rights] - ) - -(do-template [ ] - [(def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (case (get@ zipper) - #;Nil - ( zipper) - - _ - ( zipper)))] - - [next #rights right down] - [prev #lefts left up] - ) - -(def: #export (end? zipper) - (All [a] (-> (Zipper a) Bool)) - (and (list;empty? (get@ #rights zipper)) - (list;empty? (children zipper)))) - -(def: #export (root? zipper) - (All [a] (-> (Zipper a) Bool)) - (case (get@ #parent zipper) - #;None - true - - _ - false)) diff --git a/stdlib/source/lux/data/struct/vector.lux b/stdlib/source/lux/data/struct/vector.lux deleted file mode 100644 index 9a22efb93..000000000 --- a/stdlib/source/lux/data/struct/vector.lux +++ /dev/null @@ -1,451 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control functor - applicative - monad - eq - monoid - fold) - (data maybe - (struct [list "List/" Fold Functor Monoid] - [array #+ Array "Array/" Functor Fold]) - [bit] - [number "Int/" Number] - [product]) - [compiler #+ with-gensyms] - (macro [ast] - ["s" syntax #+ syntax: Syntax]) - [pipe] - )) - -## This implementation of vectors is based on Clojure's -## PersistentVector implementation. - -## [Utils] -(type: (Node a) - (#Base (Array a)) - (#Hierarchy (Array (Node a)))) - -(type: (Base a) (Array a)) -(type: (Hierarchy a) (Array (Node a))) - -(type: Level Nat) - -(type: Index Nat) - -(def: branching-exponent - Nat - +5) - -(def: root-level - Level - +0) - -(do-template [ ] - [(def: - (-> Level Level) - ( branching-exponent))] - - [level-up n.+] - [level-down n.-] - ) - -(def: full-node-size - Nat - (bit;<< branching-exponent +1)) - -(def: branch-idx-mask - Nat - (n.dec full-node-size)) - -(def: branch-idx - (-> Index Index) - (bit;& branch-idx-mask)) - -(def: (new-hierarchy _) - (All [a] (-> Top (Hierarchy a))) - (array;new full-node-size)) - -(def: (tail-off vec-size) - (-> Nat Nat) - (if (n.< full-node-size vec-size) - +0 - (|> (n.dec vec-size) - (bit;>>> branching-exponent) - (bit;<< branching-exponent)))) - -(def: (new-path level tail) - (All [a] (-> Level (Base a) (Node a))) - (if (n.= +0 level) - (#Base tail) - (|> (: (Hierarchy ($ +0)) - (new-hierarchy [])) - (array;put +0 (new-path (level-down level) tail)) - #Hierarchy))) - -(def: (new-tail singleton) - (All [a] (-> a (Base a))) - (|> (: (Base ($ +0)) - (array;new +1)) - (array;put +0 singleton))) - -(def: (push-tail size level tail parent) - (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a))) - (let [sub-idx (branch-idx (bit;>>> level (n.dec size))) - ## If we're currently on a bottom node - sub-node (if (n.= branching-exponent level) - ## Just add the tail to it - (#Base tail) - ## Otherwise, check whether there's a vacant spot - (case (array;get sub-idx parent) - ## If so, set the path to the tail - #;None - (new-path (level-down level) tail) - ## If not, push the tail onto the sub-node. - (#;Some (#Hierarchy sub-node)) - (#Hierarchy (push-tail size (level-down level) tail sub-node)) - - _ - (undefined)) - )] - (|> (array;clone parent) - (array;put sub-idx sub-node)))) - -(def: (expand-tail val tail) - (All [a] (-> a (Base a) (Base a))) - (let [tail-size (array;size tail)] - (|> (: (Base ($ +0)) - (array;new (n.inc tail-size))) - (array;copy tail-size +0 tail +0) - (array;put tail-size val) - ))) - -(def: (put' level idx val hierarchy) - (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a))) - (let [sub-idx (branch-idx (bit;>>> level idx))] - (case (array;get sub-idx hierarchy) - (#;Some (#Hierarchy sub-node)) - (|> (array;clone hierarchy) - (array;put sub-idx (#Hierarchy (put' (level-down level) idx val sub-node)))) - - (^=> (#;Some (#Base base)) - (n.= +0 (level-down level))) - (|> (array;clone hierarchy) - (array;put sub-idx (|> (array;clone base) - (array;put (branch-idx idx) val) - #Base))) - - _ - (undefined)))) - -(def: (pop-tail size level hierarchy) - (All [a] (-> Nat Level (Hierarchy a) (Maybe (Hierarchy a)))) - (let [sub-idx (branch-idx (bit;>>> level (n.- +2 size)))] - (cond (n.= +0 sub-idx) - #;None - - (n.> branching-exponent level) - (do Monad - [base|hierarchy (array;get sub-idx hierarchy) - sub (case base|hierarchy - (#Hierarchy sub) - (pop-tail size (level-down level) sub) - - (#Base _) - (undefined))] - (|> (array;clone hierarchy) - (array;put sub-idx (#Hierarchy sub)) - #;Some)) - - ## Else... - (|> (array;clone hierarchy) - (array;remove sub-idx) - #;Some) - ))) - -(def: (to-list' node) - (All [a] (-> (Node a) (List a))) - (case node - (#Base base) - (array;to-list base) - - (#Hierarchy hierarchy) - (|> hierarchy - array;to-list - list;reverse - (List/fold (lambda [sub acc] (List/append (to-list' sub) acc)) - #;Nil)))) - -## [Types] -(type: #export (Vector a) - {#level Level - #size Nat - #root (Hierarchy a) - #tail (Base a)}) - -## [Exports] -(def: #export empty - Vector - {#level (level-up root-level) - #size +0 - #root (array;new full-node-size) - #tail (array;new +0)}) - -(def: #export (size vector) - (All [a] (-> (Vector a) Nat)) - (get@ #size vector)) - -(def: #export (add val vec) - (All [a] (-> a (Vector a) (Vector a))) - ## Check if there is room in the tail. - (let [vec-size (get@ #size vec)] - (if (|> vec-size (n.- (tail-off vec-size)) (n.< full-node-size)) - ## If so, append to it. - (|> vec - (update@ #size n.inc) - (update@ #tail (expand-tail val))) - ## Otherwise, push tail into the tree - ## -------------------------------------------------------- - ## Will the root experience an overflow with this addition? - (|> (if (n.> (bit;<< (get@ #level vec) +1) - (bit;>>> branching-exponent vec-size)) - ## If so, a brand-new root must be established, that is - ## 1-level taller. - (|> vec - (set@ #root (|> (: (Hierarchy ($ +0)) - (new-hierarchy [])) - (array;put +0 (#Hierarchy (get@ #root vec))) - (array;put +1 (new-path (get@ #level vec) (get@ #tail vec))))) - (update@ #level level-up)) - ## Otherwise, just push the current tail onto the root. - (|> vec - (update@ #root (push-tail vec-size (get@ #level vec) (get@ #tail vec))))) - ## Finally, update the size of the Vector and grow a new - ## tail with the new element as it's sole member. - (update@ #size n.inc) - (set@ #tail (new-tail val))) - ))) - -(def: (base-for idx vec) - (All [a] (-> Index (Vector a) (Maybe (Base a)))) - (let [vec-size (get@ #size vec)] - (if (and (n.>= +0 idx) - (n.< vec-size idx)) - (if (n.>= (tail-off vec-size) idx) - (#;Some (get@ #tail vec)) - (loop [level (get@ #level vec) - hierarchy (get@ #root vec)] - (case [(n.> branching-exponent level) - (array;get (branch-idx (bit;>>> level idx)) hierarchy)] - [true (#;Some (#Hierarchy sub))] - (recur (level-down level) sub) - - [false (#;Some (#Base base))] - (#;Some base) - - [_ #;None] - #;None - - _ - (error! "Incorrect vector structure.")))) - #;None))) - -(def: #export (at idx vec) - (All [a] (-> Nat (Vector a) (Maybe a))) - (do Monad - [base (base-for idx vec)] - (array;get (branch-idx idx) base))) - -(def: #export (put idx val vec) - (All [a] (-> Nat a (Vector a) (Vector a))) - (let [vec-size (get@ #size vec)] - (if (and (n.>= +0 idx) - (n.< vec-size idx)) - (if (n.>= (tail-off vec-size) idx) - (|> vec - (update@ #tail (: (-> (Base ($ +0)) (Base ($ +0))) - (|>. array;clone (array;put (branch-idx idx) val))))) - (|> vec - (update@ #root (put' (get@ #level vec) idx val)))) - vec))) - -(def: #export (update idx f vec) - (All [a] (-> Nat (-> a a) (Vector a) (Vector a))) - (case (at idx vec) - (#;Some val) - (put idx (f val) vec) - - #;None - vec)) - -(def: #export (pop vec) - (All [a] (-> (Vector a) (Vector a))) - (case (get@ #size vec) - +0 - empty - - +1 - empty - - vec-size - (if (|> vec-size (n.- (tail-off vec-size)) (n.> +1)) - (let [old-tail (get@ #tail vec) - new-tail-size (n.dec (array;size old-tail))] - (|> vec - (update@ #size n.dec) - (set@ #tail (|> (array;new new-tail-size) - (array;copy new-tail-size +0 old-tail +0))))) - (default (undefined) - (do Monad - [new-tail (base-for (n.- +2 vec-size) vec) - #let [[level' root'] (: [Level (Hierarchy ($ +0))] - (let [init-level (get@ #level vec)] - (loop [level init-level - root (: (Hierarchy ($ +0)) - (default (new-hierarchy []) - (pop-tail vec-size init-level (get@ #root vec))))] - (if (n.> branching-exponent level) - (case [(array;get +1 root) (array;get +0 root)] - [#;None (#;Some (#Hierarchy sub-node))] - (recur (level-down level) sub-node) - - [#;None (#;Some (#Base _))] - (undefined) - - _ - [level root]) - [level root]))))]] - (wrap (|> vec - (update@ #size n.dec) - (set@ #level level') - (set@ #root root') - (set@ #tail new-tail)))))) - )) - -(def: #export (to-list vec) - (All [a] (-> (Vector a) (List a))) - (List/append (to-list' (#Hierarchy (get@ #root vec))) - (to-list' (#Base (get@ #tail vec))))) - -(def: #export (from-list list) - (All [a] (-> (List a) (Vector a))) - (List/fold add - (: (Vector ($ +0)) - empty) - list)) - -(def: #export (member? a/Eq vec val) - (All [a] (-> (Eq a) (Vector a) a Bool)) - (list;member? a/Eq (to-list vec) val)) - -(def: #export empty? - (All [a] (-> (Vector a) Bool)) - (|>. (get@ #size) (n.= +0))) - -## [Syntax] -(syntax: #export (vector [elems (s;some s;any)]) - {#;doc (doc "Vector literals." - (vector 10 20 30 40))} - (wrap (list (` (from-list (list (~@ elems))))))) - -## [Structures] -(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Node a)))) - (def: (= v1 v2) - (case [v1 v2] - [(#Base b1) (#Base b2)] - (:: (array;Eq Eq) = b1 b2) - - [(#Hierarchy h1) (#Hierarchy h2)] - (:: (array;Eq (Eq Eq)) = h1 h2) - ))) - -(struct: #export (Eq Eq) (All [a] (-> (Eq a) (Eq (Vector a)))) - (def: (= v1 v2) - (and (n.= (get@ #size v1) (get@ #size v2)) - (let [(^open "Node/") (Eq Eq)] - (and (Node/= (#Base (get@ #tail v1)) - (#Base (get@ #tail v2))) - (Node/= (#Hierarchy (get@ #root v1)) - (#Hierarchy (get@ #root v2)))))))) - -(struct: _ (Fold Node) - (def: (fold f init xs) - (case xs - (#Base base) - (Array/fold f init base) - - (#Hierarchy hierarchy) - (Array/fold (lambda [node init'] (fold f init' node)) - init - hierarchy)) - )) - -(struct: #export _ (Fold Vector) - (def: (fold f init xs) - (let [(^open) Fold] - (fold f - (fold f - init - (#Hierarchy (get@ #root xs))) - (#Base (get@ #tail xs)))) - )) - -(struct: #export Monoid (All [a] - (Monoid (Vector a))) - (def: unit empty) - (def: (append xs ys) - (List/fold add xs (to-list ys)))) - -(struct: _ (Functor Node) - (def: (map f xs) - (case xs - (#Base base) - (#Base (Array/map f base)) - - (#Hierarchy hierarchy) - (#Hierarchy (Array/map (map f) hierarchy))) - )) - -(struct: #export _ (Functor Vector) - (def: (map f xs) - {#level (get@ #level xs) - #size (get@ #size xs) - #root (|> xs (get@ #root) (Array/map (:: Functor map f))) - #tail (|> xs (get@ #tail) (Array/map f)) - })) - -(struct: #export _ (Applicative Vector) - (def: functor Functor) - - (def: (wrap x) - (vector x)) - - (def: (apply ff fa) - (let [(^open) Functor - (^open) Fold - (^open) Monoid - results (map (lambda [f] (map f fa)) - ff)] - (fold append unit results))) - ) - -(struct: #export _ (Monad Vector) - (def: applicative Applicative) - - (def: join - (let [(^open) Fold - (^open) Monoid] - (fold (lambda [post pre] (append pre post)) unit))) - ) - -(def: #export (reverse xs) - (All [a] - (-> (Vector a) (Vector a))) - (let [(^open) Fold - (^open) Monoid] - (fold add unit xs))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 85d5d9dd5..adc0454b2 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -11,7 +11,7 @@ monad codec hash) - (data (struct [list]) + (data (coll [list]) maybe))) ## [Functions] @@ -19,7 +19,7 @@ (-> Text Nat) (int-to-nat (_lux_proc ["jvm" "i2l"] [(_lux_proc ["jvm" "invokevirtual:java.lang.String:length:"] [x])]))) -(def: #export (at idx x) +(def: #export (nth idx x) (-> Nat Text (Maybe Char)) (if (n.< (size x) idx) (#;Some (_lux_proc ["jvm" "invokevirtual:java.lang.String:charAt:int"] [x (_lux_proc ["jvm" "l2i"] [(nat-to-int idx)])])) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 2ae5c62ca..732de0db4 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -11,7 +11,7 @@ [number] [text] [ident] - (struct [list "" Monad])) + (coll [list "" Monad])) [type] [compiler] (macro [ast] diff --git a/stdlib/source/lux/effect.lux b/stdlib/source/lux/effect.lux new file mode 100644 index 000000000..de3038927 --- /dev/null +++ b/stdlib/source/lux/effect.lux @@ -0,0 +1,406 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: {#;doc "Algebraic effects."} + lux + (lux (control ["F" functor] + applicative + monad) + [io #- run] + (data (coll [list "List/" Monad Monoid]) + [number "Nat/" Codec] + text/format + error + [ident "Ident/" Eq] + [text]) + [compiler] + [macro] + (macro [ast] + ["s" syntax #+ syntax: Syntax] + (syntax [common])) + [type])) + +## [Type] +(type: #export (Eff F a) + {#;doc "A Free Monad implementation for algebraic effects."} + (#Pure a) + (#Effect (F (Eff F a)))) + +(sig: #export (Handler E M) + {#;doc "A way to interpret effects into arbitrary monads."} + (: (Monad M) + monad) + (: (All [a] (-> (E a) (M a))) + handle)) + +## [Values] +(struct: #export (Functor dsl) + (All [F] (-> (F;Functor F) (F;Functor (Eff F)))) + (def: (map f ea) + (case ea + (#Pure a) + (#Pure (f a)) + + (#Effect value) + (#Effect (:: dsl map (map f) value))))) + +(struct: #export (Applicative dsl) + (All [F] (-> (F;Functor F) (Applicative (Eff F)))) + (def: functor (Functor dsl)) + + (def: (wrap a) + (#Pure a)) + + (def: (apply ef ea) + (case [ef ea] + [(#Pure f) (#Pure a)] + (#Pure (f a)) + + [(#Pure f) (#Effect fa)] + (#Effect (:: dsl map + (:: (Functor dsl) map f) + fa)) + + [(#Effect ff) _] + (#Effect (:: dsl map + (lambda [f] (apply f ea)) + ff)) + ))) + +(struct: #export (Monad dsl) + (All [F] (-> (F;Functor F) (Monad (Eff F)))) + (def: applicative (Applicative dsl)) + + (def: (join efefa) + (case efefa + (#Pure efa) + (case efa + (#Pure a) + (#Pure a) + + (#Effect fa) + (#Effect fa)) + + (#Effect fefa) + (#Effect (:: dsl map + (:: (Monad dsl) join) + fefa)) + ))) + +(type: #hidden (|@ L R) + (All [a] (| (L a) (R a)))) + +(def: #hidden (combine-functors left right) + (All [L R] + (-> (F;Functor L) (F;Functor R) + (F;Functor (|@ L R)))) + (struct + (def: (map f l|r) + (case l|r + (+0 l) (+0 (:: left map f l)) + (+1 r) (+1 (:: right map f r))) + ))) + +(def: #hidden (combine-handlers Monad left right) + (All [L R M] + (-> (Monad M) + (Handler L M) (Handler R M) + (Handler (|@ L R) M))) + (struct + (def: monad Monad) + + (def: (handle l|r) + (case l|r + (#;Left l) (:: left handle l) + (#;Right r) (:: right handle r) + )))) + +## [Syntax] +(syntax: #export (|E [effects (s;many s;any)]) + {#;doc (doc "A way to combine smaller effect into a larger effect." + (type: EffABC (|E EffA EffB EffC)))} + (wrap (list (` ($_ ;;|@ (~@ effects)))))) + +(syntax: #export (|F [functors (s;many s;any)]) + {#;doc (doc "A way to combine smaller effect functors into a larger functor." + (def: Functor + (Functor EffABC) + (|F Functor Functor Functor)))} + (wrap (list (` ($_ ;;combine-functors (~@ functors)))))) + +(syntax: #export (|H monad [handlers (s;many s;any)]) + {#;doc (doc "A way to combine smaller effect handlers into a larger handler." + (def: Handler + (Handler EffABC io;IO) + (|H io;Monad + Handler Handler Handler)))} + (do @ + [g!combiner (compiler;gensym "")] + (wrap (list (` (let [(~ g!combiner) (;;combine-handlers (~ monad))] + ($_ (~ g!combiner) (~@ handlers)))))))) + +(type: Op + {#name Text + #inputs (List AST) + #output AST}) + +(def: op^ + (Syntax Op) + (s;form (s;either ($_ s;seq + s;local-symbol + (s;tuple (s;some s;any)) + s;any) + ($_ s;seq + s;local-symbol + (:: s;Monad wrap (list)) + s;any)))) + +(syntax: #export (effect: [exp-lvl common;export-level] + [name s;local-symbol] + [ops (s;many op^)]) + {#;doc (doc "Define effects by specifying which operations and constants a handler must provide." + (effect: #export EffA + (opA [Nat Text] Bool) + (fieldA Nat)) + + "In this case, 'opA' will be a function (-> Nat Text Bool)." + "'fieldA' will be a value provided by a handler.")} + (do @ + [g!output (compiler;gensym "g!output") + #let [op-types (List/map (lambda [op] + (let [g!tag (ast;tag ["" (get@ #name op)]) + g!inputs (` [(~@ (get@ #inputs op))]) + g!output (` (-> (~ (get@ #output op)) (~ g!output)))] + (` ((~ g!tag) (~ g!inputs) (~ g!output))))) + ops) + type-name (ast;symbol ["" name]) + type-def (` (type: (~@ (common;gen-export-level exp-lvl)) + ((~ type-name) (~ g!output)) + (~@ op-types))) + op-tags (List/map (|>. (get@ #name) [""] ast;tag (list) ast;tuple) + ops) + functor-def (` (struct: (~@ (common;gen-export-level exp-lvl)) (~' _) (F;Functor (~ type-name)) + (def: ((~' map) (~' f) (~' fa)) + (case (~' fa) + (^template [(~' )] + ((~' ) (~' params) (~' cont)) + ((~' ) (~' params) (. (~' f) (~' cont)))) + ((~@ op-tags)))) + )) + function-defs (List/map (lambda [op] + (let [g!name (ast;symbol ["" (get@ #name op)]) + g!tag (ast;tag ["" (get@ #name op)]) + g!params (: (List AST) + (case (list;size (get@ #inputs op)) + +0 (list) + s (|> (list;n.range +0 (n.dec s)) + (List/map (|>. Nat/encode + (format "_") + [""] + ast;symbol)))))] + (` (def: (~@ (common;gen-export-level exp-lvl)) ((~ g!name) (~@ g!params)) + (-> (~@ (get@ #inputs op)) + ((~ type-name) (~ (get@ #output op)))) + ((~ g!tag) [(~@ g!params)] ;id))))) + ops)]] + (wrap (list& type-def + functor-def + function-defs)))) + +(type: Translation + {#effect Ident + #target-type AST + #target-monad AST}) + +(def: translation^ + (Syntax Translation) + (s;form (do s;Monad + [_ (s;this! (' =>))] + (s;seq s;symbol + (s;tuple (s;seq s;any + s;any)))))) + +(syntax: #export (handler: [exp-lvl common;export-level] + [name s;local-symbol] + [[effect target-type target-monad] translation^] + [defs (s;many (common;def *compiler*))]) + {#;doc (doc "Define effect handlers by implementing the operations and values of an effect." + (handler: _ + (=> EffA [IO Monad]) + (def: (opA length sample) + (:: Monad wrap (n.< length + (size sample)))) + + (def: fieldA (:: Monad wrap +10))) + + "Since a name for the handler was not specified, 'handler:' will generate the name as Handler.")} + (do @ + [(^@ effect [e-module _]) (compiler;un-alias effect) + g!input (compiler;gensym "g!input") + g!cont (compiler;gensym "g!cont") + g!value (compiler;gensym "value") + g!wrap (compiler;gensym "wrap") + #let [g!cases (|> defs + (List/map (lambda [def] + (let [g!tag (ast;tag [e-module (get@ #common;def-name def)]) + g!args (List/map (|>. [""] ast;symbol) + (get@ #common;def-args def)) + eff-calc (case (get@ #common;def-type def) + #;None + (get@ #common;def-value def) + + (#;Some type) + (` (: (~ type) (~ (get@ #common;def-value def))))) + invocation (case g!args + #;Nil + eff-calc + + _ + (` ((~ eff-calc) (~@ g!args))))] + (list (` ((~ g!tag) [(~@ g!args)] (~ g!cont))) + (` (do (~ target-monad) + [(~' #let) [(~ g!wrap) (~' wrap)] + (~ g!value) (~ invocation)] + ((~ g!wrap) ((~ g!cont) (~ g!value))))) + )))) + List/join)]] + (wrap (list (` (struct: (~@ (common;gen-export-level exp-lvl)) (~ (ast;symbol ["" name])) + (;;Handler (~ (ast;symbol effect)) (~ target-type)) + (def: (~' monad) (~ target-monad)) + + (def: ((~' handle) (~ g!input)) + (case (~ g!input) + (~@ g!cases)) + ))))))) + +(def: #export (with-handler handler body) + {#;doc "Handles an effectful computation with the given handler to produce a monadic value."} + (All [E M a] (-> (Handler E M) (Eff E a) (M a))) + (case body + (#Pure value) + (:: handler wrap value) + + (#Effect effect) + (do (get@ #monad handler) + [result (:: handler handle effect)] + (with-handler handler result)) + )) + +(def: (un-apply type-app) + (-> Type Type) + (case type-app + (#;AppT effect value) + effect + + _ + (error! (format "Wrong type format: " (%type type-app))))) + +(def: (clean-effect effect) + (-> Type Type) + (case effect + (#;UnivQ env body) + (#;UnivQ (list) body) + + _ + (error! (format "Wrong effect format: " (%type effect))))) + +(def: g!functor AST (ast;symbol ["" "\t@E\t"])) + +(syntax: #export (doE functor [bindings (s;tuple (s;some s;any))] body) + {#;doc (doc "An alternative to the 'do' macro for monads." + (with-handler Handler + (doE Functor + [a (lift fieldA) + b (lift fieldB) + c (lift fieldC)] + (wrap ($_ n.+ a b c)))))} + (do @ + [g!output (compiler;gensym "")] + (wrap (list (` (let [(~ g!functor) (~ functor)] + (do (Monad (~ g!functor)) + [(~@ bindings) + (~ g!output) (~ body)] + (#;;Pure (~ g!output))))))))) + +(def: (flatten-effect-stack stack) + (-> Type (List Type)) + (case stack + (#;SumT left right) + (List/append (flatten-effect-stack left) + (flatten-effect-stack right)) + + (^ (#;AppT branches (#;VarT _))) + (flatten-effect-stack branches) + + (^ (#;AppT (#;AppT (#;NamedT (ident-for ;;|@) _) + left) + right)) + (#;Cons left (flatten-effect-stack right)) + + (^ (#;AppT (#;AppT (#;NamedT (ident-for ;;Eff) _) + effect) + param)) + (list effect) + + _ + (list stack) + )) + +(def: (same-effect? expected actual) + (case [expected actual] + [(#;NamedT e-name _) (#;NamedT a-name _)] + (Ident/= e-name a-name) + + _ + false)) + +(def: (nest-effect idx total base) + (-> Nat Nat AST AST) + (cond (n.= +0 idx) + (` (+0 (~ base))) + + (n.> +2 total) + (` (+1 (~ (nest-effect (n.dec idx) (n.dec total) base)))) + + ## else + (` (+1 (~ base))) + )) + +(syntax: #export (lift [value (s;alt s;symbol + s;any)]) + {#;doc (doc "A way to (automatically) lift effectful fields and operations from simple effects into the larger space of composite effects." + (with-handler Handler + (doE Functor + [a (lift fieldA) + b (lift fieldB) + c (lift fieldC)] + (wrap ($_ n.+ a b c)))))} + (case value + (#;Left var) + (do @ + [input (compiler;find-type var) + output compiler;expected-type] + (case [input output] + (^=> [(#;AppT eff0 _) (#;AppT stackT0 recT0)] + [(type;apply-type stackT0 recT0) (#;Some unfoldT0)] + [stackT0 (^ (#;AppT (#;NamedT (ident-for ;;Eff) _) + stackT1))] + [(type;apply-type stackT1 recT0) (#;Some unfoldT1)] + [(flatten-effect-stack unfoldT1) stack] + [(|> stack list;enumerate + (list;find (lambda [[idx effect]] + (same-effect? effect eff0)))) + (#;Some [idx _])]) + (wrap (list (` (#;;Effect (:: (~ g!functor) (~' map) (~' wrap) + (~ (nest-effect idx (list;size stack) (ast;symbol var)))))))) + + _ + (compiler;fail (format "Invalid type to lift: " (%type output))))) + + (#;Right node) + (do @ + [g!value (compiler;gensym "")] + (wrap (list (` (let [(~ g!value) (~ node)] + (;;lift (~ g!value))))))))) diff --git a/stdlib/source/lux/host.lux b/stdlib/source/lux/host.lux index ededaa0a4..58d163c2e 100644 --- a/stdlib/source/lux/host.lux +++ b/stdlib/source/lux/host.lux @@ -7,10 +7,10 @@ lux (lux (control monad [enum]) - (codata function - [io #+ IO Monad io]) - (data (struct [list #* "" Functor Fold "List/" Monad Monoid] - [array #+ Array]) + [io #+ IO Monad io] + (codata function) + (data (coll [list #* "" Functor Fold "List/" Monad Monoid] + [array #+ Array]) number maybe [product] @@ -561,14 +561,14 @@ (-> Text Text (Syntax AST)) (do s;Monad [#let [dotted-name (format "." field-name)] - _ (s;sample! (ast;symbol ["" dotted-name]))] + _ (s;this! (ast;symbol ["" dotted-name]))] (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getstatic" ":" class-name ":" field-name)))] []))))) (def: (make-get-var-parser class-name field-name) (-> Text Text (Syntax AST)) (do s;Monad [#let [dotted-name (format "." field-name)] - _ (s;sample! (ast;symbol ["" dotted-name]))] + _ (s;this! (ast;symbol ["" dotted-name]))] (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "getfield" ":" class-name ":" field-name)))] [_jvm_this]))))) (def: (make-put-var-parser class-name field-name) @@ -576,7 +576,7 @@ (do s;Monad [#let [dotted-name (format "." field-name)] [_ _ value] (: (Syntax [Unit Unit AST]) - (s;form ($_ s;seq (s;sample! (' :=)) (s;sample! (ast;symbol ["" dotted-name])) s;any)))] + (s;form ($_ s;seq (s;this! (' :=)) (s;this! (ast;symbol ["" dotted-name])) s;any)))] (wrap (`' (_lux_proc ["jvm" (~ (ast;text (format "putfield" ":" class-name ":" field-name)))] [_jvm_this (~ value)]))))) (def: (pre-walk-replace f input) @@ -621,7 +621,7 @@ (-> (List TypeParam) Text (List ArgDecl) (Syntax AST)) (do s;Monad [[_ args] (: (Syntax [Unit (List AST)]) - (s;form ($_ s;seq (s;sample! (' .new!)) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + (s;form ($_ s;seq (s;this! (' .new!)) (s;tuple (s;exactly (list;size arg-decls) s;any))))) #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] (wrap (` (;_lux_proc ["jvm" (~ (ast;text (format "new" ":" class-name ":" (text;join-with "," arg-decls'))))] [(~@ args)]))))) @@ -631,7 +631,7 @@ (do s;Monad [#let [dotted-name (format "." method-name "!")] [_ args] (: (Syntax [Unit (List AST)]) - (s;form ($_ s;seq (s;sample! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format "invokestatic" ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] [(~@ args)]))))) @@ -642,7 +642,7 @@ (do s;Monad [#let [dotted-name (format "." method-name "!")] [_ args] (: (Syntax [Unit (List AST)]) - (s;form ($_ s;seq (s;sample! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) + (s;form ($_ s;seq (s;this! (ast;symbol ["" dotted-name])) (s;tuple (s;exactly (list;size arg-decls) s;any))))) #let [arg-decls' (: (List Text) (map (. (simple-class$ params) product;right) arg-decls))]] (wrap (`' (;_lux_proc ["jvm" (~ (ast;text (format ":" class-name ":" method-name ":" (text;join-with "," arg-decls'))))] [(~' _jvm_this) (~@ args)])))))] @@ -680,32 +680,32 @@ (Syntax PrivacyModifier) (let [(^open) s;Monad] ($_ s;alt - (s;sample! (' #public)) - (s;sample! (' #private)) - (s;sample! (' #protected)) + (s;this! (' #public)) + (s;this! (' #private)) + (s;this! (' #protected)) (wrap [])))) (def: inheritance-modifier^ (Syntax InheritanceModifier) (let [(^open) s;Monad] ($_ s;alt - (s;sample! (' #final)) - (s;sample! (' #abstract)) + (s;this! (' #final)) + (s;this! (' #abstract)) (wrap [])))) (def: bound-kind^ (Syntax BoundKind) - (s;alt (s;sample! (' <)) - (s;sample! (' >)))) + (s;alt (s;this! (' <)) + (s;this! (' >)))) (def: (generic-type^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax GenericType)) ($_ s;either (do s;Monad - [_ (s;sample! (' ?))] + [_ (s;this! (' ?))] (wrap (#GenericWildcard #;None))) (s;tuple (do s;Monad - [_ (s;sample! (' ?)) + [_ (s;this! (' ?)) bound-kind bound-kind^ bound (generic-type^ imports type-vars)] (wrap (#GenericWildcard (#;Some [bound-kind bound]))))) @@ -731,7 +731,7 @@ ## else (wrap (#GenericClass name (list)))))) (s;form (do s;Monad - [name (s;sample! (' Array)) + [name (s;this! (' Array)) component (generic-type^ imports type-vars)] (case component (^template [ ] @@ -763,7 +763,7 @@ (wrap [param-name (list)])) (s;tuple (do s;Monad [param-name s;local-symbol - _ (s;sample! (' <)) + _ (s;this! (' <)) bounds (s;many (generic-type^ imports (list)))] (wrap [param-name bounds]))))) @@ -807,7 +807,7 @@ (def: (annotations^' imports) (-> ClassImports (Syntax (List Annotation))) (do s;Monad - [_ (s;sample! (' #ann))] + [_ (s;this! (' #ann))] (s;tuple (s;some (annotation^ imports))))) (def: (annotations^ imports) @@ -819,7 +819,7 @@ (def: (throws-decl'^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax (List GenericType))) (do s;Monad - [_ (s;sample! (' #throws))] + [_ (s;this! (' #throws))] (s;tuple (s;some (generic-type^ imports type-vars))))) (def: (throws-decl^ imports type-vars) @@ -845,14 +845,14 @@ (def: state-modifier^ (Syntax StateModifier) ($_ s;alt - (s;sample! (' #volatile)) - (s;sample! (' #final)) + (s;this! (' #volatile)) + (s;this! (' #final)) (:: s;Monad wrap []))) (def: (field-decl^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax [MemberDecl FieldDecl])) (s;either (s;form (do s;Monad - [_ (s;sample! (' #const)) + [_ (s;this! (' #const)) name s;local-symbol anns (annotations^ imports) type (generic-type^ imports type-vars) @@ -887,10 +887,10 @@ (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) (s;form (do s;Monad [pm privacy-modifier^ - strict-fp? (s;sample? (' #strict)) + strict-fp? (s;this? (' #strict)) method-vars (s;default (list) (type-params^ imports)) #let [total-vars (List/append class-vars method-vars)] - [_ arg-decls] (s;form (s;seq (s;sample! (' new)) + [_ arg-decls] (s;form (s;seq (s;this! (' new)) (arg-decls^ imports total-vars))) constructor-args (constructor-args^ imports total-vars) exs (throws-decl^ imports total-vars) @@ -905,8 +905,8 @@ (-> ClassImports (List TypeParam) (Syntax [MemberDecl MethodDef])) (s;form (do s;Monad [pm privacy-modifier^ - strict-fp? (s;sample? (' #strict)) - final? (s;sample? (' #final)) + strict-fp? (s;this? (' #strict)) + final? (s;this? (' #final)) method-vars (s;default (list) (type-params^ imports)) #let [total-vars (List/append class-vars method-vars)] [name arg-decls] (s;form (s;seq s;local-symbol @@ -923,7 +923,7 @@ (def: (overriden-method-def^ imports) (-> ClassImports (Syntax [MemberDecl MethodDef])) (s;form (do s;Monad - [strict-fp? (s;sample? (' #strict)) + [strict-fp? (s;this? (' #strict)) owner-class (class-decl^ imports) method-vars (s;default (list) (type-params^ imports)) #let [total-vars (List/append (product;right owner-class) method-vars)] @@ -942,8 +942,8 @@ (-> ClassImports (Syntax [MemberDecl MethodDef])) (s;form (do s;Monad [pm privacy-modifier^ - strict-fp? (s;sample? (' #strict)) - _ (s;sample! (' #static)) + strict-fp? (s;this? (' #strict)) + _ (s;this! (' #static)) method-vars (s;default (list) (type-params^ imports)) #let [total-vars method-vars] [name arg-decls] (s;form (s;seq s;local-symbol @@ -961,7 +961,7 @@ (-> ClassImports (Syntax [MemberDecl MethodDef])) (s;form (do s;Monad [pm privacy-modifier^ - _ (s;sample! (' #abstract)) + _ (s;this! (' #abstract)) method-vars (s;default (list) (type-params^ imports)) #let [total-vars method-vars] [name arg-decls] (s;form (s;seq s;local-symbol @@ -978,7 +978,7 @@ (-> ClassImports (Syntax [MemberDecl MethodDef])) (s;form (do s;Monad [pm privacy-modifier^ - _ (s;sample! (' #native)) + _ (s;this! (' #native)) method-vars (s;default (list) (type-params^ imports)) #let [total-vars method-vars] [name arg-decls] (s;form (s;seq s;local-symbol @@ -1008,42 +1008,42 @@ (def: class-kind^ (Syntax ClassKind) (s;either (do s;Monad - [_ (s;sample! (' #class))] + [_ (s;this! (' #class))] (wrap #Class)) (do s;Monad - [_ (s;sample! (' #interface))] + [_ (s;this! (' #interface))] (wrap #Interface)) )) (def: import-member-alias^ (Syntax (Maybe Text)) (s;opt (do s;Monad - [_ (s;sample! (' #as))] + [_ (s;this! (' #as))] s;local-symbol))) (def: (import-member-args^ imports type-vars) (-> ClassImports (List TypeParam) (Syntax (List [Bool GenericType]))) - (s;tuple (s;some (s;seq (s;sample? (' #?)) (generic-type^ imports type-vars))))) + (s;tuple (s;some (s;seq (s;this? (' #?)) (generic-type^ imports type-vars))))) (def: import-member-return-flags^ (Syntax [Bool Bool Bool]) - ($_ s;seq (s;sample? (' #io)) (s;sample? (' #try)) (s;sample? (' #?)))) + ($_ s;seq (s;this? (' #io)) (s;this? (' #try)) (s;this? (' #?)))) (def: primitive-mode^ (Syntax Primitive-Mode) - (s;alt (s;sample! (' #manual)) - (s;sample! (' #auto)))) + (s;alt (s;this! (' #manual)) + (s;this! (' #auto)))) (def: (import-member-decl^ imports owner-vars) (-> ClassImports (List TypeParam) (Syntax ImportMemberDecl)) ($_ s;either (s;form (do s;Monad - [_ (s;sample! (' #enum)) + [_ (s;this! (' #enum)) enum-members (s;some s;local-symbol)] (wrap (#EnumDecl enum-members)))) (s;form (do s;Monad [tvars (s;default (list) (type-params^ imports)) - _ (s;sample! (' new)) + _ (s;this! (' new)) ?alias import-member-alias^ #let [total-vars (List/append owner-vars tvars)] ?prim-mode (s;opt primitive-mode^) @@ -1061,7 +1061,7 @@ )) (s;form (do s;Monad [kind (: (Syntax ImportMethodKind) - (s;alt (s;sample! (' #static)) + (s;alt (s;this! (' #static)) (wrap []))) tvars (s;default (list) (type-params^ imports)) name s;local-symbol @@ -1083,12 +1083,12 @@ #import-method-return return }])))) (s;form (do s;Monad - [static? (s;sample? (' #static)) + [static? (s;this? (' #static)) name s;local-symbol ?prim-mode (s;opt primitive-mode^) gtype (generic-type^ imports owner-vars) - maybe? (s;sample? (' #?)) - setter? (s;sample? (' #!))] + maybe? (s;this? (' #?)) + setter? (s;this? (' #!))] (wrap (#FieldAccessDecl {#import-field-mode (default #AutoPrM ?prim-mode) #import-field-name name #import-field-static? static? @@ -1251,7 +1251,7 @@ (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs) (let [super-replacer (parser->replacer (s;form (do s;Monad - [_ (s;sample! (' .super!)) + [_ (s;this! (' .super!)) args (s;tuple (s;exactly (list;size arg-decls) s;any)) #let [arg-decls' (: (List Text) (map (. (simple-class$ (list)) product;right) arg-decls))]] @@ -1944,7 +1944,7 @@ (compiler;fail (format "Unknown class: " class-name)))) (syntax: #export (jvm-import [#let [imports (class-imports *compiler*)]] - [long-name? (s;sample? (' #long))] + [long-name? (s;this? (' #long))] [class-decl (class-decl^ imports)] [#let [full-class-name (product;left class-decl) imports (add-import [(short-class-name full-class-name) full-class-name] diff --git a/stdlib/source/lux/io.lux b/stdlib/source/lux/io.lux new file mode 100644 index 000000000..e395e7c32 --- /dev/null +++ b/stdlib/source/lux/io.lux @@ -0,0 +1,57 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: {#;doc "A method for abstracting I/O and effectful computations to make it safe while writing pure functional code."} + lux + (lux (control functor + applicative + monad) + (data (coll list)))) + +## [Types] +(type: #export (IO a) + {#;doc "A type that represents synchronous, effectful computations that may interact with the outside world."} + (-> Void a)) + +## [Syntax] +(macro: #export (io tokens state) + {#;doc (doc "Delays the evaluation of an expression, by wrapping it in an IO 'thunk'." + "Great for wrapping effectful computations (which won't be performed until the IO is \"run\")." + (io (exec + (log! msg) + "Some value...")))} + (case tokens + (^ (list value)) + (let [blank (: AST [["" -1 -1] (#;SymbolS ["" ""])])] + (#;Right [state (list (` (;_lux_lambda (~ blank) (~ blank) (~ value))))])) + + _ + (#;Left "Wrong syntax for io"))) + +## [Structures] +(struct: #export _ (Functor IO) + (def: (map f ma) + (io (f (ma (:! Void [])))))) + +(struct: #export _ (Applicative IO) + (def: functor Functor) + + (def: (wrap x) + (io x)) + + (def: (apply ff fa) + (io ((ff (:! Void [])) (fa (:! Void [])))))) + +(struct: #export _ (Monad IO) + (def: applicative Applicative) + + (def: (join mma) + (io ((mma (:! Void [])) (:! Void []))))) + +## [Functions] +(def: #export (run action) + {#;doc "A way to execute IO computations and perform their side-effects."} + (All [a] (-> (IO a) a)) + (action (:! Void []))) diff --git a/stdlib/source/lux/lexer.lux b/stdlib/source/lux/lexer.lux index ca8f7f5cf..03e5f5cbd 100644 --- a/stdlib/source/lux/lexer.lux +++ b/stdlib/source/lux/lexer.lux @@ -15,7 +15,7 @@ [char "Char/" Ord] maybe ["E" error #- fail] - (struct [list "" Functor])))) + (coll [list "" Functor])))) ## [Types] (type: #export (Lexer a) @@ -86,7 +86,7 @@ {#;doc "Just returns the next character without applying any logic."} (Lexer Char) (lambda [input] - (case [(text;at +0 input) (text;split +1 input)] + (case [(text;nth +0 input) (text;split +1 input)] [(#;Some output) (#;Some [_ input'])] (#E;Success [input' output]) @@ -276,7 +276,7 @@ {#;doc "Lex the next character (without consuming it from the input)."} (Lexer Char) (lambda [input] - (case (text;at +0 input) + (case (text;nth +0 input) (#;Some output) (#E;Success [input output]) @@ -288,7 +288,7 @@ {#;doc "Lex a character if it matches the given sample."} (-> Char (Lexer Char)) (lambda [input] - (case [(text;at +0 input) (text;split +1 input)] + (case [(text;nth +0 input) (text;split +1 input)] [(#;Some char') (#;Some [_ input'])] (if (Char/= test char') (#E;Success [input' test]) @@ -352,7 +352,7 @@ (case (text;split +1 input) (#;Some [init input']) (if (text;contains? init options) - (case (text;at +0 init) + (case (text;nth +0 init) (#;Some output) (#E;Success [input' output]) @@ -370,7 +370,7 @@ (case (text;split +1 input) (#;Some [init input']) (if (;not (text;contains? init options)) - (case (text;at +0 init) + (case (text;nth +0 init) (#;Some output) (#E;Success [input' output]) @@ -388,7 +388,7 @@ (case (: (Maybe [Text Char]) (do Monad [[init input'] (text;split +1 input) - output (text;at +0 init)] + output (text;nth +0 init)] (wrap [input' output]))) (#;Some [input' output]) (if (p output) diff --git a/stdlib/source/lux/lexer/regex.lux b/stdlib/source/lux/lexer/regex.lux index 5684a4465..503364ce0 100644 --- a/stdlib/source/lux/lexer/regex.lux +++ b/stdlib/source/lux/lexer/regex.lux @@ -11,7 +11,7 @@ text/format [number "Int/" Codec] [product] - (struct [list "" Fold "List/" Monad])) + (coll [list "" Fold "List/" Monad])) [compiler #- run] (macro [ast] [syntax #+ syntax:]) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index b06deedb7..54d41b28f 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -6,14 +6,14 @@ (;module: lux (lux (control monad) - (data (struct [list "List/" Monad]) + (data (coll [list "List/" Monad]) text/format) [compiler] (macro ["s" syntax #+ syntax: Syntax]))) (def: omit^ (Syntax Bool) - (s;sample? (' #omit))) + (s;this? (' #omit))) (do-template [ ] [(syntax: #export ( [? omit^] token) diff --git a/stdlib/source/lux/macro/ast.lux b/stdlib/source/lux/macro/ast.lux index 821264c09..d284a8043 100644 --- a/stdlib/source/lux/macro/ast.lux +++ b/stdlib/source/lux/macro/ast.lux @@ -11,7 +11,7 @@ [char] [text #+ Eq "Text/" Monoid] ident - (struct [list #* "" Functor Fold]) + (coll [list #* "" Functor Fold]) ))) ## [Types] diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index d194a540b..5420e0328 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -9,8 +9,8 @@ [eq]) (data [text] text/format - (struct [list "List/" Fold Monad] - [dict #+ Dict]) + (coll [list "List/" Fold Monad] + [dict #+ Dict]) [number] [product] [bool] diff --git a/stdlib/source/lux/macro/poly/eq.lux b/stdlib/source/lux/macro/poly/eq.lux index bdce71d50..a9d7c0fae 100644 --- a/stdlib/source/lux/macro/poly/eq.lux +++ b/stdlib/source/lux/macro/poly/eq.lux @@ -9,8 +9,8 @@ [eq]) (data [text] text/format - (struct [list "List/" Monad] - [dict #+ Dict]) + (coll [list "List/" Monad] + [dict #+ Dict]) [number] [product] [bool] diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux index e659bb41d..ec06193bf 100644 --- a/stdlib/source/lux/macro/poly/functor.lux +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -9,8 +9,8 @@ [functor]) (data [text] text/format - (struct [list "List/" Monad] - [dict #+ Dict]) + (coll [list "List/" Monad] + [dict #+ Dict]) [number] [product] [bool] diff --git a/stdlib/source/lux/macro/poly/text-encoder.lux b/stdlib/source/lux/macro/poly/text-encoder.lux index c538844a7..c197f8e0c 100644 --- a/stdlib/source/lux/macro/poly/text-encoder.lux +++ b/stdlib/source/lux/macro/poly/text-encoder.lux @@ -9,8 +9,8 @@ [codec]) (data [text] text/format - (struct [list "List/" Monad] - [dict #+ Dict]) + (coll [list "List/" Monad] + [dict #+ Dict]) [number] [product] [bool] diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index ba24b607b..2713de9c1 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -15,7 +15,7 @@ [number] [text "Text/" Monoid] [ident] - (struct [list #* "" Functor Fold "List/" Monoid]) + (coll [list #* "" Functor Fold "List/" Monoid]) [product] [error #- fail])) (.. [ast "AST/" Eq])) @@ -113,7 +113,7 @@ [ tag Ident #;TagS ident;Eq "tag"] ) -(def: #export (sample? ast) +(def: #export (this? ast) {#;doc "Asks if the given AST is the next input."} (-> AST (Syntax Bool)) (lambda [tokens] @@ -128,7 +128,7 @@ _ (#;Right [tokens false])))) -(def: #export (sample! ast) +(def: #export (this! ast) {#;doc "Ensures the given AST is the next input."} (-> AST (Syntax Unit)) (lambda [tokens] diff --git a/stdlib/source/lux/macro/syntax/common.lux b/stdlib/source/lux/macro/syntax/common.lux index 96203b4c2..3ebb716c6 100644 --- a/stdlib/source/lux/macro/syntax/common.lux +++ b/stdlib/source/lux/macro/syntax/common.lux @@ -8,7 +8,7 @@ The goal is to be able to reuse common syntax in macro definitions across libraries."} lux (lux (control monad) - (data (struct [list]) + (data (coll [list]) text/format [ident "Ident/" Eq] [product]) @@ -27,8 +27,8 @@ #export #hidden)} (Syntax (Maybe Export-Level)) - (s;opt (s;alt (s;sample! (' #export)) - (s;sample! (' #hidden))))) + (s;opt (s;alt (s;this! (' #export)) + (s;this! (' #hidden))))) (def: #export (gen-export-level ?el) (-> (Maybe Export-Level) (List AST)) @@ -70,7 +70,7 @@ (def: check^ (Syntax [(Maybe AST) AST]) (s;either (s;form (do s;Monad - [_ (s;sample! (' lux;_lux_:)) + [_ (s;this! (' lux;_lux_:)) type s;any value s;any] (wrap [(#;Some type) value]))) @@ -83,9 +83,9 @@ (def: (_def-anns^ _) (-> Top (Syntax (List [Ident AST]))) - (s;alt (s;sample! (' #lux;Nil)) + (s;alt (s;this! (' #lux;Nil)) (s;form (do s;Monad - [_ (s;sample! (' #lux;Cons)) + [_ (s;this! (' #lux;Cons)) [head tail] (s;seq (s;tuple (s;seq _def-anns-tag^ s;any)) (_def-anns^ []))] (wrap [head tail]))) @@ -94,10 +94,10 @@ (def: (flat-list^ _) (-> Top (Syntax (List AST))) (s;either (do s;Monad - [_ (s;sample! (' #lux;Nil))] + [_ (s;this! (' #lux;Nil))] (wrap (list))) (s;form (do s;Monad - [_ (s;sample! (' #lux;Cons)) + [_ (s;this! (' #lux;Cons)) [head tail] (s;tuple (s;seq s;any s;any)) tail (s;local (list tail) (flat-list^ []))] (wrap (#;Cons head tail)))))) @@ -105,13 +105,13 @@ (def: list-meta^ (Syntax (List AST)) (s;form (do s;Monad - [_ (s;sample! (' #lux;ListA))] + [_ (s;this! (' #lux;ListA))] (flat-list^ [])))) (def: text-meta^ (Syntax Text) (s;form (do s;Monad - [_ (s;sample! (' #lux;TextA))] + [_ (s;this! (' #lux;TextA))] s;text))) (def: (find-def-args meta-data) @@ -138,7 +138,7 @@ (compiler;macro-expand-all def-raw))] (s;local me-def-raw (s;form (do @ - [_ (s;sample! (' lux;_lux_def)) + [_ (s;this! (' lux;_lux_def)) def-name s;local-symbol [?def-type def-value] check^ def-anns s;any diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index d5a03b421..1fdde77e6 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -6,7 +6,7 @@ (;module: {#;doc "Common mathematical constants and functions."} lux (lux (control monad) - (data (struct [list "" Fold]) + (data (coll [list "" Fold]) [number "Int/" Number] [product] text/format) @@ -122,7 +122,7 @@ (s/map ast;tag s;tag)) (s;form (s;many s;any)) (s;tuple (s;either (do s;Monad - [_ (s;sample! (' #and)) + [_ (s;this! (' #and)) init-subject (infix^ []) init-op s;any init-param (infix^ []) diff --git a/stdlib/source/lux/math/complex.lux b/stdlib/source/lux/math/complex.lux index 9666abdab..ef91715ad 100644 --- a/stdlib/source/lux/math/complex.lux +++ b/stdlib/source/lux/math/complex.lux @@ -16,7 +16,7 @@ text/format error maybe - (struct [list "List/" Monad])) + (coll [list "List/" Monad])) [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/math/simple.lux b/stdlib/source/lux/math/simple.lux index f8b059794..45ba0a4a4 100644 --- a/stdlib/source/lux/math/simple.lux +++ b/stdlib/source/lux/math/simple.lux @@ -8,7 +8,7 @@ (lux (control monad) (data text/format [product] - (struct [list])) + (coll [list])) [compiler] (macro [ast] ["s" syntax #+ syntax: Syntax]) diff --git a/stdlib/source/lux/pipe.lux b/stdlib/source/lux/pipe.lux index 12337e3ef..2008971c4 100644 --- a/stdlib/source/lux/pipe.lux +++ b/stdlib/source/lux/pipe.lux @@ -6,7 +6,7 @@ (;module: {#;doc "Composable extensions to the piping macro |> that enhance it with various abilities."} lux (lux (control monad) - (data (struct [list #+ Monad "" Fold "List/" Monad]) + (data (coll [list #+ Monad "" Fold "List/" Monad]) maybe) [compiler #+ with-gensyms Monad] (macro ["s" syntax #+ syntax: Syntax] diff --git a/stdlib/source/lux/random.lux b/stdlib/source/lux/random.lux index 195255643..468b6a34b 100644 --- a/stdlib/source/lux/random.lux +++ b/stdlib/source/lux/random.lux @@ -15,13 +15,13 @@ text/format [product] [number] - (struct [list "List/" Fold] - ["A" array] - ["D" dict] - ["Q" queue] - ["S" set] - ["ST" stack] - ["V" vector])) + (coll [list "List/" Fold] + ["A" array] + ["D" dict] + ["Q" queue] + ["S" set] + ["ST" stack] + ["V" vector])) (math ["r" ratio] ["c" complex]))) @@ -288,7 +288,7 @@ (def: (swap from to vec) (All [a] (-> Nat Nat (V;Vector a) (V;Vector a))) (V;put to (default (undefined) - (V;at from vec)) + (V;nth from vec)) vec)) (def: #export (shuffle seed vector) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index 9524a2168..3b582815e 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -12,12 +12,12 @@ applicative monad) (concurrency [promise #+ Promise Monad]) - (data (struct [list "List/" Monad Fold]) + (data (coll [list "List/" Monad Fold]) [product] [text] text/format [error #- fail "Error/" Monad]) - (codata [io #- run]) + [io #- run] ["R" random] [host #- try])) @@ -136,10 +136,10 @@ (def: config^ (Syntax Test-Config) (s;alt (do s;Monad - [_ (s;sample! (' #seed))] + [_ (s;this! (' #seed))] s;nat) (do s;Monad - [_ (s;sample! (' #times))] + [_ (s;this! (' #times))] s;nat))) (def: property-test^ diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index cda44670b..7610773b1 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -11,7 +11,7 @@ [ident "Ident/" Eq] [number "Nat/" Codec] maybe - (struct [list #+ "List/" Monad Monoid Fold])) + (coll [list #+ "List/" Monad Monoid Fold])) (macro [ast]) )) @@ -41,7 +41,7 @@ (#;BoundT idx) (default (error! (Text/append "Unknown type var: " (Nat/encode idx))) - (list;at idx env)) + (list;nth idx env)) _ type diff --git a/stdlib/source/lux/type/auto.lux b/stdlib/source/lux/type/auto.lux index 2266827c9..28ba34090 100644 --- a/stdlib/source/lux/type/auto.lux +++ b/stdlib/source/lux/type/auto.lux @@ -10,8 +10,8 @@ (data [text "Text/" Eq] text/format [number] - (struct [list "List/" Monad Fold] - [dict]) + (coll [list "List/" Monad Fold] + [dict]) [bool] [product]) [compiler #+ Monad] diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux index 25cf19834..78461f7d7 100644 --- a/stdlib/source/lux/type/check.lux +++ b/stdlib/source/lux/type/check.lux @@ -15,8 +15,8 @@ [number] maybe [product] - (struct [list] - [dict]) + (coll [list] + [dict]) [error #- fail]) [type "Type/" Eq] )) diff --git a/stdlib/test/test/lux.lux b/stdlib/test/test/lux.lux index cd394ac76..947676665 100644 --- a/stdlib/test/test/lux.lux +++ b/stdlib/test/test/lux.lux @@ -7,7 +7,7 @@ lux lux/test (lux (control monad) - (codata [io]) + [io] [math] ["R" random] (data [text "T/" Eq] diff --git a/stdlib/test/test/lux/cli.lux b/stdlib/test/test/lux/cli.lux index 2aab87ae4..35b342000 100644 --- a/stdlib/test/test/lux/cli.lux +++ b/stdlib/test/test/lux/cli.lux @@ -5,14 +5,14 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data text/format [text "Text/" Eq] [number] [product] [sum] - (struct [list])) + (coll [list])) (codata function) ["&" cli] ["R" random] diff --git a/stdlib/test/test/lux/codata/coll/stream.lux b/stdlib/test/test/lux/codata/coll/stream.lux new file mode 100644 index 000000000..9dc10c07f --- /dev/null +++ b/stdlib/test/test/lux/codata/coll/stream.lux @@ -0,0 +1,106 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io] + (control monad + comonad) + (data [text "Text/" Monoid] + text/format + (coll [list]) + [number "Nat/" Codec]) + (codata function + [cont] + (coll ["&" stream])) + ["R" random] + pipe) + lux/test) + +(test: "Streams" + [size (|> R;nat (:: @ map (|>. (n.% +100) (n.max +2)))) + offset (|> R;nat (:: @ map (n.% +100))) + factor (|> R;nat (:: @ map (|>. (n.% +100) (n.max +2)))) + elem R;nat + cycle-seed (R;list size R;nat) + cycle-sample-idx (|> R;nat (:: @ map (n.% +1000))) + #let [(^open "List/") (list;Eq number;Eq) + sample0 (&;iterate n.inc +0) + sample1 (&;iterate n.inc offset)]] + ($_ seq + (assert "Can move along a stream and take slices off it." + (and (and (List/= (list;n.range +0 (n.dec size)) + (&;take size sample0)) + (List/= (list;n.range offset (n.dec (n.+ offset size))) + (&;take size (&;drop offset sample0))) + (let [[drops takes...] (&;split size sample0)] + (and (List/= (list;n.range +0 (n.dec size)) + drops) + (List/= (list;n.range size (n.dec (n.* +2 size))) + (&;take size takes...))))) + (and (List/= (list;n.range +0 (n.dec size)) + (&;take-while (n.< size) sample0)) + (List/= (list;n.range offset (n.dec (n.+ offset size))) + (&;take-while (n.< (n.+ offset size)) + (&;drop-while (n.< offset) sample0))) + (let [[drops takes...] (&;split-while (n.< size) sample0)] + (and (List/= (list;n.range +0 (n.dec size)) + drops) + (List/= (list;n.range size (n.dec (n.* +2 size))) + (&;take-while (n.< (n.* +2 size)) takes...))))) + )) + + (assert "Can repeat any element and infinite number of times." + (n.= elem (&;nth offset (&;repeat elem)))) + + (assert "Can obtain the head & tail of a stream." + (and (n.= offset (&;head sample1)) + (List/= (list;n.range (n.inc offset) (n.+ offset size)) + (&;take size (&;tail sample1))))) + + (assert "Can filter streams." + (and (n.= (n.* +2 offset) + (&;nth offset + (&;filter n.even? sample0))) + (let [[evens odds] (&;partition n.even? (&;iterate n.inc +0))] + (and (n.= (n.* +2 offset) + (&;nth offset evens)) + (n.= (n.inc (n.* +2 offset)) + (&;nth offset odds)))))) + + (assert "Functor goes over 'all' elements in a stream." + (let [(^open "&/") &;Functor + there (&/map (n.* factor) sample0) + back-again (&/map (n./ factor) there)] + (and (not (List/= (&;take size sample0) + (&;take size there))) + (List/= (&;take size sample0) + (&;take size back-again))))) + + (assert "CoMonad produces a value for every element in a stream." + (let [(^open "&/") &;Functor] + (List/= (&;take size (&/map (n.* factor) sample1)) + (&;take size + (be &;CoMonad + [inputs sample1] + (n.* factor (&;head inputs))))))) + + (assert "'unfold' generalizes 'iterate'." + (let [(^open "&/") &;Functor + (^open "List/") (list;Eq text;Eq)] + (List/= (&;take size + (&/map Nat/encode (&;iterate n.inc offset))) + (&;take size + (&;unfold (lambda [n] [(n.inc n) (Nat/encode n)]) + offset))))) + + (assert "Can cycle over the same elements as an infinite stream." + (|> (&;cycle cycle-seed) + (default (undefined)) + (&;nth cycle-sample-idx) + (n.= (default (undefined) + (list;nth (n.% size cycle-sample-idx) + cycle-seed))))) + )) diff --git a/stdlib/test/test/lux/codata/cont.lux b/stdlib/test/test/lux/codata/cont.lux index 39fdd6f42..b0e906248 100644 --- a/stdlib/test/test/lux/codata/cont.lux +++ b/stdlib/test/test/lux/codata/cont.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [text "Text/" Monoid] text/format diff --git a/stdlib/test/test/lux/codata/env.lux b/stdlib/test/test/lux/codata/env.lux index 4f5a37de9..2acad142f 100644 --- a/stdlib/test/test/lux/codata/env.lux +++ b/stdlib/test/test/lux/codata/env.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [text "Text/" Monoid] text/format diff --git a/stdlib/test/test/lux/codata/io.lux b/stdlib/test/test/lux/codata/io.lux deleted file mode 100644 index 7965869d0..000000000 --- a/stdlib/test/test/lux/codata/io.lux +++ /dev/null @@ -1,27 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control monad) - (data [text "Text/" Monoid Eq] - text/format - [number]) - (codata function - ["&" io])) - lux/test) - -(test: "I/O" - ($_ seq - (assert "" (Text/= "YOLO" (&;run (&;io "YOLO")))) - (assert "" (i.= 11 (&;run (:: &;Functor map i.inc (&;io 10))))) - (assert "" (i.= 10 (&;run (:: &;Applicative wrap 10)))) - (assert "" (i.= 30 (&;run (let [(^open "&/") &;Applicative] - (&/apply (&/wrap (i.+ 10)) (&/wrap 20)))))) - (assert "" (i.= 30 (&;run (do &;Monad - [f (wrap i.+) - x (wrap 10) - y (wrap 20)] - (wrap (f x y)))))))) diff --git a/stdlib/test/test/lux/codata/state.lux b/stdlib/test/test/lux/codata/state.lux index 79a458cc0..d73ebaa58 100644 --- a/stdlib/test/test/lux/codata/state.lux +++ b/stdlib/test/test/lux/codata/state.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [text "Text/" Monoid] text/format diff --git a/stdlib/test/test/lux/codata/struct/stream.lux b/stdlib/test/test/lux/codata/struct/stream.lux deleted file mode 100644 index 41132b2ee..000000000 --- a/stdlib/test/test/lux/codata/struct/stream.lux +++ /dev/null @@ -1,106 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io]) - (control monad - comonad) - (data [text "Text/" Monoid] - text/format - (struct [list]) - [number "Nat/" Codec]) - (codata function - [cont] - (struct ["&" stream])) - ["R" random] - pipe) - lux/test) - -(test: "Streams" - [size (|> R;nat (:: @ map (|>. (n.% +100) (n.max +2)))) - offset (|> R;nat (:: @ map (n.% +100))) - factor (|> R;nat (:: @ map (|>. (n.% +100) (n.max +2)))) - elem R;nat - cycle-seed (R;list size R;nat) - cycle-sample-idx (|> R;nat (:: @ map (n.% +1000))) - #let [(^open "List/") (list;Eq number;Eq) - sample0 (&;iterate n.inc +0) - sample1 (&;iterate n.inc offset)]] - ($_ seq - (assert "Can move along a stream and take slices off it." - (and (and (List/= (list;n.range +0 (n.dec size)) - (&;take size sample0)) - (List/= (list;n.range offset (n.dec (n.+ offset size))) - (&;take size (&;drop offset sample0))) - (let [[drops takes...] (&;split size sample0)] - (and (List/= (list;n.range +0 (n.dec size)) - drops) - (List/= (list;n.range size (n.dec (n.* +2 size))) - (&;take size takes...))))) - (and (List/= (list;n.range +0 (n.dec size)) - (&;take-while (n.< size) sample0)) - (List/= (list;n.range offset (n.dec (n.+ offset size))) - (&;take-while (n.< (n.+ offset size)) - (&;drop-while (n.< offset) sample0))) - (let [[drops takes...] (&;split-while (n.< size) sample0)] - (and (List/= (list;n.range +0 (n.dec size)) - drops) - (List/= (list;n.range size (n.dec (n.* +2 size))) - (&;take-while (n.< (n.* +2 size)) takes...))))) - )) - - (assert "Can repeat any element and infinite number of times." - (n.= elem (&;at offset (&;repeat elem)))) - - (assert "Can obtain the head & tail of a stream." - (and (n.= offset (&;head sample1)) - (List/= (list;n.range (n.inc offset) (n.+ offset size)) - (&;take size (&;tail sample1))))) - - (assert "Can filter streams." - (and (n.= (n.* +2 offset) - (&;at offset - (&;filter n.even? sample0))) - (let [[evens odds] (&;partition n.even? (&;iterate n.inc +0))] - (and (n.= (n.* +2 offset) - (&;at offset evens)) - (n.= (n.inc (n.* +2 offset)) - (&;at offset odds)))))) - - (assert "Functor goes over 'all' elements in a stream." - (let [(^open "&/") &;Functor - there (&/map (n.* factor) sample0) - back-again (&/map (n./ factor) there)] - (and (not (List/= (&;take size sample0) - (&;take size there))) - (List/= (&;take size sample0) - (&;take size back-again))))) - - (assert "CoMonad produces a value for every element in a stream." - (let [(^open "&/") &;Functor] - (List/= (&;take size (&/map (n.* factor) sample1)) - (&;take size - (be &;CoMonad - [inputs sample1] - (n.* factor (&;head inputs))))))) - - (assert "'unfold' generalizes 'iterate'." - (let [(^open "&/") &;Functor - (^open "List/") (list;Eq text;Eq)] - (List/= (&;take size - (&/map Nat/encode (&;iterate n.inc offset))) - (&;take size - (&;unfold (lambda [n] [(n.inc n) (Nat/encode n)]) - offset))))) - - (assert "Can cycle over the same elements as an infinite stream." - (|> (&;cycle cycle-seed) - (default (undefined)) - (&;at cycle-sample-idx) - (n.= (default (undefined) - (list;at (n.% size cycle-sample-idx) - cycle-seed))))) - )) diff --git a/stdlib/test/test/lux/concurrency/actor.lux b/stdlib/test/test/lux/concurrency/actor.lux index 7136ab30d..5ae191512 100644 --- a/stdlib/test/test/lux/concurrency/actor.lux +++ b/stdlib/test/test/lux/concurrency/actor.lux @@ -5,14 +5,14 @@ (;module: lux - (lux (control monad) + (lux [io #- run] + (control monad) (data [number] text/format [error #- fail]) (concurrency [promise #+ Promise Monad "Promise/" Monad] ["&" actor #+ actor:]) - (codata function - [io #- run])) + (codata function)) lux/test) (actor: Adder diff --git a/stdlib/test/test/lux/concurrency/atom.lux b/stdlib/test/test/lux/concurrency/atom.lux index 312bc0369..a2ef82562 100644 --- a/stdlib/test/test/lux/concurrency/atom.lux +++ b/stdlib/test/test/lux/concurrency/atom.lux @@ -5,10 +5,10 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [number] - (struct [list "" Functor]) + (coll [list "" Functor]) text/format) (concurrency ["&" atom]) ["R" random] diff --git a/stdlib/test/test/lux/concurrency/frp.lux b/stdlib/test/test/lux/concurrency/frp.lux index 6bec2ea37..2d0b75f95 100644 --- a/stdlib/test/test/lux/concurrency/frp.lux +++ b/stdlib/test/test/lux/concurrency/frp.lux @@ -5,14 +5,14 @@ (;module: lux - (lux (control monad) + (lux [io #- run] + (control monad) (data [number] text/format [error #- fail]) (concurrency [promise #+ Promise Monad "Promise/" Monad] ["&" frp]) - (codata function - [io #- run])) + (codata function)) lux/test) (def: (List->Chan values) diff --git a/stdlib/test/test/lux/concurrency/promise.lux b/stdlib/test/test/lux/concurrency/promise.lux index 53accdfcc..c217fccf9 100644 --- a/stdlib/test/test/lux/concurrency/promise.lux +++ b/stdlib/test/test/lux/concurrency/promise.lux @@ -5,13 +5,13 @@ (;module: lux - (lux (control monad) + (lux [io #- run] + (control monad) (data [number] text/format [error #- fail]) (concurrency ["&" promise]) - (codata function - [io #- run]) + (codata function) ["R" random] pipe) lux/test) diff --git a/stdlib/test/test/lux/concurrency/stm.lux b/stdlib/test/test/lux/concurrency/stm.lux index 5b385c685..763804018 100644 --- a/stdlib/test/test/lux/concurrency/stm.lux +++ b/stdlib/test/test/lux/concurrency/stm.lux @@ -5,10 +5,10 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [number] - (struct [list "" Functor "List/" Fold]) + (coll [list "" Functor "List/" Fold]) text/format) (concurrency ["&" stm] [promise]) diff --git a/stdlib/test/test/lux/control/effect.lux b/stdlib/test/test/lux/control/effect.lux deleted file mode 100644 index be7eda3aa..000000000 --- a/stdlib/test/test/lux/control/effect.lux +++ /dev/null @@ -1,77 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io "IO/" Monad]) - (control monad - functor) - (data [text] - text/format) - [macro] - ["R" random] - pipe - (control effect)) - lux/test) - -(do-template [ ] - [(effect: - ( [Nat Text] Bool) - ( Nat))] - - [EffA opA fieldA] - [EffB opB fieldB] - [EffC opC fieldC] - ) - -(do-template [ ] - [(handler: _ - (=> [io;IO io;Monad]) - (def: ( size sample) - (IO/wrap ( size (text;size sample)))) - - (def: (IO/wrap )))] - - [EffA opA n.< fieldA +10] - [EffB opB n.= fieldB +20] - [EffC opC n.> fieldC +30] - ) - -(type: EffABC (|E EffA EffB EffC)) - -(def: Functor - (Functor EffABC) - (|F Functor Functor Functor)) - -(def: Handler - (Handler EffABC io;IO) - (|H io;Monad - Handler Handler Handler)) - -## [Tests] -(test: "Algebraic effects" - (let% [ (do-template [ ] - [(io;run (with-handler Handler - (doE Functor - [] - (lift ( "YOLO"))))) - (n.= (io;run (with-handler Handler - (doE Functor - [] - (lift )))))] - - [opA +10 fieldA +10] - [opB +4 fieldB +20] - [opC +2 fieldC +30])] - (assert "Can handle effects using handlers." - (and - - (n.= +60 (io;run (with-handler Handler - (doE Functor - [a (lift fieldA) - b (lift fieldB) - c (lift fieldC)] - (wrap ($_ n.+ a b c)))))) - )))) diff --git a/stdlib/test/test/lux/data/bit.lux b/stdlib/test/test/lux/data/bit.lux index 0b66b30f5..0da5cfd45 100644 --- a/stdlib/test/test/lux/data/bit.lux +++ b/stdlib/test/test/lux/data/bit.lux @@ -5,8 +5,8 @@ (;module: lux - (lux (control [monad]) - (codata [io]) + (lux [io] + (control [monad]) (data ["&" bit] number) ["R" random]) diff --git a/stdlib/test/test/lux/data/bool.lux b/stdlib/test/test/lux/data/bool.lux index 4c196546c..669232f47 100644 --- a/stdlib/test/test/lux/data/bool.lux +++ b/stdlib/test/test/lux/data/bool.lux @@ -6,7 +6,7 @@ (;module: lux (lux (control [monad]) - (codata [io]) + [io] (data bool) ["R" random]) lux/test) diff --git a/stdlib/test/test/lux/data/char.lux b/stdlib/test/test/lux/data/char.lux index 6482dd219..460e98b24 100644 --- a/stdlib/test/test/lux/data/char.lux +++ b/stdlib/test/test/lux/data/char.lux @@ -6,7 +6,7 @@ (;module: lux (lux (control [monad]) - (codata [io]) + [io] (data char [text] text/format) @@ -35,7 +35,7 @@ (#;Left _) false)) (|> value as-text - (text;at +0) (default (undefined)) + (text;nth +0) (default (undefined)) (:: Eq = value)))) (assert "Characters have an ordering relationship." diff --git a/stdlib/test/test/lux/data/coll/array.lux b/stdlib/test/test/lux/data/coll/array.lux new file mode 100644 index 000000000..236c2f915 --- /dev/null +++ b/stdlib/test/test/lux/data/coll/array.lux @@ -0,0 +1,135 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux (control [monad]) + [io] + (data (coll ["&" array] + [list]) + [number]) + ["R" random] + pipe) + lux/test) + +(def: bounded-size + (R;Random Nat) + (|> R;nat + (:: R;Monad map (|>. (n.% +100) (n.+ +1))))) + +(test: "Arrays and their copies" + [size bounded-size + original (R;array size R;nat) + #let [clone (&;clone original) + copy (: (&;Array Nat) + (&;new size)) + manual-copy (: (&;Array Nat) + (&;new size))]] + ($_ seq + (assert "Size function must correctly return size of array." + (n.= size (&;size original))) + (assert "Cloning an array should yield and identical array, but not the same one." + (and (:: (&;Eq number;Eq) = original clone) + (not (is original clone)))) + (assert "Full-range manual copies should give the same result as cloning." + (exec (&;copy size +0 original +0 copy) + (and (:: (&;Eq number;Eq) = original copy) + (not (is original copy))))) + (assert "Array folding should go over all values." + (exec (:: &;Fold fold + (lambda [x idx] + (exec (&;put idx x manual-copy) + (n.inc idx))) + +0 + original) + (:: (&;Eq number;Eq) = original manual-copy))) + (assert "Transformations between (full) arrays and lists shouldn't cause lose or change any values." + (|> original + &;to-list &;from-list + (:: (&;Eq number;Eq) = original))) + )) + +(test: "Array mutation" + [size bounded-size + idx (:: @ map (n.% size) R;nat) + array (|> (R;array size R;nat) + (R;filter (|>. &;to-list (list;any? n.odd?)))) + #let [value (default (undefined) + (&;get idx array))]] + ($_ seq + (assert "Shouldn't be able to find a value in an unoccupied cell." + (case (&;get idx (&;remove idx array)) + (#;Some _) false + #;None true)) + (assert "You should be able to access values put into the array." + (case (&;get idx (&;put idx value array)) + (#;Some value') (n.= value' value) + #;None false)) + (assert "All cells should be occupied on a full array." + (and (n.= size (&;occupied array)) + (n.= +0 (&;vacant array)))) + (assert "Filtering mutates the array to remove invalid values." + (exec (&;filter n.even? array) + (and (n.< size (&;occupied array)) + (n.> +0 (&;vacant array)) + (n.= size (n.+ (&;occupied array) + (&;vacant array)))))) + )) + +(test: "Finding values." + [size bounded-size + array (|> (R;array size R;nat) + (R;filter (|>. &;to-list (list;any? n.even?))))] + ($_ seq + (assert "Can find values inside arrays." + (|> (&;find n.even? array) + (case> (#;Some _) true + #;None false))) + (assert "Can find values inside arrays (with access to indices)." + (|> (&;find+ (lambda [idx n] + (and (n.even? n) + (n.< size idx))) + array) + (case> (#;Some _) true + #;None false))))) + +(test: "Functor" + [size bounded-size + array (R;array size R;nat)] + (let [(^open) &;Functor + (^open) (&;Eq number;Eq)] + ($_ seq + (assert "Functor shouldn't alter original array." + (let [copy (map id array)] + (and (= array copy) + (not (is array copy))))) + (assert "Functor should go over all available array elements." + (let [there (map n.inc array) + back-again (map n.dec there)] + (and (not (= array there)) + (= array back-again))))))) + +(test: "Monoid" + [sizeL bounded-size + sizeR bounded-size + left (R;array sizeL R;nat) + right (R;array sizeR R;nat) + #let [(^open) &;Monoid + (^open) (&;Eq number;Eq) + fusion (append left right)]] + ($_ seq + (assert "Appending two arrays should produce a new one twice as large." + (n.= (n.+ sizeL sizeR) (&;size fusion))) + (assert "First elements of fused array should equal the first array." + (|> (: (&;Array Nat) + (&;new sizeL)) + (&;copy sizeL +0 fusion +0) + (= left))) + (assert "Last elements of fused array should equal the second array." + (|> (: (&;Array Nat) + (&;new sizeR)) + (&;copy sizeR sizeL fusion +0) + (= right))) + )) diff --git a/stdlib/test/test/lux/data/coll/dict.lux b/stdlib/test/test/lux/data/coll/dict.lux new file mode 100644 index 000000000..38b8e83b4 --- /dev/null +++ b/stdlib/test/test/lux/data/coll/dict.lux @@ -0,0 +1,137 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io] + (control monad + [eq]) + (data [text "Text/" Monoid] + text/format + [number] + [char] + (coll ["&" dict] + [list "List/" Fold Functor])) + (codata function) + ["R" random] + pipe) + lux/test) + +(test: "Dictionaries." + [#let [capped-nat (:: R;Monad map (n.% +100) R;nat)] + size capped-nat + dict (R;dict char;Hash size R;char capped-nat) + non-key (|> R;char + (R;filter (lambda [key] (not (&;contains? key dict))))) + test-val (|> R;nat + (R;filter (lambda [val] (not (list;member? number;Eq (&;values dict) val)))))] + ($_ seq + (assert "Size function should correctly represent Dict size." + (n.= size (&;size dict))) + + (assert "Dicts of size 0 should be considered empty." + (if (n.= +0 size) + (&;empty? dict) + (not (&;empty? dict)))) + + (assert "The functions 'entries', 'keys' and 'values' should be synchronized." + (:: (list;Eq (eq;conj char;Eq number;Eq)) = + (&;entries dict) + (list;zip2 (&;keys dict) + (&;values dict)))) + + (assert "Dict should be able to recognize it's own keys." + (list;every? (lambda [key] (&;contains? key dict)) + (&;keys dict))) + + (assert "Should be able to get every key." + (list;every? (lambda [key] (case (&;get key dict) + (#;Some _) true + _ false)) + (&;keys dict))) + + (assert "Shouldn't be able to access non-existant keys." + (case (&;get non-key dict) + (#;Some _) false + _ true)) + + (assert "Should be able to put and then get a value." + (case (&;get non-key (&;put non-key test-val dict)) + (#;Some v) (n.= test-val v) + _ true)) + + (assert "Should be able to put~ and then get a value." + (case (&;get non-key (&;put~ non-key test-val dict)) + (#;Some v) (n.= test-val v) + _ true)) + + (assert "Shouldn't be able to put~ an existing key." + (or (n.= +0 size) + (let [first-key (|> dict &;keys list;head (default (undefined)))] + (case (&;get first-key (&;put~ first-key test-val dict)) + (#;Some v) (not (n.= test-val v)) + _ true)))) + + (assert "Removing a key should make it's value inaccessible." + (let [base (&;put non-key test-val dict)] + (and (&;contains? non-key base) + (not (&;contains? non-key (&;remove non-key base)))))) + + (assert "Should be possible to update values via their keys." + (let [base (&;put non-key test-val dict) + updt (&;update non-key n.inc base)] + (case [(&;get non-key base) (&;get non-key updt)] + [(#;Some x) (#;Some y)] + (n.= (n.inc x) y) + + _ + false))) + + (assert "Additions and removals to a Dict should affect its size." + (let [plus (&;put non-key test-val dict) + base (&;remove non-key plus)] + (and (n.= (n.inc (&;size dict)) (&;size plus)) + (n.= (n.dec (&;size plus)) (&;size base))))) + + (assert "A Dict should equal itself & going to<->from lists shouldn't change that." + (let [(^open) (&;Eq number;Eq)] + (and (= dict dict) + (|> dict &;entries (&;from-list char;Hash) (= dict))))) + + (assert "Merging a Dict to itself changes nothing." + (let [(^open) (&;Eq number;Eq)] + (= dict (&;merge dict dict)))) + + (assert "If you merge, and the second dict has overlapping keys, it should overwrite yours." + (let [dict' (|> dict &;entries + (List/map (lambda [[k v]] [k (n.inc v)])) + (&;from-list char;Hash)) + (^open) (&;Eq number;Eq)] + (= dict' (&;merge dict' dict)))) + + (assert "Can merge values in such a way that they become combined." + (list;every? (lambda [[x x*2]] (n.= (n.* +2 x) x*2)) + (list;zip2 (&;values dict) + (&;values (&;merge-with n.+ dict dict))))) + + (assert "Should be able to select subset of keys from dict." + (|> dict + (&;put non-key test-val) + (&;select (list non-key)) + &;size + (n.= +1))) + + (assert "Should be able to re-bind existing values to different keys." + (or (n.= +0 size) + (let [first-key (|> dict &;keys list;head (default (undefined))) + rebound (&;re-bind first-key non-key dict)] + (and (n.= (&;size dict) (&;size rebound)) + (&;contains? non-key rebound) + (not (&;contains? first-key rebound)) + (n.= (default (undefined) + (&;get first-key dict)) + (default (undefined) + (&;get non-key rebound))))))) + )) diff --git a/stdlib/test/test/lux/data/coll/list.lux b/stdlib/test/test/lux/data/coll/list.lux new file mode 100644 index 000000000..9df350b0b --- /dev/null +++ b/stdlib/test/test/lux/data/coll/list.lux @@ -0,0 +1,226 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io] + (control monad) + (data (coll ["&" list]) + [text "Text/" Monoid] + [number] + [bool] + [product]) + ["R" random] + pipe) + lux/test) + +(def: bounded-size + (R;Random Nat) + (|> R;nat + (:: R;Monad map (|>. (n.% +100) (n.+ +10))))) + +(test: "Lists: Part 1" + [size bounded-size + idx (:: @ map (n.% size) R;nat) + sample (R;list size R;nat) + other-size bounded-size + other-sample (R;list other-size R;nat) + separator R;nat + #let [(^open) (&;Eq number;Eq) + (^open "&/") &;Functor]] + ($_ seq + (assert "The size function should correctly portray the size of the list." + (n.= size (&;size sample))) + + (assert "The repeat function should produce as many elements as asked of it." + (n.= size (&;size (&;repeat size [])))) + + (assert "Reversing a list does not change it's size." + (n.= (&;size sample) + (&;size (&;reverse sample)))) + + (assert "Reversing a list twice results in the original list." + (= sample + (&;reverse (&;reverse sample)))) + + (assert "Filtering by a predicate and its complement should result in a number of elements equal to the original list." + (and (n.= (&;size sample) + (n.+ (&;size (&;filter n.even? sample)) + (&;size (&;filter (bool;complement n.even?) sample)))) + (let [[plus minus] (&;partition n.even? sample)] + (n.= (&;size sample) + (n.+ (&;size plus) + (&;size minus)))))) + + (assert "If every element in a list satisfies a predicate, there can't be any that satisfy its complement." + (if (&;every? n.even? sample) + (and (not (&;any? (bool;complement n.even?) sample)) + (&;empty? (&;filter (bool;complement n.even?) sample))) + (&;any? (bool;complement n.even?) sample))) + + (assert "Any element of the list can be considered it's member." + (let [elem (default (undefined) + (&;nth idx sample))] + (&;member? number;Eq sample elem))) + )) + +(test: "Lists: Part 2" + [size bounded-size + idx (:: @ map (n.% size) R;nat) + sample (R;list size R;nat) + other-size bounded-size + other-sample (R;list other-size R;nat) + separator R;nat + #let [(^open) (&;Eq number;Eq) + (^open "&/") &;Functor]] + ($_ seq + (assert "Appending the head and the tail should yield the original list." + (let [head (default (undefined) + (&;head sample)) + tail (default (undefined) + (&;tail sample))] + (= sample + (#;Cons head tail)))) + + (assert "Appending the inits and the last should yield the original list." + (let [(^open) &;Monoid + inits (default (undefined) + (&;inits sample)) + last (default (undefined) + (&;last sample))] + (= sample + (append inits (list last))))) + + (assert "Functor should go over every element of the list." + (let [(^open) &;Functor + there (map n.inc sample) + back-again (map n.dec there)] + (and (not (= sample there)) + (= sample back-again)))) + + (assert "Splitting a list into chunks and re-appending them should yield the original list." + (let [(^open) &;Monoid + [left right] (&;split idx sample) + [left' right'] (&;split-with n.even? sample)] + (and (= sample + (append left right)) + (= sample + (append left' right')) + (= sample + (append (&;take idx sample) + (&;drop idx sample))) + (= sample + (append (&;take-while n.even? sample) + (&;drop-while n.even? sample))) + ))) + + (assert "Segmenting the list in pairs should yield as many elements as N/2." + (n.= (n./ +2 size) + (&;size (&;as-pairs sample)))) + + (assert "Sorting a list shouldn't change it's size." + (n.= (&;size sample) + (&;size (&;sort n.< sample)))) + + (assert "Sorting a list with one order should yield the reverse of sorting it with the opposite order." + (= (&;sort n.< sample) + (&;reverse (&;sort n.> sample)))) + )) + +(test: "Lists: Part 3" + [size bounded-size + idx (:: @ map (n.% size) R;nat) + sample (R;list size R;nat) + other-size bounded-size + other-sample (R;list other-size R;nat) + separator R;nat + #let [(^open) (&;Eq number;Eq) + (^open "&/") &;Functor]] + ($_ seq + (assert "If you zip 2 lists, the result's size will be that of the smaller list." + (n.= (&;size (&;zip2 sample other-sample)) + (n.min (&;size sample) (&;size other-sample)))) + + (assert "I can pair-up elements of a list in order." + (let [(^open) &;Functor + zipped (&;zip2 sample other-sample) + num-zipper (&;size zipped)] + (and (|> zipped (map product;left) (= (&;take num-zipper sample))) + (|> zipped (map product;right) (= (&;take num-zipper other-sample)))))) + + (assert "You can generate indices for any size, and they will be in ascending order." + (let [(^open) &;Functor + indices (&;indices size)] + (and (n.= size (&;size indices)) + (= indices + (&;sort n.< indices)) + (&;every? (n.= (n.dec size)) + (&;zip2-with n.+ + indices + (&;sort n.> indices))) + ))) + + (assert "The 'interpose' function places a value between every member of a list." + (let [(^open) &;Functor + sample+ (&;interpose separator sample)] + (and (n.= (|> size (n.* +2) n.dec) + (&;size sample+)) + (|> sample+ &;as-pairs (map product;right) (&;every? (n.= separator)))))) + + (assert "List append is a monoid." + (let [(^open) &;Monoid] + (and (= sample (append unit sample)) + (= sample (append sample unit)) + (let [[left right] (&;split size (append sample other-sample))] + (and (= sample left) + (= other-sample right)))))) + + (assert "Applicative allows you to create singleton lists, and apply lists of functions to lists of values." + (let [(^open) &;Applicative] + (and (= (list separator) (wrap separator)) + (= (map n.inc sample) + (apply (wrap n.inc) sample))))) + + (assert "List concatenation is a monad." + (let [(^open) &;Monad + (^open) &;Monoid] + (= (append sample other-sample) + (join (list sample other-sample))))) + + (assert "You can find any value that satisfies some criterium, if such values exist in the list." + (case (&;find n.even? sample) + (#;Some found) + (and (n.even? found) + (&;any? n.even? sample) + (not (&;every? (bool;complement n.even?) sample))) + + #;None + (and (not (&;any? n.even? sample)) + (&;every? (bool;complement n.even?) sample)))) + + (assert "You can iteratively construct a list, generating values until you're done." + (= (&;n.range +0 (n.dec size)) + (&;iterate (lambda [n] (if (n.< size n) (#;Some (n.inc n)) #;None)) + +0))) + + (assert "Can enumerate all elements in a list." + (let [enum-sample (&;enumerate sample)] + (and (= (&;indices (&;size enum-sample)) + (&/map product;left enum-sample)) + (= sample + (&/map product;right enum-sample))))) + )) + +(test: "Monad transformer" + (let [lift (&;lift-list io;Monad) + (^open "io/") io;Monad] + (assert "Can add list functionality to any monad." + (|> (io;run (do (&;ListT io;Monad) + [a (lift (io/wrap 123)) + b (wrap 456)] + (wrap (i.+ a b)))) + (case> (^ (list 579)) true + _ false))) + )) diff --git a/stdlib/test/test/lux/data/coll/queue.lux b/stdlib/test/test/lux/data/coll/queue.lux new file mode 100644 index 000000000..e65c4eb74 --- /dev/null +++ b/stdlib/test/test/lux/data/coll/queue.lux @@ -0,0 +1,55 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io] + (control monad) + (data (coll ["&" queue]) + [number]) + ["R" random] + pipe) + lux/test) + +(test: "Queues" + [size (:: @ map (n.% +100) R;nat) + sample (R;queue size R;nat) + non-member (|> R;nat + (R;filter (. not (&;member? number;Eq sample))))] + ($_ seq + (assert "I can query the size of a queue (and empty queues have size 0)." + (if (n.= +0 size) + (&;empty? sample) + (n.= size (&;size sample)))) + + (assert "Enqueueing and dequeing affects the size of queues." + (and (n.= (n.inc size) (&;size (&;push non-member sample))) + (or (&;empty? sample) + (n.= (n.dec size) (&;size (&;pop sample)))) + (n.= size (&;size (&;pop (&;push non-member sample)))))) + + (assert "Transforming to/from list can't change the queue." + (let [(^open "&/") (&;Eq number;Eq)] + (|> sample + &;to-list &;from-list + (&/= sample)))) + + (assert "I can always peek at a non-empty queue." + (case (&;peek sample) + #;None (&;empty? sample) + (#;Some _) true)) + + (assert "I can query whether an element belongs to a queue." + (and (not (&;member? number;Eq sample non-member)) + (&;member? number;Eq (&;push non-member sample) + non-member) + (case (&;peek sample) + #;None + (&;empty? sample) + + (#;Some first) + (and (&;member? number;Eq sample first) + (not (&;member? number;Eq (&;pop sample) first)))))) + )) diff --git a/stdlib/test/test/lux/data/coll/set.lux b/stdlib/test/test/lux/data/coll/set.lux new file mode 100644 index 000000000..d9540927e --- /dev/null +++ b/stdlib/test/test/lux/data/coll/set.lux @@ -0,0 +1,68 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io] + (control monad) + (data (coll ["&" set] + [list "" Fold]) + [number]) + ["R" random] + pipe) + lux/test) + +(def: gen-nat + (R;Random Nat) + (|> R;nat + (:: R;Monad map (n.% +100)))) + +(test: "Sets" + [sizeL gen-nat + sizeR gen-nat + setL (R;set number;Hash sizeL gen-nat) + setR (R;set number;Hash sizeR gen-nat) + non-member (|> gen-nat + (R;filter (. not (&;member? setL)))) + #let [(^open "&/") &;Eq]] + ($_ seq + (assert "I can query the size of a set." + (and (n.= sizeL (&;size setL)) + (n.= sizeR (&;size setR)))) + + (assert "Converting sets to/from lists can't change their values." + (|> setL + &;to-list (&;from-list number;Hash) + (&/= setL))) + + (assert "Every set is a sub-set of the union of itself with another." + (let [setLR (&;union setL setR)] + (and (&;sub? setLR setL) + (&;sub? setLR setR)))) + + (assert "Every set is a super-set of the intersection of itself with another." + (let [setLR (&;intersection setL setR)] + (and (&;super? setLR setL) + (&;super? setLR setR)))) + + (assert "Union with the empty set leaves a set unchanged." + (&/= setL + (&;union (&;new number;Hash) + setL))) + + (assert "Intersection with the empty set results in the empty set." + (let [empty-set (&;new number;Hash)] + (&/= empty-set + (&;intersection empty-set setL)))) + + (assert "After substracting a set A from another B, no member of A can be a member of B." + (let [sub (&;difference setR setL)] + (not (list;any? (&;member? sub) (&;to-list setR))))) + + (assert "Every member of a set must be identifiable." + (and (not (&;member? setL non-member)) + (&;member? (&;add non-member setL) non-member) + (not (&;member? (&;remove non-member (&;add non-member setL)) non-member)))) + )) diff --git a/stdlib/test/test/lux/data/coll/stack.lux b/stdlib/test/test/lux/data/coll/stack.lux new file mode 100644 index 000000000..f8057b1f2 --- /dev/null +++ b/stdlib/test/test/lux/data/coll/stack.lux @@ -0,0 +1,48 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io] + (control monad) + (data (coll ["&" stack] + [list "" Fold]) + [number]) + ["R" random] + pipe) + lux/test) + +(def: gen-nat + (R;Random Nat) + (|> R;nat + (:: R;Monad map (n.% +100)))) + +(test: "Stacks" + [size gen-nat + sample (R;stack size gen-nat) + new-top gen-nat] + ($_ seq + (assert "Can query the size of a stack." + (n.= size (&;size sample))) + + (assert "Can peek inside non-empty stacks." + (case (&;peek sample) + #;None (&;empty? sample) + (#;Some _) (not (&;empty? sample)))) + + (assert "Popping empty stacks doesn't change anything. + But, if they're non-empty, the top of the stack is removed." + (let [sample' (&;pop sample)] + (or (n.= (&;size sample) (n.inc (&;size sample'))) + (and (&;empty? sample) (&;empty? sample'))) + )) + + (assert "Pushing onto a stack always increases it by 1, adding a new value at the top." + (and (is sample + (&;pop (&;push new-top sample))) + (n.= (n.inc (&;size sample)) (&;size (&;push new-top sample))) + (|> (&;push new-top sample) &;peek (default (undefined)) + (is new-top)))) + )) diff --git a/stdlib/test/test/lux/data/coll/tree/rose.lux b/stdlib/test/test/lux/data/coll/tree/rose.lux new file mode 100644 index 000000000..126a36678 --- /dev/null +++ b/stdlib/test/test/lux/data/coll/tree/rose.lux @@ -0,0 +1,40 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io] + (control monad) + (data (coll (tree ["&" rose]) + [list "List/" Monad]) + [number]) + ["R" random] + pipe) + lux/test) + +(def: gen-nat + (R;Random Nat) + (|> R;nat + (:: R;Monad map (n.% +100)))) + +(test: "Trees" + [leaf (:: @ map &;leaf R;nat) + branchS gen-nat + branchV R;nat + branchC (R;list branchS R;nat) + #let [branch (&;branch branchV (List/map &;leaf branchC))] + #let [(^open "&/") (&;Eq number;Eq) + (^open "List/") (list;Eq number;Eq)]] + ($_ seq + (assert "Can compare trees for equality." + (and (&/= leaf leaf) + (&/= branch branch) + (not (&/= leaf branch)) + (not (&/= leaf (&;branch branchV (List/map &;leaf (list;reverse branchC))))))) + + (assert "Can flatten a tree to get all the nodes as a flat tree." + (List/= (list& branchV branchC) + (&;flatten branch))) + )) diff --git a/stdlib/test/test/lux/data/coll/tree/zipper.lux b/stdlib/test/test/lux/data/coll/tree/zipper.lux new file mode 100644 index 000000000..949b558a7 --- /dev/null +++ b/stdlib/test/test/lux/data/coll/tree/zipper.lux @@ -0,0 +1,128 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io] + (control monad) + (data (coll [list "List/" Fold Functor] + (tree ["&" zipper] + [rose])) + [text "Text/" Monoid] + text/format + [number]) + (codata function) + ["R" random] + pipe) + lux/test) + +(def: gen-tree + (R;Random (rose;Tree Nat)) + (R;rec (lambda [gen-tree] + (do R;Monad + ## Each branch can have, at most, 1 child. + [size (|> R;nat (:: @ map (n.% +2)))] + (R;seq R;nat + (R;list size gen-tree)))))) + +(def: (to-end zipper) + (All [a] (-> (&;Zipper a) (&;Zipper a))) + (loop [zipper zipper] + (if (&;end? zipper) + zipper + (recur (&;next zipper))))) + +(test: "Zippers" + [sample gen-tree + new-val R;nat + pre-val R;nat + post-val R;nat + #let [(^open "Tree/") (rose;Eq number;Eq) + (^open "List/") (list;Eq number;Eq)]] + ($_ seq + (assert "Trees can be converted to/from zippers." + (|> sample + &;from-tree &;to-tree + (Tree/= sample))) + + (assert "Creating a zipper gives you a root node." + (|> sample &;from-tree &;root?)) + + (assert "Can move down inside branches. Can move up from lower nodes." + (let [zipper (&;from-tree sample)] + (if (&;branch? zipper) + (let [child (|> zipper &;down)] + (and (not (Tree/= sample (&;to-tree child))) + (|> child &;parent (default (undefined)) (is zipper)) + (|> child &;up (is zipper) not) + (|> child &;root (is zipper) not))) + (and (&;leaf? zipper) + (|> zipper (&;prepend-child new-val) &;branch?))))) + + (assert "Can prepend and append children." + (let [zipper (&;from-tree sample)] + (if (&;branch? zipper) + (let [mid-val (|> zipper &;down &;value) + zipper (|> zipper + (&;prepend-child pre-val) + (&;append-child post-val))] + (and (|> zipper &;down &;value (is pre-val)) + (|> zipper &;down &;right &;value (is mid-val)) + (|> zipper &;down &;right &;right &;value (is post-val)) + (|> zipper &;down &;rightmost &;leftmost &;value (is pre-val)) + (|> zipper &;down &;right &;left &;value (is pre-val)) + (|> zipper &;down &;rightmost &;value (is post-val)))) + true))) + + (assert "Can insert children around a node (unless it's root)." + (let [zipper (&;from-tree sample)] + (if (&;branch? zipper) + (let [mid-val (|> zipper &;down &;value) + zipper (|> zipper + &;down + (&;insert-left pre-val) + (default (undefined)) + (&;insert-right post-val) + (default (undefined)) + &;up)] + (and (|> zipper &;down &;value (is pre-val)) + (|> zipper &;down &;right &;value (is mid-val)) + (|> zipper &;down &;right &;right &;value (is post-val)) + (|> zipper &;down &;rightmost &;leftmost &;value (is pre-val)) + (|> zipper &;down &;right &;left &;value (is pre-val)) + (|> zipper &;down &;rightmost &;value (is post-val)))) + (and (|> zipper (&;insert-left pre-val) (case> (#;Some _) false + #;None true)) + (|> zipper (&;insert-right post-val) (case> (#;Some _) false + #;None true)))))) + + (assert "Can set and update the value of a node." + (|> sample &;from-tree (&;set new-val) &;value (n.= new-val))) + + (assert "Zipper traversal follows the outline of the tree depth-first." + (List/= (rose;flatten sample) + (loop [zipper (&;from-tree sample)] + (if (&;end? zipper) + (list (&;value zipper)) + (#;Cons (&;value zipper) + (recur (&;next zipper))))))) + + (assert "Backwards zipper traversal yield reverse tree flatten." + (List/= (list;reverse (rose;flatten sample)) + (loop [zipper (to-end (&;from-tree sample))] + (if (&;root? zipper) + (list (&;value zipper)) + (#;Cons (&;value zipper) + (recur (&;prev zipper))))))) + + (assert "Can remove nodes (except root nodes)." + (let [zipper (&;from-tree sample)] + (if (&;branch? zipper) + (and (|> zipper &;down &;root? not) + (|> zipper &;down &;remove (case> #;None false + (#;Some node) (&;root? node)))) + (|> zipper &;remove (case> #;None true + (#;Some _) false))))) + )) diff --git a/stdlib/test/test/lux/data/coll/vector.lux b/stdlib/test/test/lux/data/coll/vector.lux new file mode 100644 index 000000000..9e1c3c44b --- /dev/null +++ b/stdlib/test/test/lux/data/coll/vector.lux @@ -0,0 +1,78 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io] + (control monad) + (data (coll ["&" vector] + [list "List/" Fold Functor]) + [text "Text/" Monoid] + text/format + [number]) + (codata function) + ["R" random] + pipe) + lux/test) + +(test: "Vectors" + [size (|> R;nat (:: @ map (n.% +100))) + idx (|> R;nat (:: @ map (n.% size))) + sample (R;vector size R;nat) + other-sample (R;vector size R;nat) + non-member (|> R;nat (R;filter (. not (&;member? number;Eq sample)))) + #let [(^open "&/") (&;Eq number;Eq) + (^open "&/") &;Monad + (^open "&/") &;Fold + (^open "&/") &;Monoid]] + ($_ seq + (assert "Can query size of vector." + (if (&;empty? sample) + (and (n.= +0 size) + (n.= +0 (&;size sample))) + (n.= size (&;size sample)))) + + (assert "Can add and remove elements to vectors." + (and (n.= (n.inc size) (&;size (&;add non-member sample))) + (n.= (n.dec size) (&;size (&;pop sample))))) + + (assert "Can put and get elements into vectors." + (|> sample + (&;put idx non-member) + (&;nth idx) + (default (undefined)) + (is non-member))) + + (assert "Can update elements of vectors." + (|> sample + (&;put idx non-member) (&;update idx n.inc) + (&;nth idx) (default (undefined)) + (n.= (n.inc non-member)))) + + (assert "Can safely transform to/from lists." + (|> sample &;to-list &;from-list (&/= sample))) + + (assert "Can identify members of a vector." + (and (not (&;member? number;Eq sample non-member)) + (&;member? number;Eq (&;add non-member sample) non-member))) + + (assert "Can fold over elements of vector." + (n.= (List/fold n.+ +0 (&;to-list sample)) + (&/fold n.+ +0 sample))) + + (assert "Functor goes over every element." + (let [there (&/map n.inc sample) + back-again (&/map n.dec there)] + (and (not (&/= sample there)) + (&/= sample back-again)))) + + (assert "Applicative allows you to create singleton vectors, and apply vectors of functions to vectors of values." + (and (&/= (&;vector non-member) (&/wrap non-member)) + (&/= (&/map n.inc sample) (&/apply (&/wrap n.inc) sample)))) + + (assert "Vector concatenation is a monad." + (&/= (&/append sample other-sample) + (&/join (&;vector sample other-sample)))) + )) diff --git a/stdlib/test/test/lux/data/error.lux b/stdlib/test/test/lux/data/error.lux index 880c2e0f1..a53d7faf2 100644 --- a/stdlib/test/test/lux/data/error.lux +++ b/stdlib/test/test/lux/data/error.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data text/format ["&" error]) diff --git a/stdlib/test/test/lux/data/error/exception.lux b/stdlib/test/test/lux/data/error/exception.lux index 312bca2a2..c3db059e6 100644 --- a/stdlib/test/test/lux/data/error/exception.lux +++ b/stdlib/test/test/lux/data/error/exception.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [error #- fail] (error ["&" exception #+ exception:]) diff --git a/stdlib/test/test/lux/data/format/json.lux b/stdlib/test/test/lux/data/format/json.lux index 06c29707f..3734192a0 100644 --- a/stdlib/test/test/lux/data/format/json.lux +++ b/stdlib/test/test/lux/data/format/json.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad codec eq) @@ -17,9 +17,9 @@ [maybe] [number "i/" Number] (format ["&" json]) - (struct [vector #+ vector] - [dict] - [list])) + (coll [vector #+ vector] + [dict] + [list])) [compiler #+ with-gensyms] [macro] (macro [ast] diff --git a/stdlib/test/test/lux/data/ident.lux b/stdlib/test/test/lux/data/ident.lux index 70a8d2a58..1f8cc0441 100644 --- a/stdlib/test/test/lux/data/ident.lux +++ b/stdlib/test/test/lux/data/ident.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data ["&" ident] [text "Text/" Eq] diff --git a/stdlib/test/test/lux/data/identity.lux b/stdlib/test/test/lux/data/identity.lux index 4f8c26cb1..2444b80b7 100644 --- a/stdlib/test/test/lux/data/identity.lux +++ b/stdlib/test/test/lux/data/identity.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad comonad) (data ["&" identity] diff --git a/stdlib/test/test/lux/data/log.lux b/stdlib/test/test/lux/data/log.lux index dd94b1efa..abc1112a2 100644 --- a/stdlib/test/test/lux/data/log.lux +++ b/stdlib/test/test/lux/data/log.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data ["&" log] [text "Text/" Monoid Eq] diff --git a/stdlib/test/test/lux/data/maybe.lux b/stdlib/test/test/lux/data/maybe.lux index b0f2b411c..de738e336 100644 --- a/stdlib/test/test/lux/data/maybe.lux +++ b/stdlib/test/test/lux/data/maybe.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data ["&" maybe] [text "Text/" Monoid] diff --git a/stdlib/test/test/lux/data/number.lux b/stdlib/test/test/lux/data/number.lux index 8b7267444..4de7d4c14 100644 --- a/stdlib/test/test/lux/data/number.lux +++ b/stdlib/test/test/lux/data/number.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data number [text "Text/" Monoid Eq] diff --git a/stdlib/test/test/lux/data/product.lux b/stdlib/test/test/lux/data/product.lux index 3d064f96e..69b1029b9 100644 --- a/stdlib/test/test/lux/data/product.lux +++ b/stdlib/test/test/lux/data/product.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data product [text "Text/" Monoid] diff --git a/stdlib/test/test/lux/data/struct/array.lux b/stdlib/test/test/lux/data/struct/array.lux deleted file mode 100644 index ae7ff4bbc..000000000 --- a/stdlib/test/test/lux/data/struct/array.lux +++ /dev/null @@ -1,135 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (control [monad]) - (codata [io]) - (data (struct ["&" array] - [list]) - [number]) - ["R" random] - pipe) - lux/test) - -(def: bounded-size - (R;Random Nat) - (|> R;nat - (:: R;Monad map (|>. (n.% +100) (n.+ +1))))) - -(test: "Arrays and their copies" - [size bounded-size - original (R;array size R;nat) - #let [clone (&;clone original) - copy (: (&;Array Nat) - (&;new size)) - manual-copy (: (&;Array Nat) - (&;new size))]] - ($_ seq - (assert "Size function must correctly return size of array." - (n.= size (&;size original))) - (assert "Cloning an array should yield and identical array, but not the same one." - (and (:: (&;Eq number;Eq) = original clone) - (not (is original clone)))) - (assert "Full-range manual copies should give the same result as cloning." - (exec (&;copy size +0 original +0 copy) - (and (:: (&;Eq number;Eq) = original copy) - (not (is original copy))))) - (assert "Array folding should go over all values." - (exec (:: &;Fold fold - (lambda [x idx] - (exec (&;put idx x manual-copy) - (n.inc idx))) - +0 - original) - (:: (&;Eq number;Eq) = original manual-copy))) - (assert "Transformations between (full) arrays and lists shouldn't cause lose or change any values." - (|> original - &;to-list &;from-list - (:: (&;Eq number;Eq) = original))) - )) - -(test: "Array mutation" - [size bounded-size - idx (:: @ map (n.% size) R;nat) - array (|> (R;array size R;nat) - (R;filter (|>. &;to-list (list;any? n.odd?)))) - #let [value (default (undefined) - (&;get idx array))]] - ($_ seq - (assert "Shouldn't be able to find a value in an unoccupied cell." - (case (&;get idx (&;remove idx array)) - (#;Some _) false - #;None true)) - (assert "You should be able to access values put into the array." - (case (&;get idx (&;put idx value array)) - (#;Some value') (n.= value' value) - #;None false)) - (assert "All cells should be occupied on a full array." - (and (n.= size (&;occupied array)) - (n.= +0 (&;vacant array)))) - (assert "Filtering mutates the array to remove invalid values." - (exec (&;filter n.even? array) - (and (n.< size (&;occupied array)) - (n.> +0 (&;vacant array)) - (n.= size (n.+ (&;occupied array) - (&;vacant array)))))) - )) - -(test: "Finding values." - [size bounded-size - array (|> (R;array size R;nat) - (R;filter (|>. &;to-list (list;any? n.even?))))] - ($_ seq - (assert "Can find values inside arrays." - (|> (&;find n.even? array) - (case> (#;Some _) true - #;None false))) - (assert "Can find values inside arrays (with access to indices)." - (|> (&;find+ (lambda [idx n] - (and (n.even? n) - (n.< size idx))) - array) - (case> (#;Some _) true - #;None false))))) - -(test: "Functor" - [size bounded-size - array (R;array size R;nat)] - (let [(^open) &;Functor - (^open) (&;Eq number;Eq)] - ($_ seq - (assert "Functor shouldn't alter original array." - (let [copy (map id array)] - (and (= array copy) - (not (is array copy))))) - (assert "Functor should go over all available array elements." - (let [there (map n.inc array) - back-again (map n.dec there)] - (and (not (= array there)) - (= array back-again))))))) - -(test: "Monoid" - [sizeL bounded-size - sizeR bounded-size - left (R;array sizeL R;nat) - right (R;array sizeR R;nat) - #let [(^open) &;Monoid - (^open) (&;Eq number;Eq) - fusion (append left right)]] - ($_ seq - (assert "Appending two arrays should produce a new one twice as large." - (n.= (n.+ sizeL sizeR) (&;size fusion))) - (assert "First elements of fused array should equal the first array." - (|> (: (&;Array Nat) - (&;new sizeL)) - (&;copy sizeL +0 fusion +0) - (= left))) - (assert "Last elements of fused array should equal the second array." - (|> (: (&;Array Nat) - (&;new sizeR)) - (&;copy sizeR sizeL fusion +0) - (= right))) - )) diff --git a/stdlib/test/test/lux/data/struct/dict.lux b/stdlib/test/test/lux/data/struct/dict.lux deleted file mode 100644 index b467e232a..000000000 --- a/stdlib/test/test/lux/data/struct/dict.lux +++ /dev/null @@ -1,137 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io]) - (control monad - [eq]) - (data [text "Text/" Monoid] - text/format - [number] - [char] - (struct ["&" dict] - [list "List/" Fold Functor])) - (codata function) - ["R" random] - pipe) - lux/test) - -(test: "Dictionaries." - [#let [capped-nat (:: R;Monad map (n.% +100) R;nat)] - size capped-nat - dict (R;dict char;Hash size R;char capped-nat) - non-key (|> R;char - (R;filter (lambda [key] (not (&;contains? key dict))))) - test-val (|> R;nat - (R;filter (lambda [val] (not (list;member? number;Eq (&;values dict) val)))))] - ($_ seq - (assert "Size function should correctly represent Dict size." - (n.= size (&;size dict))) - - (assert "Dicts of size 0 should be considered empty." - (if (n.= +0 size) - (&;empty? dict) - (not (&;empty? dict)))) - - (assert "The functions 'entries', 'keys' and 'values' should be synchronized." - (:: (list;Eq (eq;conj char;Eq number;Eq)) = - (&;entries dict) - (list;zip2 (&;keys dict) - (&;values dict)))) - - (assert "Dict should be able to recognize it's own keys." - (list;every? (lambda [key] (&;contains? key dict)) - (&;keys dict))) - - (assert "Should be able to get every key." - (list;every? (lambda [key] (case (&;get key dict) - (#;Some _) true - _ false)) - (&;keys dict))) - - (assert "Shouldn't be able to access non-existant keys." - (case (&;get non-key dict) - (#;Some _) false - _ true)) - - (assert "Should be able to put and then get a value." - (case (&;get non-key (&;put non-key test-val dict)) - (#;Some v) (n.= test-val v) - _ true)) - - (assert "Should be able to put~ and then get a value." - (case (&;get non-key (&;put~ non-key test-val dict)) - (#;Some v) (n.= test-val v) - _ true)) - - (assert "Shouldn't be able to put~ an existing key." - (or (n.= +0 size) - (let [first-key (|> dict &;keys list;head (default (undefined)))] - (case (&;get first-key (&;put~ first-key test-val dict)) - (#;Some v) (not (n.= test-val v)) - _ true)))) - - (assert "Removing a key should make it's value inaccessible." - (let [base (&;put non-key test-val dict)] - (and (&;contains? non-key base) - (not (&;contains? non-key (&;remove non-key base)))))) - - (assert "Should be possible to update values via their keys." - (let [base (&;put non-key test-val dict) - updt (&;update non-key n.inc base)] - (case [(&;get non-key base) (&;get non-key updt)] - [(#;Some x) (#;Some y)] - (n.= (n.inc x) y) - - _ - false))) - - (assert "Additions and removals to a Dict should affect its size." - (let [plus (&;put non-key test-val dict) - base (&;remove non-key plus)] - (and (n.= (n.inc (&;size dict)) (&;size plus)) - (n.= (n.dec (&;size plus)) (&;size base))))) - - (assert "A Dict should equal itself & going to<->from lists shouldn't change that." - (let [(^open) (&;Eq number;Eq)] - (and (= dict dict) - (|> dict &;entries (&;from-list char;Hash) (= dict))))) - - (assert "Merging a Dict to itself changes nothing." - (let [(^open) (&;Eq number;Eq)] - (= dict (&;merge dict dict)))) - - (assert "If you merge, and the second dict has overlapping keys, it should overwrite yours." - (let [dict' (|> dict &;entries - (List/map (lambda [[k v]] [k (n.inc v)])) - (&;from-list char;Hash)) - (^open) (&;Eq number;Eq)] - (= dict' (&;merge dict' dict)))) - - (assert "Can merge values in such a way that they become combined." - (list;every? (lambda [[x x*2]] (n.= (n.* +2 x) x*2)) - (list;zip2 (&;values dict) - (&;values (&;merge-with n.+ dict dict))))) - - (assert "Should be able to select subset of keys from dict." - (|> dict - (&;put non-key test-val) - (&;select (list non-key)) - &;size - (n.= +1))) - - (assert "Should be able to re-bind existing values to different keys." - (or (n.= +0 size) - (let [first-key (|> dict &;keys list;head (default (undefined))) - rebound (&;re-bind first-key non-key dict)] - (and (n.= (&;size dict) (&;size rebound)) - (&;contains? non-key rebound) - (not (&;contains? first-key rebound)) - (n.= (default (undefined) - (&;get first-key dict)) - (default (undefined) - (&;get non-key rebound))))))) - )) diff --git a/stdlib/test/test/lux/data/struct/list.lux b/stdlib/test/test/lux/data/struct/list.lux deleted file mode 100644 index b40615036..000000000 --- a/stdlib/test/test/lux/data/struct/list.lux +++ /dev/null @@ -1,226 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io]) - (control monad) - (data (struct ["&" list]) - [text "Text/" Monoid] - [number] - [bool] - [product]) - ["R" random] - pipe) - lux/test) - -(def: bounded-size - (R;Random Nat) - (|> R;nat - (:: R;Monad map (|>. (n.% +100) (n.+ +10))))) - -(test: "Lists: Part 1" - [size bounded-size - idx (:: @ map (n.% size) R;nat) - sample (R;list size R;nat) - other-size bounded-size - other-sample (R;list other-size R;nat) - separator R;nat - #let [(^open) (&;Eq number;Eq) - (^open "&/") &;Functor]] - ($_ seq - (assert "The size function should correctly portray the size of the list." - (n.= size (&;size sample))) - - (assert "The repeat function should produce as many elements as asked of it." - (n.= size (&;size (&;repeat size [])))) - - (assert "Reversing a list does not change it's size." - (n.= (&;size sample) - (&;size (&;reverse sample)))) - - (assert "Reversing a list twice results in the original list." - (= sample - (&;reverse (&;reverse sample)))) - - (assert "Filtering by a predicate and its complement should result in a number of elements equal to the original list." - (and (n.= (&;size sample) - (n.+ (&;size (&;filter n.even? sample)) - (&;size (&;filter (bool;complement n.even?) sample)))) - (let [[plus minus] (&;partition n.even? sample)] - (n.= (&;size sample) - (n.+ (&;size plus) - (&;size minus)))))) - - (assert "If every element in a list satisfies a predicate, there can't be any that satisfy its complement." - (if (&;every? n.even? sample) - (and (not (&;any? (bool;complement n.even?) sample)) - (&;empty? (&;filter (bool;complement n.even?) sample))) - (&;any? (bool;complement n.even?) sample))) - - (assert "Any element of the list can be considered it's member." - (let [elem (default (undefined) - (&;at idx sample))] - (&;member? number;Eq sample elem))) - )) - -(test: "Lists: Part 2" - [size bounded-size - idx (:: @ map (n.% size) R;nat) - sample (R;list size R;nat) - other-size bounded-size - other-sample (R;list other-size R;nat) - separator R;nat - #let [(^open) (&;Eq number;Eq) - (^open "&/") &;Functor]] - ($_ seq - (assert "Appending the head and the tail should yield the original list." - (let [head (default (undefined) - (&;head sample)) - tail (default (undefined) - (&;tail sample))] - (= sample - (#;Cons head tail)))) - - (assert "Appending the inits and the last should yield the original list." - (let [(^open) &;Monoid - inits (default (undefined) - (&;inits sample)) - last (default (undefined) - (&;last sample))] - (= sample - (append inits (list last))))) - - (assert "Functor should go over every element of the list." - (let [(^open) &;Functor - there (map n.inc sample) - back-again (map n.dec there)] - (and (not (= sample there)) - (= sample back-again)))) - - (assert "Splitting a list into chunks and re-appending them should yield the original list." - (let [(^open) &;Monoid - [left right] (&;split idx sample) - [left' right'] (&;split-with n.even? sample)] - (and (= sample - (append left right)) - (= sample - (append left' right')) - (= sample - (append (&;take idx sample) - (&;drop idx sample))) - (= sample - (append (&;take-while n.even? sample) - (&;drop-while n.even? sample))) - ))) - - (assert "Segmenting the list in pairs should yield as many elements as N/2." - (n.= (n./ +2 size) - (&;size (&;as-pairs sample)))) - - (assert "Sorting a list shouldn't change it's size." - (n.= (&;size sample) - (&;size (&;sort n.< sample)))) - - (assert "Sorting a list with one order should yield the reverse of sorting it with the opposite order." - (= (&;sort n.< sample) - (&;reverse (&;sort n.> sample)))) - )) - -(test: "Lists: Part 3" - [size bounded-size - idx (:: @ map (n.% size) R;nat) - sample (R;list size R;nat) - other-size bounded-size - other-sample (R;list other-size R;nat) - separator R;nat - #let [(^open) (&;Eq number;Eq) - (^open "&/") &;Functor]] - ($_ seq - (assert "If you zip 2 lists, the result's size will be that of the smaller list." - (n.= (&;size (&;zip2 sample other-sample)) - (n.min (&;size sample) (&;size other-sample)))) - - (assert "I can pair-up elements of a list in order." - (let [(^open) &;Functor - zipped (&;zip2 sample other-sample) - num-zipper (&;size zipped)] - (and (|> zipped (map product;left) (= (&;take num-zipper sample))) - (|> zipped (map product;right) (= (&;take num-zipper other-sample)))))) - - (assert "You can generate indices for any size, and they will be in ascending order." - (let [(^open) &;Functor - indices (&;indices size)] - (and (n.= size (&;size indices)) - (= indices - (&;sort n.< indices)) - (&;every? (n.= (n.dec size)) - (&;zip2-with n.+ - indices - (&;sort n.> indices))) - ))) - - (assert "The 'interpose' function places a value between every member of a list." - (let [(^open) &;Functor - sample+ (&;interpose separator sample)] - (and (n.= (|> size (n.* +2) n.dec) - (&;size sample+)) - (|> sample+ &;as-pairs (map product;right) (&;every? (n.= separator)))))) - - (assert "List append is a monoid." - (let [(^open) &;Monoid] - (and (= sample (append unit sample)) - (= sample (append sample unit)) - (let [[left right] (&;split size (append sample other-sample))] - (and (= sample left) - (= other-sample right)))))) - - (assert "Applicative allows you to create singleton lists, and apply lists of functions to lists of values." - (let [(^open) &;Applicative] - (and (= (list separator) (wrap separator)) - (= (map n.inc sample) - (apply (wrap n.inc) sample))))) - - (assert "List concatenation is a monad." - (let [(^open) &;Monad - (^open) &;Monoid] - (= (append sample other-sample) - (join (list sample other-sample))))) - - (assert "You can find any value that satisfies some criterium, if such values exist in the list." - (case (&;find n.even? sample) - (#;Some found) - (and (n.even? found) - (&;any? n.even? sample) - (not (&;every? (bool;complement n.even?) sample))) - - #;None - (and (not (&;any? n.even? sample)) - (&;every? (bool;complement n.even?) sample)))) - - (assert "You can iteratively construct a list, generating values until you're done." - (= (&;n.range +0 (n.dec size)) - (&;iterate (lambda [n] (if (n.< size n) (#;Some (n.inc n)) #;None)) - +0))) - - (assert "Can enumerate all elements in a list." - (let [enum-sample (&;enumerate sample)] - (and (= (&;indices (&;size enum-sample)) - (&/map product;left enum-sample)) - (= sample - (&/map product;right enum-sample))))) - )) - -(test: "Monad transformer" - (let [lift (&;lift-list io;Monad) - (^open "io/") io;Monad] - (assert "Can add list functionality to any monad." - (|> (io;run (do (&;ListT io;Monad) - [a (lift (io/wrap 123)) - b (wrap 456)] - (wrap (i.+ a b)))) - (case> (^ (list 579)) true - _ false))) - )) diff --git a/stdlib/test/test/lux/data/struct/queue.lux b/stdlib/test/test/lux/data/struct/queue.lux deleted file mode 100644 index d92fecf10..000000000 --- a/stdlib/test/test/lux/data/struct/queue.lux +++ /dev/null @@ -1,55 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io]) - (control monad) - (data (struct ["&" queue]) - [number]) - ["R" random] - pipe) - lux/test) - -(test: "Queues" - [size (:: @ map (n.% +100) R;nat) - sample (R;queue size R;nat) - non-member (|> R;nat - (R;filter (. not (&;member? number;Eq sample))))] - ($_ seq - (assert "I can query the size of a queue (and empty queues have size 0)." - (if (n.= +0 size) - (&;empty? sample) - (n.= size (&;size sample)))) - - (assert "Enqueueing and dequeing affects the size of queues." - (and (n.= (n.inc size) (&;size (&;push non-member sample))) - (or (&;empty? sample) - (n.= (n.dec size) (&;size (&;pop sample)))) - (n.= size (&;size (&;pop (&;push non-member sample)))))) - - (assert "Transforming to/from list can't change the queue." - (let [(^open "&/") (&;Eq number;Eq)] - (|> sample - &;to-list &;from-list - (&/= sample)))) - - (assert "I can always peek at a non-empty queue." - (case (&;peek sample) - #;None (&;empty? sample) - (#;Some _) true)) - - (assert "I can query whether an element belongs to a queue." - (and (not (&;member? number;Eq sample non-member)) - (&;member? number;Eq (&;push non-member sample) - non-member) - (case (&;peek sample) - #;None - (&;empty? sample) - - (#;Some first) - (and (&;member? number;Eq sample first) - (not (&;member? number;Eq (&;pop sample) first)))))) - )) diff --git a/stdlib/test/test/lux/data/struct/set.lux b/stdlib/test/test/lux/data/struct/set.lux deleted file mode 100644 index ae709384f..000000000 --- a/stdlib/test/test/lux/data/struct/set.lux +++ /dev/null @@ -1,68 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io]) - (control monad) - (data (struct ["&" set] - [list "" Fold]) - [number]) - ["R" random] - pipe) - lux/test) - -(def: gen-nat - (R;Random Nat) - (|> R;nat - (:: R;Monad map (n.% +100)))) - -(test: "Sets" - [sizeL gen-nat - sizeR gen-nat - setL (R;set number;Hash sizeL gen-nat) - setR (R;set number;Hash sizeR gen-nat) - non-member (|> gen-nat - (R;filter (. not (&;member? setL)))) - #let [(^open "&/") &;Eq]] - ($_ seq - (assert "I can query the size of a set." - (and (n.= sizeL (&;size setL)) - (n.= sizeR (&;size setR)))) - - (assert "Converting sets to/from lists can't change their values." - (|> setL - &;to-list (&;from-list number;Hash) - (&/= setL))) - - (assert "Every set is a sub-set of the union of itself with another." - (let [setLR (&;union setL setR)] - (and (&;sub? setLR setL) - (&;sub? setLR setR)))) - - (assert "Every set is a super-set of the intersection of itself with another." - (let [setLR (&;intersection setL setR)] - (and (&;super? setLR setL) - (&;super? setLR setR)))) - - (assert "Union with the empty set leaves a set unchanged." - (&/= setL - (&;union (&;new number;Hash) - setL))) - - (assert "Intersection with the empty set results in the empty set." - (let [empty-set (&;new number;Hash)] - (&/= empty-set - (&;intersection empty-set setL)))) - - (assert "After substracting a set A from another B, no member of A can be a member of B." - (let [sub (&;difference setR setL)] - (not (list;any? (&;member? sub) (&;to-list setR))))) - - (assert "Every member of a set must be identifiable." - (and (not (&;member? setL non-member)) - (&;member? (&;add non-member setL) non-member) - (not (&;member? (&;remove non-member (&;add non-member setL)) non-member)))) - )) diff --git a/stdlib/test/test/lux/data/struct/stack.lux b/stdlib/test/test/lux/data/struct/stack.lux deleted file mode 100644 index 001eb1af1..000000000 --- a/stdlib/test/test/lux/data/struct/stack.lux +++ /dev/null @@ -1,48 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io]) - (control monad) - (data (struct ["&" stack] - [list "" Fold]) - [number]) - ["R" random] - pipe) - lux/test) - -(def: gen-nat - (R;Random Nat) - (|> R;nat - (:: R;Monad map (n.% +100)))) - -(test: "Stacks" - [size gen-nat - sample (R;stack size gen-nat) - new-top gen-nat] - ($_ seq - (assert "Can query the size of a stack." - (n.= size (&;size sample))) - - (assert "Can peek inside non-empty stacks." - (case (&;peek sample) - #;None (&;empty? sample) - (#;Some _) (not (&;empty? sample)))) - - (assert "Popping empty stacks doesn't change anything. - But, if they're non-empty, the top of the stack is removed." - (let [sample' (&;pop sample)] - (or (n.= (&;size sample) (n.inc (&;size sample'))) - (and (&;empty? sample) (&;empty? sample'))) - )) - - (assert "Pushing onto a stack always increases it by 1, adding a new value at the top." - (and (is sample - (&;pop (&;push new-top sample))) - (n.= (n.inc (&;size sample)) (&;size (&;push new-top sample))) - (|> (&;push new-top sample) &;peek (default (undefined)) - (is new-top)))) - )) diff --git a/stdlib/test/test/lux/data/struct/tree/rose.lux b/stdlib/test/test/lux/data/struct/tree/rose.lux deleted file mode 100644 index 21592aba9..000000000 --- a/stdlib/test/test/lux/data/struct/tree/rose.lux +++ /dev/null @@ -1,40 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io]) - (control monad) - (data (struct (tree ["&" rose]) - [list "List/" Monad]) - [number]) - ["R" random] - pipe) - lux/test) - -(def: gen-nat - (R;Random Nat) - (|> R;nat - (:: R;Monad map (n.% +100)))) - -(test: "Trees" - [leaf (:: @ map &;leaf R;nat) - branchS gen-nat - branchV R;nat - branchC (R;list branchS R;nat) - #let [branch (&;branch branchV (List/map &;leaf branchC))] - #let [(^open "&/") (&;Eq number;Eq) - (^open "List/") (list;Eq number;Eq)]] - ($_ seq - (assert "Can compare trees for equality." - (and (&/= leaf leaf) - (&/= branch branch) - (not (&/= leaf branch)) - (not (&/= leaf (&;branch branchV (List/map &;leaf (list;reverse branchC))))))) - - (assert "Can flatten a tree to get all the nodes as a flat tree." - (List/= (list& branchV branchC) - (&;flatten branch))) - )) diff --git a/stdlib/test/test/lux/data/struct/tree/zipper.lux b/stdlib/test/test/lux/data/struct/tree/zipper.lux deleted file mode 100644 index f2d7fe708..000000000 --- a/stdlib/test/test/lux/data/struct/tree/zipper.lux +++ /dev/null @@ -1,128 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io]) - (control monad) - (data (struct [list "List/" Fold Functor] - (tree ["&" zipper] - [rose])) - [text "Text/" Monoid] - text/format - [number]) - (codata function) - ["R" random] - pipe) - lux/test) - -(def: gen-tree - (R;Random (rose;Tree Nat)) - (R;rec (lambda [gen-tree] - (do R;Monad - ## Each branch can have, at most, 1 child. - [size (|> R;nat (:: @ map (n.% +2)))] - (R;seq R;nat - (R;list size gen-tree)))))) - -(def: (to-end zipper) - (All [a] (-> (&;Zipper a) (&;Zipper a))) - (loop [zipper zipper] - (if (&;end? zipper) - zipper - (recur (&;next zipper))))) - -(test: "Zippers" - [sample gen-tree - new-val R;nat - pre-val R;nat - post-val R;nat - #let [(^open "Tree/") (rose;Eq number;Eq) - (^open "List/") (list;Eq number;Eq)]] - ($_ seq - (assert "Trees can be converted to/from zippers." - (|> sample - &;from-tree &;to-tree - (Tree/= sample))) - - (assert "Creating a zipper gives you a root node." - (|> sample &;from-tree &;root?)) - - (assert "Can move down inside branches. Can move up from lower nodes." - (let [zipper (&;from-tree sample)] - (if (&;branch? zipper) - (let [child (|> zipper &;down)] - (and (not (Tree/= sample (&;to-tree child))) - (|> child &;parent (default (undefined)) (is zipper)) - (|> child &;up (is zipper) not) - (|> child &;root (is zipper) not))) - (and (&;leaf? zipper) - (|> zipper (&;prepend-child new-val) &;branch?))))) - - (assert "Can prepend and append children." - (let [zipper (&;from-tree sample)] - (if (&;branch? zipper) - (let [mid-val (|> zipper &;down &;value) - zipper (|> zipper - (&;prepend-child pre-val) - (&;append-child post-val))] - (and (|> zipper &;down &;value (is pre-val)) - (|> zipper &;down &;right &;value (is mid-val)) - (|> zipper &;down &;right &;right &;value (is post-val)) - (|> zipper &;down &;rightmost &;leftmost &;value (is pre-val)) - (|> zipper &;down &;right &;left &;value (is pre-val)) - (|> zipper &;down &;rightmost &;value (is post-val)))) - true))) - - (assert "Can insert children around a node (unless it's root)." - (let [zipper (&;from-tree sample)] - (if (&;branch? zipper) - (let [mid-val (|> zipper &;down &;value) - zipper (|> zipper - &;down - (&;insert-left pre-val) - (default (undefined)) - (&;insert-right post-val) - (default (undefined)) - &;up)] - (and (|> zipper &;down &;value (is pre-val)) - (|> zipper &;down &;right &;value (is mid-val)) - (|> zipper &;down &;right &;right &;value (is post-val)) - (|> zipper &;down &;rightmost &;leftmost &;value (is pre-val)) - (|> zipper &;down &;right &;left &;value (is pre-val)) - (|> zipper &;down &;rightmost &;value (is post-val)))) - (and (|> zipper (&;insert-left pre-val) (case> (#;Some _) false - #;None true)) - (|> zipper (&;insert-right post-val) (case> (#;Some _) false - #;None true)))))) - - (assert "Can set and update the value of a node." - (|> sample &;from-tree (&;set new-val) &;value (n.= new-val))) - - (assert "Zipper traversal follows the outline of the tree depth-first." - (List/= (rose;flatten sample) - (loop [zipper (&;from-tree sample)] - (if (&;end? zipper) - (list (&;value zipper)) - (#;Cons (&;value zipper) - (recur (&;next zipper))))))) - - (assert "Backwards zipper traversal yield reverse tree flatten." - (List/= (list;reverse (rose;flatten sample)) - (loop [zipper (to-end (&;from-tree sample))] - (if (&;root? zipper) - (list (&;value zipper)) - (#;Cons (&;value zipper) - (recur (&;prev zipper))))))) - - (assert "Can remove nodes (except root nodes)." - (let [zipper (&;from-tree sample)] - (if (&;branch? zipper) - (and (|> zipper &;down &;root? not) - (|> zipper &;down &;remove (case> #;None false - (#;Some node) (&;root? node)))) - (|> zipper &;remove (case> #;None true - (#;Some _) false))))) - )) diff --git a/stdlib/test/test/lux/data/struct/vector.lux b/stdlib/test/test/lux/data/struct/vector.lux deleted file mode 100644 index 35663c63a..000000000 --- a/stdlib/test/test/lux/data/struct/vector.lux +++ /dev/null @@ -1,78 +0,0 @@ -## Copyright (c) Eduardo Julian. All rights reserved. -## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -## If a copy of the MPL was not distributed with this file, -## You can obtain one at http://mozilla.org/MPL/2.0/. - -(;module: - lux - (lux (codata [io]) - (control monad) - (data (struct ["&" vector] - [list "List/" Fold Functor]) - [text "Text/" Monoid] - text/format - [number]) - (codata function) - ["R" random] - pipe) - lux/test) - -(test: "Vectors" - [size (|> R;nat (:: @ map (n.% +100))) - idx (|> R;nat (:: @ map (n.% size))) - sample (R;vector size R;nat) - other-sample (R;vector size R;nat) - non-member (|> R;nat (R;filter (. not (&;member? number;Eq sample)))) - #let [(^open "&/") (&;Eq number;Eq) - (^open "&/") &;Monad - (^open "&/") &;Fold - (^open "&/") &;Monoid]] - ($_ seq - (assert "Can query size of vector." - (if (&;empty? sample) - (and (n.= +0 size) - (n.= +0 (&;size sample))) - (n.= size (&;size sample)))) - - (assert "Can add and remove elements to vectors." - (and (n.= (n.inc size) (&;size (&;add non-member sample))) - (n.= (n.dec size) (&;size (&;pop sample))))) - - (assert "Can put and get elements into vectors." - (|> sample - (&;put idx non-member) - (&;at idx) - (default (undefined)) - (is non-member))) - - (assert "Can update elements of vectors." - (|> sample - (&;put idx non-member) (&;update idx n.inc) - (&;at idx) (default (undefined)) - (n.= (n.inc non-member)))) - - (assert "Can safely transform to/from lists." - (|> sample &;to-list &;from-list (&/= sample))) - - (assert "Can identify members of a vector." - (and (not (&;member? number;Eq sample non-member)) - (&;member? number;Eq (&;add non-member sample) non-member))) - - (assert "Can fold over elements of vector." - (n.= (List/fold n.+ +0 (&;to-list sample)) - (&/fold n.+ +0 sample))) - - (assert "Functor goes over every element." - (let [there (&/map n.inc sample) - back-again (&/map n.dec there)] - (and (not (&/= sample there)) - (&/= sample back-again)))) - - (assert "Applicative allows you to create singleton vectors, and apply vectors of functions to vectors of values." - (and (&/= (&;vector non-member) (&/wrap non-member)) - (&/= (&/map n.inc sample) (&/apply (&/wrap n.inc) sample)))) - - (assert "Vector concatenation is a monad." - (&/= (&/append sample other-sample) - (&/join (&;vector sample other-sample)))) - )) diff --git a/stdlib/test/test/lux/data/sum.lux b/stdlib/test/test/lux/data/sum.lux index 2ff10dbf5..abb00dbfa 100644 --- a/stdlib/test/test/lux/data/sum.lux +++ b/stdlib/test/test/lux/data/sum.lux @@ -5,12 +5,12 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data sum [text "Text/" Monoid] [number] - (struct [list])) + (coll [list])) (codata function) pipe) lux/test) diff --git a/stdlib/test/test/lux/data/text.lux b/stdlib/test/test/lux/data/text.lux index 14f58aedb..fc1d17e64 100644 --- a/stdlib/test/test/lux/data/text.lux +++ b/stdlib/test/test/lux/data/text.lux @@ -5,13 +5,13 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data ["&" text] [char] text/format [number] - (struct [list])) + (coll [list])) (codata function) ["R" random] pipe) @@ -34,7 +34,7 @@ idx (:: @ map (n.% size) R;nat) sample (R;text size)] (assert "" (|> sample - (&;at idx) + (&;nth idx) (case> (^=> (#;Some char) [(char;as-text char) char'] [[(&;index-of char' sample) @@ -132,20 +132,21 @@ ))) (test: "Structures" - ($_ seq - (assert "" (:: &;Ord < "bcd" "abc")) - (assert "" (not (:: &;Ord < "abc" "abc"))) - (assert "" (not (:: &;Ord < "abc" "bcd"))) - (assert "" (:: &;Ord <= "bcd" "abc")) - (assert "" (:: &;Ord <= "abc" "abc")) - (assert "" (not (:: &;Ord <= "abc" "bcd"))) - (assert "" (:: &;Ord > "abc" "bcd")) - (assert "" (not (:: &;Ord > "abc" "abc"))) - (assert "" (not (:: &;Ord > "bcd" "abc"))) - (assert "" (:: &;Ord >= "abc" "bcd")) - (assert "" (:: &;Ord >= "abc" "abc")) - (assert "" (not (:: &;Ord >= "bcd" "abc"))) - )) + (let [(^open "&/") &;Ord] + ($_ seq + (assert "" (&/< "bcd" "abc")) + (assert "" (not (&/< "abc" "abc"))) + (assert "" (not (&/< "abc" "bcd"))) + (assert "" (&/<= "bcd" "abc")) + (assert "" (&/<= "abc" "abc")) + (assert "" (not (&/<= "abc" "bcd"))) + (assert "" (&/> "abc" "bcd")) + (assert "" (not (&/> "abc" "abc"))) + (assert "" (not (&/> "bcd" "abc"))) + (assert "" (&/>= "abc" "bcd")) + (assert "" (&/>= "abc" "abc")) + (assert "" (not (&/>= "bcd" "abc"))) + ))) (test: "Codec" [size bounded-size diff --git a/stdlib/test/test/lux/data/text/format.lux b/stdlib/test/test/lux/data/text/format.lux index 12516a9ca..7ec6baf98 100644 --- a/stdlib/test/test/lux/data/text/format.lux +++ b/stdlib/test/test/lux/data/text/format.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data text/format [text] diff --git a/stdlib/test/test/lux/effect.lux b/stdlib/test/test/lux/effect.lux new file mode 100644 index 000000000..275e1e66a --- /dev/null +++ b/stdlib/test/test/lux/effect.lux @@ -0,0 +1,77 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux [io "IO/" Monad] + (control monad + functor) + (data [text] + text/format) + [macro] + ["R" random] + pipe + effect) + lux/test) + +(do-template [ ] + [(effect: + ( [Nat Text] Bool) + ( Nat))] + + [EffA opA fieldA] + [EffB opB fieldB] + [EffC opC fieldC] + ) + +(do-template [ ] + [(handler: _ + (=> [io;IO io;Monad]) + (def: ( size sample) + (IO/wrap ( size (text;size sample)))) + + (def: (IO/wrap )))] + + [EffA opA n.< fieldA +10] + [EffB opB n.= fieldB +20] + [EffC opC n.> fieldC +30] + ) + +(type: EffABC (|E EffA EffB EffC)) + +(def: Functor + (Functor EffABC) + (|F Functor Functor Functor)) + +(def: Handler + (Handler EffABC io;IO) + (|H io;Monad + Handler Handler Handler)) + +## [Tests] +(test: "Algebraic effects" + (let% [ (do-template [ ] + [(io;run (with-handler Handler + (doE Functor + [] + (lift ( "YOLO"))))) + (n.= (io;run (with-handler Handler + (doE Functor + [] + (lift )))))] + + [opA +10 fieldA +10] + [opB +4 fieldB +20] + [opC +2 fieldC +30])] + (assert "Can handle effects using handlers." + (and + + (n.= +60 (io;run (with-handler Handler + (doE Functor + [a (lift fieldA) + b (lift fieldB) + c (lift fieldC)] + (wrap ($_ n.+ a b c)))))) + )))) diff --git a/stdlib/test/test/lux/host.lux b/stdlib/test/test/lux/host.lux index 03ed87772..61f6aa7ec 100644 --- a/stdlib/test/test/lux/host.lux +++ b/stdlib/test/test/lux/host.lux @@ -5,13 +5,13 @@ (;module: lux - (lux (control monad) + (lux [io] + (control monad) (data text/format [number] [product] [text "Text/" Eq]) - (codata function - [io]) + (codata function) ["&" host #+ jvm-import class: interface: object] ["R" random] pipe) diff --git a/stdlib/test/test/lux/io.lux b/stdlib/test/test/lux/io.lux new file mode 100644 index 000000000..0d7a3e5a9 --- /dev/null +++ b/stdlib/test/test/lux/io.lux @@ -0,0 +1,27 @@ +## Copyright (c) Eduardo Julian. All rights reserved. +## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +## If a copy of the MPL was not distributed with this file, +## You can obtain one at http://mozilla.org/MPL/2.0/. + +(;module: + lux + (lux ["&" io] + (control monad) + (data [text "Text/" Monoid Eq] + text/format + [number]) + (codata function)) + lux/test) + +(test: "I/O" + ($_ seq + (assert "" (Text/= "YOLO" (&;run (&;io "YOLO")))) + (assert "" (i.= 11 (&;run (:: &;Functor map i.inc (&;io 10))))) + (assert "" (i.= 10 (&;run (:: &;Applicative wrap 10)))) + (assert "" (i.= 30 (&;run (let [(^open "&/") &;Applicative] + (&/apply (&/wrap (i.+ 10)) (&/wrap 20)))))) + (assert "" (i.= 30 (&;run (do &;Monad + [f (wrap i.+) + x (wrap 10) + y (wrap 20)] + (wrap (f x y)))))))) diff --git a/stdlib/test/test/lux/lexer.lux b/stdlib/test/test/lux/lexer.lux index 3c459ab8e..f08841a93 100644 --- a/stdlib/test/test/lux/lexer.lux +++ b/stdlib/test/test/lux/lexer.lux @@ -6,12 +6,12 @@ (;module: lux (lux (control monad) - (codata [io]) + [io] (data [error #- fail] [text "T/" Eq] text/format [char "C/" Eq] - (struct [list])) + (coll [list])) ["R" random] pipe ["&" lexer]) diff --git a/stdlib/test/test/lux/lexer/regex.lux b/stdlib/test/test/lux/lexer/regex.lux index 4a9f01c27..fd8e563ec 100644 --- a/stdlib/test/test/lux/lexer/regex.lux +++ b/stdlib/test/test/lux/lexer/regex.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [error #- fail] [product] diff --git a/stdlib/test/test/lux/macro/ast.lux b/stdlib/test/test/lux/macro/ast.lux index 61127bef7..9c010c1e4 100644 --- a/stdlib/test/test/lux/macro/ast.lux +++ b/stdlib/test/test/lux/macro/ast.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (codata function) (control monad) (data [text "T/" Eq] diff --git a/stdlib/test/test/lux/macro/poly/eq.lux b/stdlib/test/test/lux/macro/poly/eq.lux index 4f4c296d6..ed34369a9 100644 --- a/stdlib/test/test/lux/macro/poly/eq.lux +++ b/stdlib/test/test/lux/macro/poly/eq.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad eq) (data text/format diff --git a/stdlib/test/test/lux/macro/poly/functor.lux b/stdlib/test/test/lux/macro/poly/functor.lux index 23d42c78d..ca269e15e 100644 --- a/stdlib/test/test/lux/macro/poly/functor.lux +++ b/stdlib/test/test/lux/macro/poly/functor.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad [functor] eq) diff --git a/stdlib/test/test/lux/macro/poly/text-encoder.lux b/stdlib/test/test/lux/macro/poly/text-encoder.lux index 154d9ab10..ef9474f42 100644 --- a/stdlib/test/test/lux/macro/poly/text-encoder.lux +++ b/stdlib/test/test/lux/macro/poly/text-encoder.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad eq) (data text/format diff --git a/stdlib/test/test/lux/macro/syntax.lux b/stdlib/test/test/lux/macro/syntax.lux index 2755bbf8e..1d96883de 100644 --- a/stdlib/test/test/lux/macro/syntax.lux +++ b/stdlib/test/test/lux/macro/syntax.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad eq) (data [text "Text/" Monoid] @@ -73,8 +73,8 @@ (let% [ (do-template [ ] [(assert (and (is? (list ( ))) - (found? (s;sample? ( )) (list ( ))) - (enforced? (s;sample! ( )) (list ( )))))] + (found? (s;this? ( )) (list ( ))) + (enforced? (s;this! ( )) (list ( )))))] ["Can parse Bool syntax." true ast;bool bool;Eq s;bool] ["Can parse Nat syntax." +123 ast;nat number;Eq s;nat] @@ -252,8 +252,8 @@ (assert "Can parse while taking separators into account." (and (match (list 123 456 789) (s;run (list (ast;int 123) (ast;text "YOLO") (ast;int 456) (ast;text "YOLO") (ast;int 789)) - (s;sep-by (s;sample! (' "YOLO")) s;int))) + (s;sep-by (s;this! (' "YOLO")) s;int))) (match (list 123 456) (s;run (list (ast;int 123) (ast;text "YOLO") (ast;int 456) (ast;int 789)) - (s;sep-by (s;sample! (' "YOLO")) s;int))))) + (s;sep-by (s;this! (' "YOLO")) s;int))))) )) diff --git a/stdlib/test/test/lux/math.lux b/stdlib/test/test/lux/math.lux index 1ffba0aa2..f16517d85 100644 --- a/stdlib/test/test/lux/math.lux +++ b/stdlib/test/test/lux/math.lux @@ -5,13 +5,13 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [text "Text/" Monoid] text/format [bool "b/" Eq] [number "r/" Number] - (struct [list "List/" Fold Functor]) + (coll [list "List/" Fold Functor]) [product]) (codata function) ["R" random] diff --git a/stdlib/test/test/lux/math/complex.lux b/stdlib/test/test/lux/math/complex.lux index f9743e9ec..0fb327425 100644 --- a/stdlib/test/test/lux/math/complex.lux +++ b/stdlib/test/test/lux/math/complex.lux @@ -5,13 +5,13 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [text "Text/" Monoid] text/format [bool "b/" Eq] [number "r/" Number] - (struct [list "List/" Fold Functor]) + (coll [list "List/" Fold Functor]) [product]) (codata function) [math] diff --git a/stdlib/test/test/lux/math/logic/continuous.lux b/stdlib/test/test/lux/math/logic/continuous.lux index 883d54a06..57905a4d7 100644 --- a/stdlib/test/test/lux/math/logic/continuous.lux +++ b/stdlib/test/test/lux/math/logic/continuous.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (codata function) ["R" random] diff --git a/stdlib/test/test/lux/math/ratio.lux b/stdlib/test/test/lux/math/ratio.lux index 0cdbf4f93..cd9c6138b 100644 --- a/stdlib/test/test/lux/math/ratio.lux +++ b/stdlib/test/test/lux/math/ratio.lux @@ -5,13 +5,13 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [text "Text/" Monoid] text/format [bool "b/" Eq] [number "r/" Number] - (struct [list "List/" Fold Functor]) + (coll [list "List/" Fold Functor]) [product]) (codata function) ["R" random] diff --git a/stdlib/test/test/lux/math/simple.lux b/stdlib/test/test/lux/math/simple.lux index 235723f25..0fc6ee2be 100644 --- a/stdlib/test/test/lux/math/simple.lux +++ b/stdlib/test/test/lux/math/simple.lux @@ -5,13 +5,13 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [text "Text/" Monoid] text/format [bool "b/" Eq] [number "r/" Number] - (struct [list "List/" Fold Functor]) + (coll [list "List/" Fold Functor]) [product]) (codata function) ["R" random] diff --git a/stdlib/test/test/lux/pipe.lux b/stdlib/test/test/lux/pipe.lux index 86f45079f..0fc95add2 100644 --- a/stdlib/test/test/lux/pipe.lux +++ b/stdlib/test/test/lux/pipe.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data text/format [number] diff --git a/stdlib/test/test/lux/type.lux b/stdlib/test/test/lux/type.lux index 1670f3146..081d9d444 100644 --- a/stdlib/test/test/lux/type.lux +++ b/stdlib/test/test/lux/type.lux @@ -5,13 +5,13 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [text "Text/" Monoid] text/format [number] maybe - (struct [list])) + (coll [list])) ["R" random] pipe ["&" type]) diff --git a/stdlib/test/test/lux/type/auto.lux b/stdlib/test/test/lux/type/auto.lux index fdc1ec51a..12b52292e 100644 --- a/stdlib/test/test/lux/type/auto.lux +++ b/stdlib/test/test/lux/type/auto.lux @@ -5,7 +5,7 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad functor [eq]) @@ -14,7 +14,7 @@ [number] [bool "B/" Eq] maybe - (struct [list])) + (coll [list])) ["R" random] pipe [type] diff --git a/stdlib/test/test/lux/type/check.lux b/stdlib/test/test/lux/type/check.lux index 2dadd92f2..e69bcfc45 100644 --- a/stdlib/test/test/lux/type/check.lux +++ b/stdlib/test/test/lux/type/check.lux @@ -5,13 +5,13 @@ (;module: lux - (lux (codata [io]) + (lux [io] (control monad) (data [text "Text/" Monoid Eq] text/format [number] maybe - (struct [list])) + (coll [list])) ["R" random] pipe [type] diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux index fdcf01457..d6a21cae4 100644 --- a/stdlib/test/tests.lux +++ b/stdlib/test/tests.lux @@ -6,27 +6,27 @@ (;module: lux (lux (control monad) - (codata [io]) + [io] (concurrency [promise]) [cli #+ program:] [test]) (test lux (lux ["_;" cli] ["_;" host] + ["_;" io] ["_;" pipe] ["_;" lexer] (lexer ["_;" regex]) - (codata ["_;" io] + (codata ["_;" cont] ["_;" env] ["_;" state] - ["_;" cont] - (struct ["_;" stream])) + (coll ["_;" stream])) (concurrency ["_;" actor] ["_;" atom] ["_;" frp] ["_;" promise] ["_;" stm]) - (control [effect]) + ["_;" effect] (data [bit] [bool] [char] @@ -41,15 +41,15 @@ [text] (error [exception]) (format [json]) - (struct [array] - [dict] - [list] - [queue] - [set] - [stack] - ## [vector] - (tree [rose] - [zipper])) + (coll [array] + [dict] + [list] + [queue] + [set] + [stack] + ## [vector] + (tree [rose] + [zipper])) (text [format]) ) ["_;" math] -- cgit v1.2.3