From 83f18eb967cfaa4f3403f58f3f80bc4945218cd8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 10 Jul 2018 20:42:57 -0400 Subject: - Re-named path "lux/data/coll/*" to "lux/data/collection/*". --- stdlib/source/lux.lux | 4 +- stdlib/source/lux/cli.lux | 2 +- stdlib/source/lux/concurrency/actor.lux | 2 +- stdlib/source/lux/concurrency/frp.lux | 2 +- stdlib/source/lux/concurrency/stm.lux | 2 +- stdlib/source/lux/control/comonad.lux | 4 +- stdlib/source/lux/control/concatenative.lux | 2 +- stdlib/source/lux/control/exception.lux | 2 +- stdlib/source/lux/control/monad/indexed.lux | 2 +- stdlib/source/lux/control/parser.lux | 2 +- stdlib/source/lux/control/pipe.lux | 2 +- stdlib/source/lux/control/predicate.lux | 2 +- stdlib/source/lux/control/region.lux | 2 +- stdlib/source/lux/data/coll/array.lux | 211 ------- stdlib/source/lux/data/coll/bits.lux | 164 ----- stdlib/source/lux/data/coll/dictionary.lux | 685 --------------------- stdlib/source/lux/data/coll/dictionary/ordered.lux | 569 ----------------- stdlib/source/lux/data/coll/dictionary/plist.lux | 62 -- stdlib/source/lux/data/coll/list.lux | 554 ----------------- stdlib/source/lux/data/coll/queue.lux | 78 --- stdlib/source/lux/data/coll/queue/priority.lux | 102 --- stdlib/source/lux/data/coll/row.lux | 437 ------------- stdlib/source/lux/data/coll/sequence.lux | 146 ----- stdlib/source/lux/data/coll/set.lux | 81 --- stdlib/source/lux/data/coll/set/ordered.lux | 86 --- stdlib/source/lux/data/coll/stack.lux | 42 -- stdlib/source/lux/data/coll/tree/finger.lux | 61 -- stdlib/source/lux/data/coll/tree/rose.lux | 73 --- stdlib/source/lux/data/coll/tree/rose/parser.lux | 50 -- stdlib/source/lux/data/coll/tree/rose/zipper.lux | 235 ------- stdlib/source/lux/data/collection/array.lux | 211 +++++++ stdlib/source/lux/data/collection/bits.lux | 164 +++++ stdlib/source/lux/data/collection/dictionary.lux | 685 +++++++++++++++++++++ .../lux/data/collection/dictionary/ordered.lux | 569 +++++++++++++++++ .../lux/data/collection/dictionary/plist.lux | 62 ++ stdlib/source/lux/data/collection/list.lux | 554 +++++++++++++++++ stdlib/source/lux/data/collection/queue.lux | 78 +++ .../source/lux/data/collection/queue/priority.lux | 102 +++ stdlib/source/lux/data/collection/row.lux | 437 +++++++++++++ stdlib/source/lux/data/collection/sequence.lux | 146 +++++ stdlib/source/lux/data/collection/set.lux | 81 +++ stdlib/source/lux/data/collection/set/ordered.lux | 86 +++ stdlib/source/lux/data/collection/stack.lux | 42 ++ stdlib/source/lux/data/collection/tree/finger.lux | 61 ++ stdlib/source/lux/data/collection/tree/rose.lux | 73 +++ .../lux/data/collection/tree/rose/parser.lux | 50 ++ .../lux/data/collection/tree/rose/zipper.lux | 235 +++++++ stdlib/source/lux/data/color.lux | 2 +- stdlib/source/lux/data/format/context.lux | 2 +- stdlib/source/lux/data/format/css.lux | 2 +- stdlib/source/lux/data/format/html.lux | 2 +- stdlib/source/lux/data/format/json.lux | 6 +- stdlib/source/lux/data/format/xml.lux | 4 +- stdlib/source/lux/data/number/complex.lux | 2 +- stdlib/source/lux/data/text.lux | 2 +- stdlib/source/lux/data/text/buffer.lux | 2 +- stdlib/source/lux/data/text/format.lux | 2 +- stdlib/source/lux/data/text/lexer.lux | 2 +- stdlib/source/lux/data/text/regex.lux | 2 +- stdlib/source/lux/data/text/unicode.lux | 4 +- stdlib/source/lux/host.js.lux | 2 +- stdlib/source/lux/host.jvm.lux | 2 +- stdlib/source/lux/io.lux | 2 +- stdlib/source/lux/lang/compiler/analysis.lux | 2 +- stdlib/source/lux/lang/compiler/analysis/case.lux | 2 +- .../lux/lang/compiler/analysis/case/coverage.lux | 4 +- .../source/lux/lang/compiler/analysis/function.lux | 2 +- .../lux/lang/compiler/analysis/inference.lux | 2 +- .../lux/lang/compiler/analysis/structure.lux | 4 +- .../source/lux/lang/compiler/default/repl/type.lux | 2 +- stdlib/source/lux/lang/compiler/extension.lux | 2 +- .../lux/lang/compiler/extension/analysis.lux | 4 +- .../lang/compiler/extension/analysis/common.lux | 6 +- .../lang/compiler/extension/analysis/host.jvm.lux | 6 +- .../source/lux/lang/compiler/extension/bundle.lux | 4 +- .../lux/lang/compiler/extension/synthesis.lux | 2 +- .../lux/lang/compiler/extension/translation.lux | 2 +- stdlib/source/lux/lang/compiler/meta/archive.lux | 2 +- stdlib/source/lux/lang/compiler/meta/cache.lux | 6 +- .../lux/lang/compiler/meta/cache/dependency.lux | 4 +- stdlib/source/lux/lang/compiler/synthesis.lux | 2 +- stdlib/source/lux/lang/compiler/synthesis/case.lux | 2 +- .../lux/lang/compiler/synthesis/expression.lux | 4 +- .../lux/lang/compiler/synthesis/function.lux | 4 +- stdlib/source/lux/lang/compiler/synthesis/loop.lux | 2 +- stdlib/source/lux/lang/compiler/translation.lux | 4 +- .../lang/compiler/translation/scheme/case.jvm.lux | 10 +- .../compiler/translation/scheme/extension.jvm.lux | 2 +- .../translation/scheme/extension/common.jvm.lux | 4 +- .../compiler/translation/scheme/function.jvm.lux | 2 +- .../lang/compiler/translation/scheme/loop.jvm.lux | 2 +- .../compiler/translation/scheme/runtime.jvm.lux | 2 +- stdlib/source/lux/lang/host/scheme.lux | 2 +- stdlib/source/lux/lang/module.lux | 4 +- stdlib/source/lux/lang/scope.lux | 4 +- stdlib/source/lux/lang/syntax.lux | 4 +- stdlib/source/lux/lang/type.lux | 2 +- stdlib/source/lux/lang/type/check.lux | 4 +- stdlib/source/lux/macro.lux | 2 +- stdlib/source/lux/macro/code.lux | 2 +- stdlib/source/lux/macro/poly.lux | 4 +- stdlib/source/lux/macro/poly/equivalence.lux | 14 +- stdlib/source/lux/macro/poly/functor.lux | 2 +- stdlib/source/lux/macro/poly/json.lux | 6 +- stdlib/source/lux/macro/syntax.lux | 2 +- stdlib/source/lux/macro/syntax/common/reader.lux | 2 +- stdlib/source/lux/macro/syntax/common/writer.lux | 2 +- stdlib/source/lux/math.lux | 2 +- stdlib/source/lux/math/logic/fuzzy.lux | 7 +- stdlib/source/lux/math/random.lux | 16 +- stdlib/source/lux/test.lux | 6 +- stdlib/source/lux/time/date.lux | 2 +- stdlib/source/lux/time/instant.lux | 4 +- stdlib/source/lux/type/abstract.lux | 2 +- stdlib/source/lux/type/implicit.lux | 4 +- stdlib/source/lux/type/object/interface.lux | 4 +- stdlib/source/lux/type/object/protocol.lux | 2 +- stdlib/source/lux/type/resource.lux | 8 +- stdlib/source/lux/world/env.jvm.lux | 2 +- stdlib/source/lux/world/file.lux | 2 +- stdlib/source/lux/world/net/udp.jvm.lux | 2 +- 121 files changed, 3777 insertions(+), 3780 deletions(-) delete mode 100644 stdlib/source/lux/data/coll/array.lux delete mode 100644 stdlib/source/lux/data/coll/bits.lux delete mode 100644 stdlib/source/lux/data/coll/dictionary.lux delete mode 100644 stdlib/source/lux/data/coll/dictionary/ordered.lux delete mode 100644 stdlib/source/lux/data/coll/dictionary/plist.lux delete mode 100644 stdlib/source/lux/data/coll/list.lux delete mode 100644 stdlib/source/lux/data/coll/queue.lux delete mode 100644 stdlib/source/lux/data/coll/queue/priority.lux delete mode 100644 stdlib/source/lux/data/coll/row.lux delete mode 100644 stdlib/source/lux/data/coll/sequence.lux delete mode 100644 stdlib/source/lux/data/coll/set.lux delete mode 100644 stdlib/source/lux/data/coll/set/ordered.lux delete mode 100644 stdlib/source/lux/data/coll/stack.lux delete mode 100644 stdlib/source/lux/data/coll/tree/finger.lux delete mode 100644 stdlib/source/lux/data/coll/tree/rose.lux delete mode 100644 stdlib/source/lux/data/coll/tree/rose/parser.lux delete mode 100644 stdlib/source/lux/data/coll/tree/rose/zipper.lux create mode 100644 stdlib/source/lux/data/collection/array.lux create mode 100644 stdlib/source/lux/data/collection/bits.lux create mode 100644 stdlib/source/lux/data/collection/dictionary.lux create mode 100644 stdlib/source/lux/data/collection/dictionary/ordered.lux create mode 100644 stdlib/source/lux/data/collection/dictionary/plist.lux create mode 100644 stdlib/source/lux/data/collection/list.lux create mode 100644 stdlib/source/lux/data/collection/queue.lux create mode 100644 stdlib/source/lux/data/collection/queue/priority.lux create mode 100644 stdlib/source/lux/data/collection/row.lux create mode 100644 stdlib/source/lux/data/collection/sequence.lux create mode 100644 stdlib/source/lux/data/collection/set.lux create mode 100644 stdlib/source/lux/data/collection/set/ordered.lux create mode 100644 stdlib/source/lux/data/collection/stack.lux create mode 100644 stdlib/source/lux/data/collection/tree/finger.lux create mode 100644 stdlib/source/lux/data/collection/tree/rose.lux create mode 100644 stdlib/source/lux/data/collection/tree/rose/parser.lux create mode 100644 stdlib/source/lux/data/collection/tree/rose/zipper.lux (limited to 'stdlib/source') diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index 138d965c4..71cdbe716 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -4948,7 +4948,7 @@ lux (lux (control (monad #as M #refer #all)) (data (text #open (\"text/\" Monoid)) - (coll (list #open (\"list/\" Monad))) + (collection (list #open (\"list/\" Monad))) maybe (ident #open (\"ident/\" Codec))) meta @@ -4959,7 +4959,7 @@ lux (lux (control [\"M\" monad #*]) (data [text \"text/\" Monoid] - (coll [list \"list/\" Monad]) + (collection [list \"list/\" Monad]) maybe [ident \"ident/\" Codec]) meta diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index c2e8e2c0f..ac04ce673 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -2,7 +2,7 @@ lux (lux (control monad ["p" parser]) - (data (coll [list "list/" Monoid Monad]) + (data (collection [list "list/" Monoid Monad]) [text "text/" Equivalence] text/format ["E" error]) diff --git a/stdlib/source/lux/concurrency/actor.lux b/stdlib/source/lux/concurrency/actor.lux index ad3bccfdc..187fe54eb 100644 --- a/stdlib/source/lux/concurrency/actor.lux +++ b/stdlib/source/lux/concurrency/actor.lux @@ -7,7 +7,7 @@ (data [product] ["e" error] text/format - (coll [list "list/" Monoid Monad Fold])) + (collection [list "list/" Monoid Monad Fold])) [macro #+ with-gensyms Monad] (macro [code] ["s" syntax #+ syntax: Syntax] diff --git a/stdlib/source/lux/concurrency/frp.lux b/stdlib/source/lux/concurrency/frp.lux index dda469f62..8a1cff374 100644 --- a/stdlib/source/lux/concurrency/frp.lux +++ b/stdlib/source/lux/concurrency/frp.lux @@ -4,7 +4,7 @@ [apply #+ Apply] [monad #+ do Monad]) [io #+ IO io] - (data (coll [list "list/" Monoid])) + (data (collection [list "list/" Monoid])) (type abstract)) (// [atom #+ Atom atom] [promise #+ Promise])) diff --git a/stdlib/source/lux/concurrency/stm.lux b/stdlib/source/lux/concurrency/stm.lux index eddaabf2b..26bcf4c36 100644 --- a/stdlib/source/lux/concurrency/stm.lux +++ b/stdlib/source/lux/concurrency/stm.lux @@ -6,7 +6,7 @@ [io #+ IO io] (data [product] [maybe] - (coll [list "list/" Functor Fold])) + (collection [list "list/" Functor Fold])) (concurrency [atom #+ Atom atom] [promise #+ Promise promise] [frp "frp/" Functor]) diff --git a/stdlib/source/lux/control/comonad.lux b/stdlib/source/lux/control/comonad.lux index f60a34c74..557cd3b7b 100644 --- a/stdlib/source/lux/control/comonad.lux +++ b/stdlib/source/lux/control/comonad.lux @@ -1,7 +1,7 @@ (.module: lux - ["F" //functor] - (lux/data/coll [list "list/" Fold])) + (lux (data (collection [list "list/" Fold]))) + ["F" //functor]) ## [Signatures] (signature: #export (CoMonad w) diff --git a/stdlib/source/lux/control/concatenative.lux b/stdlib/source/lux/control/concatenative.lux index fb1e903b2..75c69baf9 100644 --- a/stdlib/source/lux/control/concatenative.lux +++ b/stdlib/source/lux/control/concatenative.lux @@ -8,7 +8,7 @@ (data [text] text/format [maybe "maybe/" Monad] - (coll [list "list/" Fold Functor])) + (collection [list "list/" Fold Functor])) [macro #+ with-gensyms Monad] (macro [code] ["s" syntax #+ syntax:] diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 80ddeed35..bf6859dcd 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -6,7 +6,7 @@ [maybe] [product] [text "text/" Monoid] - (coll [list "list/" Functor Fold])) + (collection [list "list/" Functor Fold])) [macro] (macro [code] ["s" syntax #+ syntax: Syntax] diff --git a/stdlib/source/lux/control/monad/indexed.lux b/stdlib/source/lux/control/monad/indexed.lux index 455334760..4967a016a 100644 --- a/stdlib/source/lux/control/monad/indexed.lux +++ b/stdlib/source/lux/control/monad/indexed.lux @@ -2,7 +2,7 @@ lux (lux (control [monad] ["p" parser]) - (data (coll [list "list/" Functor Fold])) + (data (collection [list "list/" Functor Fold])) [macro] (macro ["s" syntax #+ Syntax syntax:]))) diff --git a/stdlib/source/lux/control/parser.lux b/stdlib/source/lux/control/parser.lux index 1ad76a50a..6bdc5877c 100644 --- a/stdlib/source/lux/control/parser.lux +++ b/stdlib/source/lux/control/parser.lux @@ -4,7 +4,7 @@ [apply #+ Apply] [monad #+ do Monad] [codec]) - (data (coll [list "list/" Functor Monoid]) + (data (collection [list "list/" Functor Monoid]) [product] ["e" error #+ Error]))) diff --git a/stdlib/source/lux/control/pipe.lux b/stdlib/source/lux/control/pipe.lux index de058307b..aae6a7db5 100644 --- a/stdlib/source/lux/control/pipe.lux +++ b/stdlib/source/lux/control/pipe.lux @@ -3,7 +3,7 @@ (lux (control [monad #+ do] ["p" parser]) (data ["e" error] - (coll [list #+ "list/" Fold Monad])) + (collection [list #+ "list/" Fold Monad])) [macro #+ with-gensyms] (macro ["s" syntax #+ syntax: Syntax] [code]) diff --git a/stdlib/source/lux/control/predicate.lux b/stdlib/source/lux/control/predicate.lux index d7abc4139..e9ddf5ff4 100644 --- a/stdlib/source/lux/control/predicate.lux +++ b/stdlib/source/lux/control/predicate.lux @@ -1,7 +1,7 @@ (.module: lux (lux (control [monoid #+ Monoid]) - (data (coll [set #+ Set])) + (data (collection [set #+ Set])) [function])) (type: #export (Predicate a) diff --git a/stdlib/source/lux/control/region.lux b/stdlib/source/lux/control/region.lux index d35495d93..09db5b5a0 100644 --- a/stdlib/source/lux/control/region.lux +++ b/stdlib/source/lux/control/region.lux @@ -6,7 +6,7 @@ ["ex" exception #+ Exception exception:]) (data ["e" error #+ Error] text/format - (coll [list "list/" Fold])))) + (collection [list "list/" Fold])))) (type: (Cleaner r m) (-> r (m (Error Any)))) diff --git a/stdlib/source/lux/data/coll/array.lux b/stdlib/source/lux/data/coll/array.lux deleted file mode 100644 index 842acec39..000000000 --- a/stdlib/source/lux/data/coll/array.lux +++ /dev/null @@ -1,211 +0,0 @@ -(.module: - lux - (lux (control [monoid #+ Monoid] - [functor #+ Functor] - [equivalence #+ Equivalence] - fold) - (data (coll [list "list/" Fold]) - [product]) - )) - -(def: #export (new size) - (All [a] (-> Nat (Array a))) - ("lux array new" size)) - -(def: #export (size xs) - (All [a] (-> (Array a) Nat)) - ("lux array size" xs)) - -(def: #export (read i xs) - (All [a] - (-> Nat (Array a) (Maybe a))) - ("lux array get" xs i)) - -(def: #export (write i x xs) - (All [a] - (-> Nat a (Array a) (Array a))) - ("lux array put" xs i x)) - -(def: #export (delete i xs) - (All [a] - (-> Nat (Array a) (Array a))) - ("lux 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 (function (_ offset target) - (case (read (n/+ offset src-start) src-array) - #.None - target - - (#.Some value) - (write (n/+ offset dest-start) value target))) - dest-array - (list.n/range +0 (dec length))))) - -(def: #export (occupied array) - {#.doc "Finds out how many cells in an array are occupied."} - (All [a] (-> (Array a) Nat)) - (list/fold (function (_ idx count) - (case (read idx array) - #.None - count - - (#.Some _) - (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 (function (_ idx xs') - (case (read idx xs) - #.None - xs' - - (#.Some x) - (if (p x) - xs' - (delete 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 (read idx xs) - #.None - (recur (inc idx)) - - (#.Some x) - (if (p x) - (#.Some x) - (recur (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 (read idx xs) - #.None - (recur (inc idx)) - - (#.Some x) - (if (p idx x) - (#.Some [idx x]) - (recur (inc idx)))) - #.None)))) - -(def: #export (clone xs) - (All [a] (-> (Array a) (Array a))) - (let [arr-size (size xs)] - (list/fold (function (_ idx ys) - (case (read idx xs) - #.None - ys - - (#.Some x) - (write 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 (function (_ x [idx arr]) - [(inc idx) (write idx x arr)]) - [+0 (new (list.size xs))] - xs))) - -(def: underflow Nat (dec +0)) - -(def: #export (to-list array) - (All [a] (-> (Array a) (List a))) - (loop [idx (dec (size array)) - output #.Nil] - (if (n/= underflow idx) - output - (recur (dec idx) - (case (read idx array) - (#.Some head) - (#.Cons head output) - - #.None - output))))) - -(structure: #export (Equivalence Equivalence) - (All [a] (-> (Equivalence a) (Equivalence (Array a)))) - (def: (= xs ys) - (let [sxs (size xs) - sxy (size ys)] - (and (n/= sxy sxs) - (list/fold (function (_ idx prev) - (and prev - (case [(read idx xs) (read idx ys)] - [#.None #.None] - true - - [(#.Some x) (#.Some y)] - (:: Equivalence = x y) - - _ - false))) - true - (list.n/range +0 (dec sxs))))) - )) - -(structure: #export Monoid (All [a] (Monoid (Array a))) - (def: identity (new +0)) - - (def: (compose xs ys) - (let [sxs (size xs) - sxy (size ys)] - (|> (new (n/+ sxy sxs)) - (copy sxs +0 xs +0) - (copy sxy +0 ys sxs))))) - -(structure: #export _ (Functor Array) - (def: (map f ma) - (let [arr-size (size ma)] - (if (n/= +0 arr-size) - (new arr-size) - (list/fold (function (_ idx mb) - (case (read idx ma) - #.None - mb - - (#.Some x) - (write idx (f x) mb))) - (new arr-size) - (list.n/range +0 (dec arr-size))) - )))) - -(structure: #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 (read idx xs) - #.None - (recur so-far (inc idx)) - - (#.Some value) - (recur (f value so-far) (inc idx))) - so-far))))) diff --git a/stdlib/source/lux/data/coll/bits.lux b/stdlib/source/lux/data/coll/bits.lux deleted file mode 100644 index 426f830d2..000000000 --- a/stdlib/source/lux/data/coll/bits.lux +++ /dev/null @@ -1,164 +0,0 @@ -(.module: - [lux #- not and or] - (lux (control [equivalence #+ Equivalence] - pipe) - (data [maybe] - [bit] - (coll [array "array/" Fold]) - text/format))) - -(type: #export Chunk I64) - -(def: #export chunk-size bit.width) - -(type: #export Bits - (Array Chunk)) - -(def: empty-chunk Chunk (.i64 +0)) - -(def: #export empty - Bits - (array.new +0)) - -(def: #export (size bits) - (-> Bits Nat) - (array/fold (function (_ chunk total) - (|> chunk bit.count (n/+ total))) - +0 - bits)) - -(def: #export (capacity bits) - (-> Bits Nat) - (|> bits array.size (n/* chunk-size))) - -(def: #export empty? - (-> Bits Bool) - (|>> size (n/= +0))) - -(def: #export (get index bits) - (-> Nat Bits Bool) - (let [[chunk-index bit-index] (n//% chunk-size index)] - (.and (n/< (array.size bits) chunk-index) - (|> (array.read chunk-index bits) - (maybe.default empty-chunk) - (bit.set? bit-index))))) - -(def: (chunk idx bits) - (-> Nat Bits Chunk) - (if (n/< (array.size bits) idx) - (|> bits (array.read idx) (maybe.default empty-chunk)) - empty-chunk)) - -(do-template [ ] - [(def: #export ( index input) - (-> Nat Bits Bits) - (let [[chunk-index bit-index] (n//% chunk-size index)] - (loop [size|output (n/max (inc chunk-index) - (array.size input)) - output ..empty] - (let [idx|output (dec size|output)] - (if (n/> +0 size|output) - (case (|> (..chunk idx|output input) - (cond> [(new> (n/= chunk-index idx|output))] - [( bit-index)] - - ## else - []) - .nat) - +0 - ## TODO: Remove 'no-op' once new-luxc is the official compiler. - (let [no-op (recur (dec size|output) output)] - no-op) - - chunk - (|> (if (is? ..empty output) - (: Bits (array.new size|output)) - output) - (array.write idx|output (.i64 chunk)) - (recur (dec size|output)))) - output)))))] - - [set bit.set] - [clear bit.clear] - [flip bit.flip] - ) - -(def: #export (intersects? reference sample) - (-> Bits Bits Bool) - (let [chunks (n/min (array.size reference) - (array.size sample))] - (loop [idx +0] - (if (n/< chunks idx) - (.or (|> (..chunk idx sample) - (bit.and (..chunk idx reference)) - ("lux i64 =" empty-chunk) - .not) - (recur (inc idx))) - false)))) - -(def: #export (not input) - (-> Bits Bits) - (case (array.size input) - +0 - ..empty - - size|output - (loop [size|output size|output - output ..empty] - (let [idx (dec size|output)] - (case (|> input (..chunk idx) bit.not .nat) - +0 - (recur (dec size|output) output) - - chunk - (if (n/> +0 size|output) - (|> (if (is? ..empty output) - (: Bits (array.new size|output)) - output) - (array.write idx (.i64 chunk)) - (recur (dec size|output))) - output)))))) - -(do-template [ ] - [(def: #export ( param subject) - (-> Bits Bits Bits) - (case (n/max (array.size param) - (array.size subject)) - +0 - ..empty - - size|output - (loop [size|output size|output - output ..empty] - (let [idx (dec size|output)] - (if (n/> +0 size|output) - (case (|> (..chunk idx subject) - ( (..chunk idx param)) - .nat) - +0 - (recur (dec size|output) output) - - chunk - (|> (if (is? ..empty output) - (: Bits (array.new size|output)) - output) - (array.write idx (.i64 chunk)) - (recur (dec size|output)))) - output)))))] - - [and bit.and] - [or bit.or] - [xor bit.xor] - ) - -(structure: #export _ (Equivalence Bits) - (def: (= reference sample) - (let [size (n/max (array.size reference) - (array.size sample))] - (loop [idx +0] - (if (n/< size idx) - (.and ("lux i64 =" - (..chunk idx reference) - (..chunk idx sample)) - (recur (inc idx))) - true))))) diff --git a/stdlib/source/lux/data/coll/dictionary.lux b/stdlib/source/lux/data/coll/dictionary.lux deleted file mode 100644 index e971228bb..000000000 --- a/stdlib/source/lux/data/coll/dictionary.lux +++ /dev/null @@ -1,685 +0,0 @@ -(.module: - lux - (lux (control hash - [equivalence #+ Equivalence]) - (data [maybe] - (coll [list "list/" Fold Functor Monoid] - [array "array/" Functor Fold]) - [bit] - [product] - [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 -## Dictionaries. -(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.left-shift (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.left-shift (n/- +1 branching-exponent) +1)) - -## The size of hierarchy-nodes, which is 2^(branching-exponent). -(def: hierarchy-nodes-size - Nat - (bit.left-shift 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.new (inc old-size)) - (array.copy idx +0 old-array +0) - (array.write idx value) - (array.copy (n/- idx old-size) idx old-array (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.write 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.delete 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 (dec (array.size array))] - (|> (array.new new-size) - (array.copy idx +0 array +0) - (array.copy (n/- idx new-size) (inc idx) array idx)))) - -## Given a top-limit for indices, produces all indices in [0, R). -(def: indices-for - (-> Nat (List Index)) - (|>> 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 (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.and hierarchy-mask - (bit.logical-right-shift level hash))) - -## A mechanism to go from indices to bit-positions. -(def: (->bit-position index) - (-> Index BitPosition) - (bit.left-shift 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.and 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.or bit bitmap)) - -(def: unset-bit-position - (-> BitPosition BitMap BitMap) - bit.xor) - -## 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) - 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.and (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))) - (:: maybe.Monad map product.left - (array.find+ (function (_ 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 (function (_ idx [insertion-idx node]) - (let [[bitmap base] node] - (case (array.read idx h-array) - #.None [insertion-idx node] - (#.Some sub-node) (if (n/= except-idx idx) - [insertion-idx node] - [(inc insertion-idx) - [(set-bit-position (->bit-position idx) bitmap) - (array.write insertion-idx (#.Left sub-node) base)]]) - ))) - [+0 [clean-bitmap - (array.new (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: hierarchy-indices (List Index) (indices-for hierarchy-nodes-size)) - -(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 (function (_ hierarchy-idx (^@ default [base-idx h-array])) - (if (bit-position-is-set? (->bit-position hierarchy-idx) - bitmap) - [(inc base-idx) - (case (array.read base-idx base) - (#.Some (#.Left sub-node)) - (array.write hierarchy-idx sub-node h-array) - - (#.Some (#.Right [key' val'])) - (array.write hierarchy-idx - (put' (level-up level) (:: Hash hash key') key' val' Hash empty) - h-array) - - #.None - (undefined))] - default)) - [+0 - (array.new hierarchy-nodes-size)] - hierarchy-indices))) - -## 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 (~~ (static ..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] (case (array.read idx hierarchy) - (#.Some sub-node) - [_size sub-node] - - _ - [(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.read 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.new +2) - (array.write +0 [key' val']) - (array.write +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 (inc base-count) - (|> (promote-base put' Hash level bitmap base) - (array.write (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) - (|> (array.new +1) - (array.write +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.read 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 (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.read 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 did not 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.read (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.read (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) - (:: maybe.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 (function (_ 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 (function (_ sub-node tail) (list/compose (entries' sub-node) tail)) - #.Nil - hierarchy) - - (#Base bitmap base) - (array/fold (function (_ branch tail) - (case branch - (#.Left sub-node) - (list/compose (entries' sub-node) tail) - - (#.Right [key' val']) - (#.Cons [key' val'] tail))) - #.Nil - base) - - (#Collisions hash colls) - (array/fold (function (_ [key' val'] tail) (#.Cons [key' val'] tail)) - #.Nil - colls))) - -## [Exports] -(type: #export (Dictionary 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) (Dictionary k v))) - {#hash Hash - #root empty}) - -(def: #export (put key val dict) - (All [k v] (-> k v (Dictionary k v) (Dictionary 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 (Dictionary k v) (Dictionary 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 (Dictionary k v) (Maybe v))) - (let [[Hash node] dict] - (get' root-level (:: Hash hash key) key Hash node))) - -(def: #export (contains? key dict) - (All [k v] (-> k (Dictionary k v) Bool)) - (case (get key dict) - #.None false - (#.Some _) true)) - -(def: #export (put~ key val dict) - {#.doc "Only puts the KV-pair if the key is not already present."} - (All [k v] (-> k v (Dictionary k v) (Dictionary k v))) - (if (contains? key dict) - dict - (put key val dict))) - -(def: #export (update key f dict) - {#.doc "Transforms the value located at key (if available), using the given function."} - (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v))) - (case (get key dict) - #.None - dict - - (#.Some val) - (put key (f val) dict))) - -(def: #export (update~ key default f dict) - {#.doc "Transforms the value located at key (if available), using the given function."} - (All [k v] (-> k v (-> v v) (Dictionary k v) (Dictionary k v))) - (put key - (f (maybe.default default - (get key dict))) - dict)) - -(def: #export size - (All [k v] (-> (Dictionary k v) Nat)) - (|>> product.right size')) - -(def: #export empty? - (All [k v] (-> (Dictionary k v) Bool)) - (|>> size (n/= +0))) - -(def: #export (entries dict) - (All [k v] (-> (Dictionary k v) (List [k v]))) - (entries' (product.right dict))) - -(def: #export (from-list Hash kvs) - (All [k v] (-> (Hash k) (List [k v]) (Dictionary k v))) - (list/fold (function (_ [k v] dict) - (put k v dict)) - (new Hash) - kvs)) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dictionary 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] (-> (Dictionary k v) (Dictionary k v) (Dictionary k v))) - (list/fold (function (_ [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) (Dictionary k v) (Dictionary k v) (Dictionary k v))) - (list/fold (function (_ [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 (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary k v))) - (let [[Hash _] dict] - (list/fold (function (_ key new-dict) - (case (get key dict) - #.None new-dict - (#.Some val) (put key val new-dict))) - (new Hash) - keys))) - -## [Structures] -(structure: #export (Equivalence Equivalence) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) - (def: (= test subject) - (and (n/= (size test) - (size subject)) - (list.every? (function (_ k) - (case [(get k test) (get k subject)] - [(#.Some tk) (#.Some sk)] - (:: Equivalence = tk sk) - - _ - false)) - (keys test))))) diff --git a/stdlib/source/lux/data/coll/dictionary/ordered.lux b/stdlib/source/lux/data/coll/dictionary/ordered.lux deleted file mode 100644 index 3cea300f7..000000000 --- a/stdlib/source/lux/data/coll/dictionary/ordered.lux +++ /dev/null @@ -1,569 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do Monad] - equivalence - [order #+ Order]) - (data (coll [list "L/" Monad Monoid Fold]) - ["p" product] - [maybe]) - [macro] - (macro [code] - ["s" syntax #+ syntax: Syntax]))) - -(def: error-message Text "Invariant violation") - -(type: Color #Red #Black) - -(type: (Node k v) - {#color Color - #key k - #value v - #left (Maybe (Node k v)) - #right (Maybe (Node k v))}) - -(do-template [ ] - [(def: ( key value left right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - {#color - #key key - #value value - #left left - #right right})] - - [red #Red] - [black #Black] - ) - -(type: #export (Dictionary k v) - {#order (Order k) - #root (Maybe (Node k v))}) - -(def: #export (new Order) - (All [k v] (-> (Order k) (Dictionary k v))) - {#order Order - #root #.None}) - -## TODO: Doing inneficient access of Order functions due to compiler bug. -## TODO: Must improve it as soon as bug is fixed. -(def: #export (get key dict) - (All [k v] (-> k (Dictionary k v) (Maybe v))) - (let [## (^open "T/") (get@ #order dict) - ] - (loop [node (get@ #root dict)] - (case node - #.None - #.None - - (#.Some node) - (let [node-key (get@ #key node)] - (cond (:: dict = node-key key) - ## (T/= node-key key) - (#.Some (get@ #value node)) - - (:: dict < node-key key) - ## (T/< node-key key) - (recur (get@ #left node)) - - ## (T/> (get@ #key node) key) - (recur (get@ #right node)))) - )))) - -(def: #export (contains? key dict) - (All [k v] (-> k (Dictionary k v) Bool)) - (let [## (^open "T/") (get@ #order dict) - ] - (loop [node (get@ #root dict)] - (case node - #.None - false - - (#.Some node) - (let [node-key (get@ #key node)] - (or (:: dict = node-key key) - ## (T/= node-key key) - (if (:: dict < node-key key) - ## (T/< node-key key) - (recur (get@ #left node)) - (recur (get@ #right node))))))))) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dictionary k v) (Maybe v))) - (case (get@ #root dict) - #.None - #.None - - (#.Some node) - (loop [node node] - (case (get@ node) - #.None - (#.Some (get@ #value node)) - - (#.Some side) - (recur side)))))] - - [min #left] - [max #right] - ) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dictionary k v) Nat)) - (loop [node (get@ #root dict)] - (case node - #.None - +0 - - (#.Some node) - (inc ( (recur (get@ #left node)) - (recur (get@ #right node)))))))] - - [size n/+] - [depth n/max] - ) - -(do-template [ ] - [(def: ( self) - (All [k v] (-> (Node k v) (Node k v))) - (case (get@ #color self) - - (set@ #color self) - - - - ))] - - [blacken #Red #Black self] - [redden #Black #Red (error! error-message)] - ) - -(def: (balance-left-add parent self) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (with-expansions - [ (as-is (black (get@ #key parent) - (get@ #value parent) - (#.Some self) - (get@ #right parent)))] - (case (get@ #color self) - #Red - (case (get@ #left self) - (^multi (#.Some left) - [(get@ #color left) #Red]) - (red (get@ #key self) - (get@ #value self) - (#.Some (blacken left)) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #right self) - (get@ #right parent)))) - - _ - (case (get@ #right self) - (^multi (#.Some right) - [(get@ #color right) #Red]) - (red (get@ #key right) - (get@ #value right) - (#.Some (black (get@ #key self) - (get@ #value self) - (get@ #left self) - (get@ #left right))) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #right right) - (get@ #right parent)))) - - _ - )) - - #Black - - ))) - -(def: (balance-right-add parent self) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (with-expansions - [ (as-is (black (get@ #key parent) - (get@ #value parent) - (get@ #left parent) - (#.Some self)))] - (case (get@ #color self) - #Red - (case (get@ #right self) - (^multi (#.Some right) - [(get@ #color right) #Red]) - (red (get@ #key self) - (get@ #value self) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #left parent) - (get@ #left self))) - (#.Some (blacken right))) - - _ - (case (get@ #left self) - (^multi (#.Some left) - [(get@ #color left) #Red]) - (red (get@ #key left) - (get@ #value left) - (#.Some (black (get@ #key parent) - (get@ #value parent) - (get@ #left parent) - (get@ #left left))) - (#.Some (black (get@ #key self) - (get@ #value self) - (get@ #right left) - (get@ #right self)))) - - _ - )) - - #Black - - ))) - -(def: (add-left addition center) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (case (get@ #color center) - #Red - (red (get@ #key center) (get@ #value center) (#.Some addition) (get@ #right center)) - - #Black - (balance-left-add center addition) - )) - -(def: (add-right addition center) - (All [k v] (-> (Node k v) (Node k v) (Node k v))) - (case (get@ #color center) - #Red - (red (get@ #key center) (get@ #value center) (get@ #left center) (#.Some addition)) - - #Black - (balance-right-add center addition) - )) - -(def: #export (put key value dict) - (All [k v] (-> k v (Dictionary k v) (Dictionary k v))) - (let [(^open "T/") (get@ #order dict) - root' (loop [?root (get@ #root dict)] - (case ?root - #.None - (#.Some (red key value #.None #.None)) - - (#.Some root) - (let [reference (get@ #key root)] - (`` (cond (~~ (do-template [ ] - [( reference key) - (let [side-root (get@ root) - outcome (recur side-root)] - (if (is? side-root outcome) - ?root - (#.Some ( (maybe.assume outcome) - root))))] - - [T/< #left add-left] - [T/> #right add-right] - )) - - ## (T/= reference key) - ?root - ))) - ))] - (set@ #root root' dict))) - -(def: (left-balance key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?left - (^multi (#.Some left) - [(get@ #color left) #Red] - [(get@ #left left) (#.Some left>>left)] - [(get@ #color left>>left) #Red]) - (red (get@ #key left) - (get@ #value left) - (#.Some (blacken left>>left)) - (#.Some (black key value (get@ #right left) ?right))) - - (^multi (#.Some left) - [(get@ #color left) #Red] - [(get@ #right left) (#.Some left>>right)] - [(get@ #color left>>right) #Red]) - (red (get@ #key left>>right) - (get@ #value left>>right) - (#.Some (black (get@ #key left) - (get@ #value left) - (get@ #left left) - (get@ #left left>>right))) - (#.Some (black key value - (get@ #right left>>right) - ?right))) - - _ - (black key value ?left ?right))) - -(def: (right-balance key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?right - (^multi (#.Some right) - [(get@ #color right) #Red] - [(get@ #right right) (#.Some right>>right)] - [(get@ #color right>>right) #Red]) - (red (get@ #key right) - (get@ #value right) - (#.Some (black key value ?left (get@ #left right))) - (#.Some (blacken right>>right))) - - (^multi (#.Some right) - [(get@ #color right) #Red] - [(get@ #left right) (#.Some right>>left)] - [(get@ #color right>>left) #Red]) - (red (get@ #key right>>left) - (get@ #value right>>left) - (#.Some (black key value ?left (get@ #left right>>left))) - (#.Some (black (get@ #key right) - (get@ #value right) - (get@ #right right>>left) - (get@ #right right)))) - - _ - (black key value ?left ?right))) - -(def: (balance-left-remove key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?left - (^multi (#.Some left) - [(get@ #color left) #Red]) - (red key value (#.Some (blacken left)) ?right) - - _ - (case ?right - (^multi (#.Some right) - [(get@ #color right) #Black]) - (right-balance key value ?left (#.Some (redden right))) - - (^multi (#.Some right) - [(get@ #color right) #Red] - [(get@ #left right) (#.Some right>>left)] - [(get@ #color right>>left) #Black]) - (red (get@ #key right>>left) - (get@ #value right>>left) - (#.Some (black key value ?left (get@ #left right>>left))) - (#.Some (right-balance (get@ #key right) - (get@ #value right) - (get@ #right right>>left) - (:: maybe.Functor map redden (get@ #right right))))) - - _ - (error! error-message)) - )) - -(def: (balance-right-remove key value ?left ?right) - (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) - (case ?right - (^multi (#.Some right) - [(get@ #color right) #Red]) - (red key value ?left (#.Some (blacken right))) - - _ - (case ?left - (^multi (#.Some left) - [(get@ #color left) #Black]) - (left-balance key value (#.Some (redden left)) ?right) - - (^multi (#.Some left) - [(get@ #color left) #Red] - [(get@ #right left) (#.Some left>>right)] - [(get@ #color left>>right) #Black]) - (red (get@ #key left>>right) - (get@ #value left>>right) - (#.Some (left-balance (get@ #key left) - (get@ #value left) - (:: maybe.Functor map redden (get@ #left left)) - (get@ #left left>>right))) - (#.Some (black key value (get@ #right left>>right) ?right))) - - _ - (error! error-message) - ))) - -(def: (prepend ?left ?right) - (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v)))) - (case [?left ?right] - [#.None _] - ?right - - [_ #.None] - ?left - - [(#.Some left) (#.Some right)] - (case [(get@ #color left) (get@ #color right)] - [#Red #Red] - (do maybe.Monad - [fused (prepend (get@ #right left) (get@ #right right))] - (case (get@ #color fused) - #Red - (wrap (red (get@ #key fused) - (get@ #value fused) - (#.Some (red (get@ #key left) - (get@ #value left) - (get@ #left left) - (get@ #left fused))) - (#.Some (red (get@ #key right) - (get@ #value right) - (get@ #right fused) - (get@ #right right))))) - - #Black - (wrap (red (get@ #key left) - (get@ #value left) - (get@ #left left) - (#.Some (red (get@ #key right) - (get@ #value right) - (#.Some fused) - (get@ #right right))))))) - - [#Red #Black] - (#.Some (red (get@ #key left) - (get@ #value left) - (get@ #left left) - (prepend (get@ #right left) - ?right))) - - [#Black #Red] - (#.Some (red (get@ #key right) - (get@ #value right) - (prepend ?left - (get@ #left right)) - (get@ #right right))) - - [#Black #Black] - (do maybe.Monad - [fused (prepend (get@ #right left) (get@ #left right))] - (case (get@ #color fused) - #Red - (wrap (red (get@ #key fused) - (get@ #value fused) - (#.Some (black (get@ #key left) - (get@ #value left) - (get@ #left left) - (get@ #left fused))) - (#.Some (black (get@ #key right) - (get@ #value right) - (get@ #right fused) - (get@ #right right))))) - - #Black - (wrap (balance-left-remove (get@ #key left) - (get@ #value left) - (get@ #left left) - (#.Some (black (get@ #key right) - (get@ #value right) - (#.Some fused) - (get@ #right right))))) - )) - ) - - _ - (undefined))) - -(def: #export (remove key dict) - (All [k v] (-> k (Dictionary k v) (Dictionary k v))) - (let [(^open "T/") (get@ #order dict) - [?root found?] (loop [?root (get@ #root dict)] - (case ?root - #.None - [#.None false] - - (#.Some root) - (let [root-key (get@ #key root) - root-val (get@ #value root)] - (if (T/= root-key key) - [(prepend (get@ #left root) - (get@ #right root)) - true] - (let [go-left? (T/< root-key key)] - (case (recur (if go-left? - (get@ #left root) - (get@ #right root))) - [#.None false] - [#.None false] - - [side-outcome _] - (if go-left? - (case (get@ #left root) - (^multi (#.Some left) - [(get@ #color left) #Black]) - [(#.Some (balance-left-remove root-key root-val side-outcome (get@ #right root))) - false] - - _ - [(#.Some (red root-key root-val side-outcome (get@ #right root))) - false]) - (case (get@ #right root) - (^multi (#.Some right) - [(get@ #color right) #Black]) - [(#.Some (balance-right-remove root-key root-val (get@ #left root) side-outcome)) - false] - - _ - [(#.Some (red root-key root-val (get@ #left root) side-outcome)) - false]) - ))) - )) - ))] - (case ?root - #.None - (if found? - (set@ #root ?root dict) - dict) - - (#.Some root) - (set@ #root (#.Some (blacken root)) dict) - ))) - -(def: #export (update key transform dict) - (All [k v] (-> k (-> v v) (Dictionary k v) (Maybe (Dictionary k v)))) - (do maybe.Monad - [old (get key dict)] - (wrap (put key (transform old) dict)))) - -(def: #export (from-list Order list) - (All [k v] (-> (Order k) (List [k v]) (Dictionary k v))) - (L/fold (function (_ [key value] dict) - (put key value dict)) - (new Order) - list)) - -(do-template [ ] - [(def: #export ( dict) - (All [k v] (-> (Dictionary k v) (List ))) - (loop [node (get@ #root dict)] - (case node - #.None - (list) - - (#.Some node') - ($_ L/compose - (recur (get@ #left node')) - (list ) - (recur (get@ #right node'))))))] - - [entries [k v] [(get@ #key node') (get@ #value node')]] - [keys k (get@ #key node')] - [values v (get@ #value node')] - ) - -(structure: #export (Equivalence Equivalence) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) - (def: (= reference sample) - (let [Equivalence (:: sample eq)] - (loop [entriesR (entries reference) - entriesS (entries sample)] - (case [entriesR entriesS] - [#.Nil #.Nil] - true - - [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')] - (and (:: Equivalence = keyR keyS) - (:: Equivalence = valueR valueS) - (recur entriesR' entriesS')) - - _ - false))))) diff --git a/stdlib/source/lux/data/coll/dictionary/plist.lux b/stdlib/source/lux/data/coll/dictionary/plist.lux deleted file mode 100644 index c483a3287..000000000 --- a/stdlib/source/lux/data/coll/dictionary/plist.lux +++ /dev/null @@ -1,62 +0,0 @@ -(.module: - lux - (lux (data [text "text/" Equivalence]))) - -(type: #export (PList a) - (List [Text a])) - -(def: #export (get key properties) - (All [a] (-> Text (PList a) (Maybe a))) - (case properties - #.Nil - #.None - - (#.Cons [k' v'] properties') - (if (text/= key k') - (#.Some v') - (get key properties')))) - -(def: #export (contains? key properties) - (All [a] (-> Text (PList a) Bool)) - (case (get key properties) - (#.Some _) - true - - #.None - false)) - -(def: #export (put key val properties) - (All [a] (-> Text a (PList a) (PList a))) - (case properties - #.Nil - (list [key val]) - - (#.Cons [k' v'] properties') - (if (text/= key k') - (#.Cons [key val] - properties') - (#.Cons [k' v'] - (put key val properties'))))) - -(def: #export (update key f properties) - (All [a] (-> Text (-> a a) (PList a) (PList a))) - (case properties - #.Nil - #.Nil - - (#.Cons [k' v'] properties') - (if (text/= key k') - (#.Cons [k' (f v')] properties') - (#.Cons [k' v'] (update key f properties'))))) - -(def: #export (remove key properties) - (All [a] (-> Text (PList a) (PList a))) - (case properties - #.Nil - properties - - (#.Cons [k' v'] properties') - (if (text/= key k') - properties' - (#.Cons [k' v'] - (remove key properties'))))) diff --git a/stdlib/source/lux/data/coll/list.lux b/stdlib/source/lux/data/coll/list.lux deleted file mode 100644 index 74ef2e5cc..000000000 --- a/stdlib/source/lux/data/coll/list.lux +++ /dev/null @@ -1,554 +0,0 @@ -(.module: - lux - (lux (control [monoid #+ Monoid] - [functor #+ Functor] - [apply #+ Apply] - [monad #+ do Monad] - [equivalence #+ Equivalence] - [fold]) - (data [number "nat/" Codec] - bool - [product]))) - -## [Types] -## (type: (List a) -## #Nil -## (#Cons a (List a))) - -## [Functions] -(structure: #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 (function (_ 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 do not."} - (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 (dec n) xs')]) #.Nil] - [drop (drop (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 (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 (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 (search check xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (Maybe b))) - (case xs - #.Nil - #.None - - (#.Cons [x xs']) - (case (check x) - (#.Some output) - (#.Some output) - - #.None - (search check xs')))) - -(def: #export (search-all check xs) - (All [a b] - (-> (-> a (Maybe b)) (List a) (List b))) - (case xs - #.Nil - #.None - - (#.Cons [x xs']) - (case (check x) - (#.Some output) - (#.Cons output (search-all check xs')) - - #.None - (search-all check 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 (function (_ _ acc) (n/+ +1 acc)) +0 list)) - -(do-template [ ] - [(def: #export ( p xs) - (All [a] - (-> (-> a Bool) (List a) Bool)) - (loop [xs xs] - (case xs - #.Nil - - - (#.Cons x xs') - (case (p x) - - (recur xs') - - output - output))))] - - [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 (dec i) xs')))) - -## [Structures] -(structure: #export (Equivalence Equivalence) - (All [a] (-> (Equivalence a) (Equivalence (List a)))) - (def: (= xs ys) - (case [xs ys] - [#.Nil #.Nil] - true - - [(#.Cons x xs') (#.Cons y ys')] - (and (:: Equivalence = x y) - (= xs' ys')) - - [_ _] - false - ))) - -(structure: #export Monoid (All [a] - (Monoid (List a))) - (def: identity #.Nil) - (def: (compose xs ys) - (case xs - #.Nil ys - (#.Cons x xs') (#.Cons x (compose xs' ys))))) - -(open: Monoid) - -(structure: #export _ (Functor List) - (def: (map f ma) - (case ma - #.Nil #.Nil - (#.Cons a ma') (#.Cons (f a) (map f ma'))))) - -(open: Functor) - -(structure: #export _ (Apply List) - (def: functor Functor) - - (def: (apply ff fa) - (case ff - #.Nil - #.Nil - - (#.Cons f ff') - (compose (map f fa) (apply ff' fa))))) - -(structure: #export _ (Monad List) - (def: functor Functor) - - (def: (wrap a) - (#.Cons a #.Nil)) - - (def: join (|>> reverse (fold compose identity)))) - -## [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 (function (_ x' [pre post]) - (if (< x x') - [(#.Cons x' pre) post] - [pre (#.Cons x' post)])) - [(list) (list)] - xs')] - ($_ compose (sort < pre) (list x) (sort < post))))) - -(do-template [ ] - [(def: #export ( from to) - {#.doc "Generates an inclusive interval of values [from, to]."} - (-> (List )) - (cond ( to from) - (list& from ( (inc from) to)) - - ( to from) - (list& from ( (dec from) to)) - - ## (= to from) - (list from)))] - - [i/range Int i/< i/>] - [n/range Nat n/< n/>] - ) - -(def: #export (empty? xs) - (All [a] (-> (List a) Bool)) - (case xs - #.Nil true - _ false)) - -(def: #export (member? eq xs x) - (All [a] (-> (Equivalence 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 Code) - [["" +0 +0] (#.Symbol "" 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 [_ (#.Nat num-lists)])) - (if (n/> +0 num-lists) - (let [(^open) Functor - indices (n/range +0 (dec num-lists)) - type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) - zip-type (` (All [(~+ type-vars)] - (-> (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) - type-vars)) - (List [(~+ type-vars)])))) - vars+lists (|> indices - (map inc) - (map (function (_ idx) - (let [base (nat/encode idx)] - [(symbol$ base) - (symbol$ ("lux text concat" base "'"))])))) - pattern (` [(~+ (map (function (_ [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) - (function ((~ 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 "Cannot 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 [_ (#.Nat num-lists)])) - (if (n/> +0 num-lists) - (let [(^open) Functor - indices (n/range +0 (dec num-lists)) - g!return-type (symbol$ "\treturn-type\t") - g!func (symbol$ "\tfunc\t") - type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) - zip-type (` (All [(~+ type-vars) (~ g!return-type)] - (-> (-> (~+ type-vars) (~ g!return-type)) - (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) - type-vars)) - (List (~ g!return-type))))) - vars+lists (|> indices - (map inc) - (map (function (_ idx) - (let [base (nat/encode idx)] - [(symbol$ base) - (symbol$ ("lux text concat" base "'"))])))) - pattern (` [(~+ (map (function (_ [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) - (function ((~ 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 "Cannot 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)) - -(structure: #export (ListT Monad) - (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) - - (def: functor (functor.compose (get@ #monad.functor Monad) Functor)) - - (def: wrap (|>> (:: Monad wrap) (:: Monad wrap))) - - (def: (join MlMla) - (do Monad - [lMla MlMla - ## TODO: Remove this version ASAP and use one below. - lla (: (($ +0) (List (List ($ +1)))) - (monad.seq @ lMla)) - ## lla (monad.seq @ lMla) - ] - (wrap (concat lla))))) - -(def: #export (lift Monad) - (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) - (monad.lift 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' (inc idx) xs')))) - -(def: #export (enumerate xs) - {#.doc "Pairs every element in the list with its 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 dec (n/range +0)))) diff --git a/stdlib/source/lux/data/coll/queue.lux b/stdlib/source/lux/data/coll/queue.lux deleted file mode 100644 index 3b144a52a..000000000 --- a/stdlib/source/lux/data/coll/queue.lux +++ /dev/null @@ -1,78 +0,0 @@ -(.module: - lux - (lux (control [equivalence #+ Equivalence] - ["F" functor]) - (data (coll [list "L/" Monoid Functor])))) - -(type: #export (Queue a) - {#front (List a) - #rear (List a)}) - -(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] - (L/compose 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? Equivalence queue member) - (All [a] (-> (Equivalence a) (Queue a) a Bool)) - (let [(^slots [#front #rear]) queue] - (or (list.member? Equivalence front member) - (list.member? Equivalence rear member)))) - -(def: #export (pop queue) - (All [a] (-> (Queue a) (Queue a))) - (case (get@ #front queue) - (^ (list)) ## Empty... - 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))) - -(structure: #export (Equivalence Equivalence) - (All [a] (-> (Equivalence a) (Equivalence (Queue a)))) - (def: (= qx qy) - (:: (list.Equivalence Equivalence) = (to-list qx) (to-list qy)))) - -(structure: #export _ (F.Functor Queue) - (def: (map f fa) - {#front (|> fa (get@ #front) (L/map f)) - #rear (|> fa (get@ #rear) (L/map f))})) diff --git a/stdlib/source/lux/data/coll/queue/priority.lux b/stdlib/source/lux/data/coll/queue/priority.lux deleted file mode 100644 index 443a54908..000000000 --- a/stdlib/source/lux/data/coll/queue/priority.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - lux - (lux (control [equivalence #+ Equivalence] - [monad #+ do Monad]) - (data (coll (tree [finger #+ Tree])) - [number "nat/" Interval] - [maybe]))) - -(type: #export Priority Nat) - -(type: #export (Queue a) - (Maybe (Tree Priority a))) - -(def: #export max Priority nat/top) -(def: #export min Priority nat/bottom) - -(def: #export empty - Queue - #.None) - -(def: #export (peek queue) - (All [a] (-> (Queue a) (Maybe a))) - (do maybe.Monad - [fingers queue] - (wrap (maybe.assume (finger.search (n/= (finger.tag fingers)) fingers))))) - -(def: #export (size queue) - (All [a] (-> (Queue a) Nat)) - (case queue - #.None - +0 - - (#.Some fingers) - (loop [node (get@ #finger.node fingers)] - (case node - (#finger.Leaf _ _) - +1 - - (#finger.Branch _ left right) - (n/+ (recur left) (recur right)))))) - -(def: #export (member? Equivalence queue member) - (All [a] (-> (Equivalence a) (Queue a) a Bool)) - (case queue - #.None - false - - (#.Some fingers) - (loop [node (get@ #finger.node fingers)] - (case node - (#finger.Leaf _ reference) - (:: Equivalence = reference member) - - (#finger.Branch _ left right) - (or (recur left) - (recur right)))))) - -(def: #export (pop queue) - (All [a] (-> (Queue a) (Queue a))) - (do maybe.Monad - [fingers queue - #let [highest-priority (finger.tag fingers)] - node' (loop [node (get@ #finger.node fingers)] - (case node - (#finger.Leaf priority reference) - (if (n/= highest-priority priority) - #.None - (#.Some node)) - - (#finger.Branch priority left right) - (if (n/= highest-priority (finger.tag (set@ #finger.node left fingers))) - (case (recur left) - #.None - (#.Some right) - - (#.Some =left) - (|> (finger.branch (set@ #finger.node =left fingers) - (set@ #finger.node right fingers)) - (get@ #finger.node) - #.Some)) - (case (recur right) - #.None - (#.Some left) - - (#.Some =right) - (|> (finger.branch (set@ #finger.node left fingers) - (set@ #finger.node =right fingers)) - (get@ #finger.node) - #.Some)) - )))] - (wrap (set@ #finger.node node' fingers)))) - -(def: #export (push priority value queue) - (All [a] (-> Priority a (Queue a) (Queue a))) - (let [addition {#finger.monoid number.Max@Monoid - #finger.node (#finger.Leaf priority value)}] - (case queue - #.None - (#.Some addition) - - (#.Some fingers) - (#.Some (finger.branch fingers addition))))) diff --git a/stdlib/source/lux/data/coll/row.lux b/stdlib/source/lux/data/coll/row.lux deleted file mode 100644 index 1d4dc648c..000000000 --- a/stdlib/source/lux/data/coll/row.lux +++ /dev/null @@ -1,437 +0,0 @@ -(.module: - lux - (lux (control [functor #+ Functor] - [apply #+ Apply] - [monad #+ do Monad] - [equivalence #+ Equivalence] - monoid - fold - ["p" parser]) - (data [maybe] - (coll [list "list/" Fold Functor Monoid] - [array "array/" Functor Fold]) - [bit] - [product]) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax: Syntax]) - )) - -## [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.left-shift branching-exponent +1)) - -(def: branch-idx-mask - Nat - (dec full-node-size)) - -(def: branch-idx - (-> Index Index) - (bit.and branch-idx-mask)) - -(def: (new-hierarchy _) - (All [a] (-> Any (Hierarchy a))) - (array.new full-node-size)) - -(def: (tail-off vec-size) - (-> Nat Nat) - (if (n/< full-node-size vec-size) - +0 - (|> (dec vec-size) - (bit.logical-right-shift branching-exponent) - (bit.left-shift branching-exponent)))) - -(def: (new-path level tail) - (All [a] (-> Level (Base a) (Node a))) - (if (n/= +0 level) - (#Base tail) - (|> (new-hierarchy []) - (array.write +0 (new-path (level-down level) tail)) - #Hierarchy))) - -(def: (new-tail singleton) - (All [a] (-> a (Base a))) - (|> (array.new +1) - (array.write +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.logical-right-shift level (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.read 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.write sub-idx sub-node)))) - -(def: (expand-tail val tail) - (All [a] (-> a (Base a) (Base a))) - (let [tail-size (array.size tail)] - (|> (array.new (inc tail-size)) - (array.copy tail-size +0 tail +0) - (array.write tail-size val)))) - -(def: (put' level idx val hierarchy) - (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a))) - (let [sub-idx (branch-idx (bit.logical-right-shift level idx))] - (case (array.read sub-idx hierarchy) - (#.Some (#Hierarchy sub-node)) - (|> (array.clone hierarchy) - (array.write sub-idx (#Hierarchy (put' (level-down level) idx val sub-node)))) - - (^multi (#.Some (#Base base)) - (n/= +0 (level-down level))) - (|> (array.clone hierarchy) - (array.write sub-idx (|> (array.clone base) - (array.write (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.logical-right-shift level (n/- +2 size)))] - (cond (n/= +0 sub-idx) - #.None - - (n/> branching-exponent level) - (do maybe.Monad - [base|hierarchy (array.read sub-idx hierarchy) - sub (case base|hierarchy - (#Hierarchy sub) - (pop-tail size (level-down level) sub) - - (#Base _) - (undefined))] - (|> (array.clone hierarchy) - (array.write sub-idx (#Hierarchy sub)) - #.Some)) - - ## Else... - (|> (array.clone hierarchy) - (array.delete 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 (function (_ sub acc) (list/compose (to-list' sub) acc)) - #.Nil)))) - -## [Types] -(type: #export (Row a) - {#level Level - #size Nat - #root (Hierarchy a) - #tail (Base a)}) - -## [Exports] -(def: #export empty - Row - {#level (level-up root-level) - #size +0 - #root (array.new full-node-size) - #tail (array.new +0)}) - -(def: #export (size row) - (All [a] (-> (Row a) Nat)) - (get@ #size row)) - -(def: #export (add val vec) - (All [a] (-> a (Row a) (Row 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 inc) - (update@ #tail (expand-tail val))) - ## Otherwise, push tail into the tree - ## -------------------------------------------------------- - ## Will the root experience an overflow with this addition? - (|> (if (n/> (bit.left-shift (get@ #level vec) +1) - (bit.logical-right-shift 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 [])) - ## TODO: Remove version above once new-luxc becomes the standard compiler. - ## (new-hierarchy []) - (array.write +0 (#Hierarchy (get@ #root vec))) - (array.write +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 row and grow a new - ## tail with the new element as it's sole member. - (update@ #size inc) - (set@ #tail (new-tail val))) - ))) - -(def: (base-for idx vec) - (All [a] (-> Index (Row 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.read (branch-idx (bit.logical-right-shift level idx)) hierarchy)] - [true (#.Some (#Hierarchy sub))] - (recur (level-down level) sub) - - [false (#.Some (#Base base))] - (#.Some base) - - [_ #.None] - #.None - - _ - (error! "Incorrect row structure.")))) - #.None))) - -(def: #export (nth idx vec) - (All [a] (-> Nat (Row a) (Maybe a))) - (do maybe.Monad - [base (base-for idx vec)] - (array.read (branch-idx idx) base))) - -(def: #export (put idx val vec) - (All [a] (-> Nat a (Row a) (Row 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 (|>> array.clone (array.write (branch-idx idx) val))) - ## TODO: Remove once new-luxc becomes the standard compiler. - (update@ #tail (: (-> (Base ($ +0)) (Base ($ +0))) - (|>> array.clone (array.write (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) (Row a) (Row a))) - (case (nth idx vec) - (#.Some val) - (put idx (f val) vec) - - #.None - vec)) - -(def: #export (pop vec) - (All [a] (-> (Row a) (Row 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 (dec (array.size old-tail))] - (|> vec - (update@ #size dec) - (set@ #tail (|> (array.new new-tail-size) - (array.copy new-tail-size +0 old-tail +0))))) - (maybe.assume - (do maybe.Monad - [new-tail (base-for (n/- +2 vec-size) vec) - #let [[level' root'] (let [init-level (get@ #level vec)] - (loop [level init-level - root (maybe.default (new-hierarchy []) - (pop-tail vec-size init-level (get@ #root vec)))] - (if (n/> branching-exponent level) - (case [(array.read +1 root) (array.read +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 dec) - (set@ #level level') - (set@ #root root') - (set@ #tail new-tail)))))) - )) - -(def: #export (to-list vec) - (All [a] (-> (Row a) (List a))) - (list/compose (to-list' (#Hierarchy (get@ #root vec))) - (to-list' (#Base (get@ #tail vec))))) - -(def: #export (from-list list) - (All [a] (-> (List a) (Row a))) - (list/fold add - empty - list)) - -(def: #export (member? a/Equivalence vec val) - (All [a] (-> (Equivalence a) (Row a) a Bool)) - (list.member? a/Equivalence (to-list vec) val)) - -(def: #export empty? - (All [a] (-> (Row a) Bool)) - (|>> (get@ #size) (n/= +0))) - -## [Syntax] -(syntax: #export (row {elems (p.some s.any)}) - {#.doc (doc "Row literals." - (row 10 20 30 40))} - (wrap (list (` (from-list (list (~+ elems))))))) - -## [Structures] -(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Node a)))) - (def: (= v1 v2) - (case [v1 v2] - [(#Base b1) (#Base b2)] - (:: (array.Equivalence Equivalence) = b1 b2) - - [(#Hierarchy h1) (#Hierarchy h2)] - (:: (array.Equivalence (Equivalence Equivalence)) = h1 h2) - - _ - false))) - -(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Row a)))) - (def: (= v1 v2) - (and (n/= (get@ #size v1) (get@ #size v2)) - (let [(^open "Node/") (Equivalence Equivalence)] - (and (Node/= (#Base (get@ #tail v1)) - (#Base (get@ #tail v2))) - (Node/= (#Hierarchy (get@ #root v1)) - (#Hierarchy (get@ #root v2)))))))) - -(structure: _ (Fold Node) - (def: (fold f init xs) - (case xs - (#Base base) - (array/fold f init base) - - (#Hierarchy hierarchy) - (array/fold (function (_ node init') (fold f init' node)) - init - hierarchy)) - )) - -(structure: #export _ (Fold Row) - (def: (fold f init xs) - (let [(^open) Fold] - (fold f - (fold f - init - (#Hierarchy (get@ #root xs))) - (#Base (get@ #tail xs)))) - )) - -(structure: #export Monoid (All [a] (Monoid (Row a))) - (def: identity empty) - (def: (compose xs ys) - (list/fold add xs (to-list ys)))) - -(structure: _ (Functor Node) - (def: (map f xs) - (case xs - (#Base base) - (#Base (array/map f base)) - - (#Hierarchy hierarchy) - (#Hierarchy (array/map (map f) hierarchy))) - )) - -(structure: #export _ (Functor Row) - (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)) - })) - -(structure: #export _ (Apply Row) - (def: functor Functor) - - (def: (apply ff fa) - (let [(^open) Functor - (^open) Fold - (^open) Monoid - results (map (function (_ f) (map f fa)) - ff)] - (fold compose identity results)))) - -(structure: #export _ (Monad Row) - (def: functor Functor) - - (def: wrap (|>> row)) - - (def: join - (let [(^open) Fold - (^open) Monoid] - (fold (function (_ post pre) (compose pre post)) identity)))) - -(def: #export (reverse xs) - (All [a] (-> (Row a) (Row a))) - (let [(^open) Fold - (^open) Monoid] - (fold add identity xs))) diff --git a/stdlib/source/lux/data/coll/sequence.lux b/stdlib/source/lux/data/coll/sequence.lux deleted file mode 100644 index ab8f1d625..000000000 --- a/stdlib/source/lux/data/coll/sequence.lux +++ /dev/null @@ -1,146 +0,0 @@ -(.module: - lux - (lux (control functor - monad - comonad - [continuation #+ pending Cont] - ["p" parser]) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax: Syntax]) - (data (coll [list "List/" Monad]) - bool))) - -## [Types] -(type: #export (Sequence a) - {#.doc "An infinite sequence of values."} - (Cont [a (Sequence a)])) - -## [Utils] -(def: (cycle' x xs init full) - (All [a] - (-> a (List a) a (List a) (Sequence a))) - (case xs - #.Nil (pending [x (cycle' init full init full)]) - (#.Cons x' xs') (pending [x (cycle' x' xs' init full)]))) - -## [Functions] -(def: #export (iterate f x) - {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."} - (All [a] - (-> (-> a a) a (Sequence a))) - (pending [x (iterate f (f x))])) - -(def: #export (repeat x) - {#.doc "Repeat a value forever."} - (All [a] - (-> a (Sequence a))) - (pending [x (repeat x)])) - -(def: #export (cycle xs) - {#.doc "Go over the elements of a list forever. - - The list should not be empty."} - (All [a] - (-> (List a) (Maybe (Sequence a)))) - (case xs - #.Nil #.None - (#.Cons x xs') (#.Some (cycle' x xs' x xs')))) - -(do-template [ ] - [(def: #export ( s) - (All [a] (-> (Sequence a) )) - (let [[h t] (continuation.run s)] - ))] - - [head a h] - [tail (Sequence a) t]) - -(def: #export (nth idx s) - (All [a] (-> Nat (Sequence a) a)) - (let [[h t] (continuation.run s)] - (if (n/> +0 idx) - (nth (dec idx) t) - h))) - -(do-template [ ] - [(def: #export ( pred xs) - (All [a] - (-> (Sequence a) (List a))) - (let [[x xs'] (continuation.run xs)] - (if - (list& x ( xs')) - (list)))) - - (def: #export ( pred xs) - (All [a] - (-> (Sequence a) (Sequence a))) - (let [[x xs'] (continuation.run xs)] - (if - ( xs') - xs))) - - (def: #export ( pred xs) - (All [a] - (-> (Sequence a) [(List a) (Sequence a)])) - (let [[x xs'] (continuation.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) (dec pred)] - ) - -(def: #export (unfold step init) - {#.doc "A stateful way of infinitely calculating the values of a sequence."} - (All [a b] - (-> (-> a [a b]) a (Sequence b))) - (let [[next x] (step init)] - (pending [x (unfold step next)]))) - -(def: #export (filter p xs) - (All [a] (-> (-> a Bool) (Sequence a) (Sequence a))) - (let [[x xs'] (continuation.run xs)] - (if (p x) - (pending [x (filter p xs')]) - (filter p xs')))) - -(def: #export (partition p xs) - {#.doc "Split a sequence 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) (Sequence a) [(Sequence a) (Sequence a)])) - [(filter p xs) (filter (complement p) xs)]) - -## [Structures] -(structure: #export _ (Functor Sequence) - (def: (map f fa) - (let [[h t] (continuation.run fa)] - (pending [(f h) (map f t)])))) - -(structure: #export _ (CoMonad Sequence) - (def: functor Functor) - (def: unwrap head) - (def: (split wa) - (let [[head tail] (continuation.run wa)] - (pending [wa (split tail)])))) - -## [Pattern-matching] -(syntax: #export (^sequence& {patterns (s.form (p.many s.any))} - body - {branches (p.some s.any)}) - {#.doc (doc "Allows destructuring of sequences in pattern-matching expressions." - "Caveat emptor: Only use it for destructuring, and not for testing values within the sequences." - (let [(^sequence& x y z _tail) (some-sequence-func 1 2 3)] - (func x y z)))} - (with-gensyms [g!sequence] - (let [body+ (` (let [(~+ (List/join (List/map (function (_ pattern) - (list (` [(~ pattern) (~ g!sequence)]) - (` ((~! continuation.run) (~ g!sequence))))) - patterns)))] - (~ body)))] - (wrap (list& g!sequence body+ branches))))) diff --git a/stdlib/source/lux/data/coll/set.lux b/stdlib/source/lux/data/coll/set.lux deleted file mode 100644 index 929040ad0..000000000 --- a/stdlib/source/lux/data/coll/set.lux +++ /dev/null @@ -1,81 +0,0 @@ -(.module: - lux - (lux (control [equivalence #+ Equivalence] - [hash #+ Hash]) - (data (coll ["dict" dictionary #+ Dictionary] - [list "list/" Fold])) - (type abstract))) - -(abstract: #export (Set a) - {} - - (Dictionary a a) - - (def: #export new - (All [a] (-> (Hash a) (Set a))) - (|>> dict.new :abstraction)) - - (def: #export size - (All [a] (-> (Set a) Nat)) - (|>> :representation dict.size)) - - (def: #export (add elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (dict.put elem elem) :abstraction)) - - (def: #export (remove elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (dict.remove elem) :abstraction)) - - (def: #export (member? set elem) - (All [a] (-> (Set a) a Bool)) - (|> set :representation (dict.contains? elem))) - - (def: #export to-list - (All [a] (-> (Set a) (List a))) - (|>> :representation dict.keys)) - - (def: #export (union xs yx) - (All [a] (-> (Set a) (Set a) (Set a))) - (:abstraction (dict.merge (:representation xs) (:representation 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))) - (:abstraction (dict.select (dict.keys (:representation filter)) - (:representation base)))) - - (structure: #export Equivalence (All [a] (Equivalence (Set a))) - (def: (= reference sample) - (let [[Hash _] (:representation reference)] - (:: (list.Equivalence (get@ #hash.eq Hash)) = - (..to-list reference) (..to-list sample))))) - - (structure: #export Hash (All [a] (Hash (Set a))) - (def: eq ..Equivalence) - - (def: (hash set) - (let [[Hash _] (:representation set)] - (list/fold (function (_ elem acc) (n/+ (:: Hash hash elem) acc)) - +0 - (..to-list set))))) - ) - -(def: #export empty? - (All [a] (-> (Set a) Bool)) - (|>> ..size (n/= +0))) - -(def: #export (from-list Hash xs) - (All [a] (-> (Hash a) (List a) (Set a))) - (list/fold ..add (..new Hash) xs)) - -(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)) diff --git a/stdlib/source/lux/data/coll/set/ordered.lux b/stdlib/source/lux/data/coll/set/ordered.lux deleted file mode 100644 index 2ad835849..000000000 --- a/stdlib/source/lux/data/coll/set/ordered.lux +++ /dev/null @@ -1,86 +0,0 @@ -(.module: - lux - (lux (control [equivalence #+ Equivalence] - [order #+ Order]) - (data (coll [list "list/" Fold] - (dictionary ["//" ordered]))) - (type abstract))) - -(abstract: #export (Set a) - {} - - (//.Dictionary a a) - - (def: #export new - (All [a] (-> (Order a) (Set a))) - (|>> //.new :abstraction)) - - (def: #export (member? set elem) - (All [a] (-> (Set a) a Bool)) - (|> set :representation (//.contains? elem))) - - (do-template [ ] - [(def: #export - (All [a] (-> (Set a) (Maybe a))) - (|>> :representation ))] - - [min //.min] - [max //.max] - ) - - (do-template [ ] - [(def: #export - (-> (Set Any) Nat) - (|>> :representation ))] - - [size //.size] - [depth //.depth] - ) - - (def: #export (add elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (//.put elem elem) :abstraction)) - - (def: #export (remove elem set) - (All [a] (-> a (Set a) (Set a))) - (|> set :representation (//.remove elem) :abstraction)) - - (def: #export to-list - (All [a] (-> (Set a) (List a))) - (|>> :representation //.keys)) - - (def: #export (from-list Order list) - (All [a] (-> (Order a) (List a) (Set a))) - (list/fold add (new Order) list)) - - (def: #export (union left right) - (All [a] (-> (Set a) (Set a) (Set a))) - (list/fold ..add right (..to-list left))) - - (def: #export (intersection left right) - (All [a] (-> (Set a) (Set a) (Set a))) - (|> (..to-list right) - (list.filter (..member? left)) - (..from-list (get@ #//.order (:representation right))))) - - (def: #export (difference param subject) - (All [a] (-> (Set a) (Set a) (Set a))) - (|> (..to-list subject) - (list.filter (|>> (..member? param) not)) - (..from-list (get@ #//.order (:representation subject))))) - - (structure: #export Equivalence (All [a] (Equivalence (Set a))) - (def: (= reference sample) - (:: (list.Equivalence (:: (:representation sample) eq)) - = (..to-list reference) (..to-list sample)))) - ) - -(def: #export (sub? super sub) - (All [a] (-> (Set a) (Set a) Bool)) - (|> sub - ..to-list - (list.every? (..member? super)))) - -(def: #export (super? sub super) - (All [a] (-> (Set a) (Set a) Bool)) - (sub? super sub)) diff --git a/stdlib/source/lux/data/coll/stack.lux b/stdlib/source/lux/data/coll/stack.lux deleted file mode 100644 index 8f93bdb69..000000000 --- a/stdlib/source/lux/data/coll/stack.lux +++ /dev/null @@ -1,42 +0,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/finger.lux b/stdlib/source/lux/data/coll/tree/finger.lux deleted file mode 100644 index ea1ff0eee..000000000 --- a/stdlib/source/lux/data/coll/tree/finger.lux +++ /dev/null @@ -1,61 +0,0 @@ -(.module: - lux - (lux (control ["m" monoid]) - (data text/format))) - -(type: #export (Node m a) - (#Leaf m a) - (#Branch m (Node m a) (Node m a))) - -(type: #export (Tree m a) - {#monoid (m.Monoid m) - #node (Node m a)}) - -(def: #export (tag tree) - (All [m a] (-> (Tree m a) m)) - (case (get@ #node tree) - (^or (#Leaf tag _) (#Branch tag _ _)) - tag)) - -(def: #export (value tree) - (All [m a] (-> (Tree m a) a)) - (case (get@ #node tree) - (#Leaf tag value) - value - - (#Branch tag left right) - (value (set@ #node left tree)))) - -(def: #export (branch left right) - (All [m a] (-> (Tree m a) (Tree m a) (Tree m a))) - (let [Monoid (get@ #monoid right)] - {#monoid Monoid - #node (#Branch (:: Monoid compose (tag left) (tag right)) - (get@ #node left) - (get@ #node right))})) - -(def: #export (search pred tree) - (All [m a] (-> (-> m Bool) (Tree m a) (Maybe a))) - (let [tag/compose (get@ [#monoid #m.compose] tree)] - (if (pred (tag tree)) - (loop [_tag (get@ [#monoid #m.identity] tree) - _node (get@ #node tree)] - (case _node - (#Leaf _ value) - (#.Some value) - - (#Branch _ left right) - (let [shifted-tag (tag/compose _tag (tag (set@ #node left tree)))] - (if (pred shifted-tag) - (recur _tag left) - (recur shifted-tag right))))) - #.None))) - -(def: #export (found? pred tree) - (All [m a] (-> (-> m Bool) (Tree m a) Bool)) - (case (search pred tree) - (#.Some _) - true - - #.None - false)) diff --git a/stdlib/source/lux/data/coll/tree/rose.lux b/stdlib/source/lux/data/coll/tree/rose.lux deleted file mode 100644 index 1fb5fc85a..000000000 --- a/stdlib/source/lux/data/coll/tree/rose.lux +++ /dev/null @@ -1,73 +0,0 @@ -(.module: - lux - (lux (control functor - [monad #+ do Monad] - equivalence - ["p" parser] - fold) - (data (coll [list "L/" Monad Fold])) - [macro] - (macro [code] - ["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) - (L/join (L/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-Code - [Code (List Tree-Code)]) - -(def: tree^ - (Syntax Tree-Code) - (|> (|>> p.some s.record (p.seq s.any)) - p.rec - p.some - s.record - (p.seq s.any) - s.tuple)) - -(syntax: #export (tree {root tree^}) - {#.doc (doc "Tree literals." - (tree Int [10 {20 {} - 30 {} - 40 {}}]))} - (wrap (list (` (~ (loop [[value children] root] - (` {#value (~ value) - #children (list (~+ (L/map recur children)))}))))))) - -## [Structs] -(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) - (def: (= tx ty) - (and (:: Equivalence = (get@ #value tx) (get@ #value ty)) - (:: (list.Equivalence (Equivalence Equivalence)) = (get@ #children tx) (get@ #children ty))))) - -(structure: #export _ (Functor Tree) - (def: (map f fa) - {#value (f (get@ #value fa)) - #children (L/map (map f) - (get@ #children fa))})) - -(structure: #export _ (Fold Tree) - (def: (fold f init tree) - (L/fold (function (_ tree' init') (fold f init' tree')) - (f (get@ #value tree) - init) - (get@ #children tree)))) diff --git a/stdlib/source/lux/data/coll/tree/rose/parser.lux b/stdlib/source/lux/data/coll/tree/rose/parser.lux deleted file mode 100644 index 3e3535649..000000000 --- a/stdlib/source/lux/data/coll/tree/rose/parser.lux +++ /dev/null @@ -1,50 +0,0 @@ -(.module: - lux - (lux (control ["p" parser] - ["ex" exception #+ exception:]) - (data ["E" error])) - [// #+ Tree] - (// [zipper #+ Zipper])) - -(type: #export (Parser t a) - (p.Parser (Zipper t) a)) - -(def: #export (run-zipper zipper parser) - (All [t a] (-> (Zipper t) (Parser t a) (E.Error a))) - (case (p.run zipper parser) - (#E.Success [zipper output]) - (#E.Success output) - - (#E.Error error) - (#E.Error error))) - -(def: #export (run tree parser) - (All [t a] (-> (Tree t) (Parser t a) (E.Error a))) - (run-zipper (zipper.zip tree) parser)) - -(def: #export value - (All [t] (Parser t t)) - (function (_ zipper) - (#E.Success [zipper (zipper.value zipper)]))) - -(exception: #export cannot-move-further) - -(do-template [ ] - [(def: #export - (All [t] (Parser t [])) - (function (_ zipper) - (let [next ( zipper)] - (if (is? zipper next) - (ex.throw cannot-move-further []) - (#E.Success [next []])))))] - - [up zipper.up] - [down zipper.down] - [left zipper.left] - [right zipper.right] - [root zipper.root] - [rightmost zipper.rightmost] - [leftmost zipper.leftmost] - [next zipper.next] - [prev zipper.prev] - ) diff --git a/stdlib/source/lux/data/coll/tree/rose/zipper.lux b/stdlib/source/lux/data/coll/tree/rose/zipper.lux deleted file mode 100644 index ba47b9f0a..000000000 --- a/stdlib/source/lux/data/coll/tree/rose/zipper.lux +++ /dev/null @@ -1,235 +0,0 @@ -(.module: - lux - (lux (control functor - comonad) - (data (coll [list "L/" Monad Fold Monoid] - (tree [rose #+ Tree "T/" Functor]) - [stack #+ Stack]) - [maybe "M/" Monad]) - [macro] - (macro [code] - ["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 (zip tree) - (All [a] (-> (Tree a) (Zipper a))) - {#parent #.None - #lefts stack.empty - #rights stack.empty - #node tree}) - -(def: #export (unzip zipper) - (All [a] (-> (Zipper a) (Tree a))) - (get@ #node zipper)) - -(def: #export (value zipper) - (All [a] (-> (Zipper a) a)) - (|> zipper (get@ [#node #rose.value]))) - -(def: #export (children zipper) - (All [a] (-> (Zipper a) (List (Tree a)))) - (|> zipper (get@ [#node #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 (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)) - -(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 - ## TODO: Remove once new-luxc becomes the standard compiler. - (update@ #node (: (-> (Tree ($ +0)) (Tree ($ +0))) - (function (_ node) - (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) - (#.Cons (get@ #node zipper) - (get@ #rights zipper))) - node)))) - ## (update@ #node (function (_ node) - ## (set@ #rose.children (L/compose (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@ (function (_ op-side) - (#.Cons (get@ #node zipper) op-side))) - (set@ side') - (set@ #node next)))) - - (def: #export ( zipper) - (All [a] (-> (Zipper a) (Zipper a))) - (L/fold (function (_ _) ) zipper (get@ zipper)))] - - [right rightmost #rights #lefts] - [left leftmost #lefts #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 (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] - (function (_ children) - ## TODO: Remove once new-luxc becomes the standard compiler. - (list& (: (Tree ($ +0)) - (rose.tree [value {}])) - children) - ## (list& (rose.tree [value {}]) - ## children) - ) - zipper)) - -(def: #export (append-child value zipper) - (All [a] (-> a (Zipper a) (Zipper a))) - (update@ [#node #rose.children] - (function (_ children) - (L/compose children - ## TODO: Remove once new-luxc becomes the standard compiler. - (list (: (Tree ($ +0)) - (rose.tree [value {}]))) - ## (list (rose.tree [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 (maybe.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@ (function (_ side) - ## TODO: Remove once new-luxc becomes the standard compiler. - (#.Cons (: (Tree ($ +0)) - (rose.tree [value {}])) - side) - ## (#.Cons (rose.tree [value {}]) - ## side) - ))))))] - - [insert-left #lefts] - [insert-right #rights] - ) - -(structure: #export _ (Functor Zipper) - (def: (map f fa) - {#parent (|> fa (get@ #parent) (M/map (map f))) - #lefts (|> fa (get@ #lefts) (L/map (T/map f))) - #rights (|> fa (get@ #rights) (L/map (T/map f))) - #node (T/map f (get@ #node fa))})) - -## TODO: Add again once new-luxc becomes the standard compiler. -## (structure: #export _ (CoMonad Zipper) -## (def: functor Functor) - -## (def: unwrap (get@ [#node #rose.value])) - -## (def: (split wa) -## (let [tree-splitter (function (tree-splitter tree) -## {#rose.value (zip tree) -## #rose.children (L/map tree-splitter -## (get@ #rose.children tree))})] -## {#parent (|> wa (get@ #parent) (M/map split)) -## #lefts (|> wa (get@ #lefts) (L/map tree-splitter)) -## #rights (|> wa (get@ #rights) (L/map tree-splitter)) -## #node (|> fa (get@ #node) tree-splitter)}))) diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux new file mode 100644 index 000000000..46d5a9572 --- /dev/null +++ b/stdlib/source/lux/data/collection/array.lux @@ -0,0 +1,211 @@ +(.module: + lux + (lux (control [monoid #+ Monoid] + [functor #+ Functor] + [equivalence #+ Equivalence] + fold) + (data (collection [list "list/" Fold]) + [product]) + )) + +(def: #export (new size) + (All [a] (-> Nat (Array a))) + ("lux array new" size)) + +(def: #export (size xs) + (All [a] (-> (Array a) Nat)) + ("lux array size" xs)) + +(def: #export (read i xs) + (All [a] + (-> Nat (Array a) (Maybe a))) + ("lux array get" xs i)) + +(def: #export (write i x xs) + (All [a] + (-> Nat a (Array a) (Array a))) + ("lux array put" xs i x)) + +(def: #export (delete i xs) + (All [a] + (-> Nat (Array a) (Array a))) + ("lux 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 (function (_ offset target) + (case (read (n/+ offset src-start) src-array) + #.None + target + + (#.Some value) + (write (n/+ offset dest-start) value target))) + dest-array + (list.n/range +0 (dec length))))) + +(def: #export (occupied array) + {#.doc "Finds out how many cells in an array are occupied."} + (All [a] (-> (Array a) Nat)) + (list/fold (function (_ idx count) + (case (read idx array) + #.None + count + + (#.Some _) + (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 (function (_ idx xs') + (case (read idx xs) + #.None + xs' + + (#.Some x) + (if (p x) + xs' + (delete 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 (read idx xs) + #.None + (recur (inc idx)) + + (#.Some x) + (if (p x) + (#.Some x) + (recur (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 (read idx xs) + #.None + (recur (inc idx)) + + (#.Some x) + (if (p idx x) + (#.Some [idx x]) + (recur (inc idx)))) + #.None)))) + +(def: #export (clone xs) + (All [a] (-> (Array a) (Array a))) + (let [arr-size (size xs)] + (list/fold (function (_ idx ys) + (case (read idx xs) + #.None + ys + + (#.Some x) + (write 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 (function (_ x [idx arr]) + [(inc idx) (write idx x arr)]) + [+0 (new (list.size xs))] + xs))) + +(def: underflow Nat (dec +0)) + +(def: #export (to-list array) + (All [a] (-> (Array a) (List a))) + (loop [idx (dec (size array)) + output #.Nil] + (if (n/= underflow idx) + output + (recur (dec idx) + (case (read idx array) + (#.Some head) + (#.Cons head output) + + #.None + output))))) + +(structure: #export (Equivalence Equivalence) + (All [a] (-> (Equivalence a) (Equivalence (Array a)))) + (def: (= xs ys) + (let [sxs (size xs) + sxy (size ys)] + (and (n/= sxy sxs) + (list/fold (function (_ idx prev) + (and prev + (case [(read idx xs) (read idx ys)] + [#.None #.None] + true + + [(#.Some x) (#.Some y)] + (:: Equivalence = x y) + + _ + false))) + true + (list.n/range +0 (dec sxs))))) + )) + +(structure: #export Monoid (All [a] (Monoid (Array a))) + (def: identity (new +0)) + + (def: (compose xs ys) + (let [sxs (size xs) + sxy (size ys)] + (|> (new (n/+ sxy sxs)) + (copy sxs +0 xs +0) + (copy sxy +0 ys sxs))))) + +(structure: #export _ (Functor Array) + (def: (map f ma) + (let [arr-size (size ma)] + (if (n/= +0 arr-size) + (new arr-size) + (list/fold (function (_ idx mb) + (case (read idx ma) + #.None + mb + + (#.Some x) + (write idx (f x) mb))) + (new arr-size) + (list.n/range +0 (dec arr-size))) + )))) + +(structure: #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 (read idx xs) + #.None + (recur so-far (inc idx)) + + (#.Some value) + (recur (f value so-far) (inc idx))) + so-far))))) diff --git a/stdlib/source/lux/data/collection/bits.lux b/stdlib/source/lux/data/collection/bits.lux new file mode 100644 index 000000000..a7be3a240 --- /dev/null +++ b/stdlib/source/lux/data/collection/bits.lux @@ -0,0 +1,164 @@ +(.module: + [lux #- not and or] + (lux (control [equivalence #+ Equivalence] + pipe) + (data [maybe] + [bit] + (collection [array "array/" Fold]) + text/format))) + +(type: #export Chunk I64) + +(def: #export chunk-size bit.width) + +(type: #export Bits + (Array Chunk)) + +(def: empty-chunk Chunk (.i64 +0)) + +(def: #export empty + Bits + (array.new +0)) + +(def: #export (size bits) + (-> Bits Nat) + (array/fold (function (_ chunk total) + (|> chunk bit.count (n/+ total))) + +0 + bits)) + +(def: #export (capacity bits) + (-> Bits Nat) + (|> bits array.size (n/* chunk-size))) + +(def: #export empty? + (-> Bits Bool) + (|>> size (n/= +0))) + +(def: #export (get index bits) + (-> Nat Bits Bool) + (let [[chunk-index bit-index] (n//% chunk-size index)] + (.and (n/< (array.size bits) chunk-index) + (|> (array.read chunk-index bits) + (maybe.default empty-chunk) + (bit.set? bit-index))))) + +(def: (chunk idx bits) + (-> Nat Bits Chunk) + (if (n/< (array.size bits) idx) + (|> bits (array.read idx) (maybe.default empty-chunk)) + empty-chunk)) + +(do-template [ ] + [(def: #export ( index input) + (-> Nat Bits Bits) + (let [[chunk-index bit-index] (n//% chunk-size index)] + (loop [size|output (n/max (inc chunk-index) + (array.size input)) + output ..empty] + (let [idx|output (dec size|output)] + (if (n/> +0 size|output) + (case (|> (..chunk idx|output input) + (cond> [(new> (n/= chunk-index idx|output))] + [( bit-index)] + + ## else + []) + .nat) + +0 + ## TODO: Remove 'no-op' once new-luxc is the official compiler. + (let [no-op (recur (dec size|output) output)] + no-op) + + chunk + (|> (if (is? ..empty output) + (: Bits (array.new size|output)) + output) + (array.write idx|output (.i64 chunk)) + (recur (dec size|output)))) + output)))))] + + [set bit.set] + [clear bit.clear] + [flip bit.flip] + ) + +(def: #export (intersects? reference sample) + (-> Bits Bits Bool) + (let [chunks (n/min (array.size reference) + (array.size sample))] + (loop [idx +0] + (if (n/< chunks idx) + (.or (|> (..chunk idx sample) + (bit.and (..chunk idx reference)) + ("lux i64 =" empty-chunk) + .not) + (recur (inc idx))) + false)))) + +(def: #export (not input) + (-> Bits Bits) + (case (array.size input) + +0 + ..empty + + size|output + (loop [size|output size|output + output ..empty] + (let [idx (dec size|output)] + (case (|> input (..chunk idx) bit.not .nat) + +0 + (recur (dec size|output) output) + + chunk + (if (n/> +0 size|output) + (|> (if (is? ..empty output) + (: Bits (array.new size|output)) + output) + (array.write idx (.i64 chunk)) + (recur (dec size|output))) + output)))))) + +(do-template [ ] + [(def: #export ( param subject) + (-> Bits Bits Bits) + (case (n/max (array.size param) + (array.size subject)) + +0 + ..empty + + size|output + (loop [size|output size|output + output ..empty] + (let [idx (dec size|output)] + (if (n/> +0 size|output) + (case (|> (..chunk idx subject) + ( (..chunk idx param)) + .nat) + +0 + (recur (dec size|output) output) + + chunk + (|> (if (is? ..empty output) + (: Bits (array.new size|output)) + output) + (array.write idx (.i64 chunk)) + (recur (dec size|output)))) + output)))))] + + [and bit.and] + [or bit.or] + [xor bit.xor] + ) + +(structure: #export _ (Equivalence Bits) + (def: (= reference sample) + (let [size (n/max (array.size reference) + (array.size sample))] + (loop [idx +0] + (if (n/< size idx) + (.and ("lux i64 =" + (..chunk idx reference) + (..chunk idx sample)) + (recur (inc idx))) + true))))) diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux new file mode 100644 index 000000000..368a77469 --- /dev/null +++ b/stdlib/source/lux/data/collection/dictionary.lux @@ -0,0 +1,685 @@ +(.module: + lux + (lux (control hash + [equivalence #+ Equivalence]) + (data [maybe] + (collection [list "list/" Fold Functor Monoid] + [array "array/" Functor Fold]) + [bit] + [product] + [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 +## Dictionaries. +(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.left-shift (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.left-shift (n/- +1 branching-exponent) +1)) + +## The size of hierarchy-nodes, which is 2^(branching-exponent). +(def: hierarchy-nodes-size + Nat + (bit.left-shift 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.new (inc old-size)) + (array.copy idx +0 old-array +0) + (array.write idx value) + (array.copy (n/- idx old-size) idx old-array (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.write 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.delete 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 (dec (array.size array))] + (|> (array.new new-size) + (array.copy idx +0 array +0) + (array.copy (n/- idx new-size) (inc idx) array idx)))) + +## Given a top-limit for indices, produces all indices in [0, R). +(def: indices-for + (-> Nat (List Index)) + (|>> 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 (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.and hierarchy-mask + (bit.logical-right-shift level hash))) + +## A mechanism to go from indices to bit-positions. +(def: (->bit-position index) + (-> Index BitPosition) + (bit.left-shift 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.and 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.or bit bitmap)) + +(def: unset-bit-position + (-> BitPosition BitMap BitMap) + bit.xor) + +## 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) + 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.and (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))) + (:: maybe.Monad map product.left + (array.find+ (function (_ 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 (function (_ idx [insertion-idx node]) + (let [[bitmap base] node] + (case (array.read idx h-array) + #.None [insertion-idx node] + (#.Some sub-node) (if (n/= except-idx idx) + [insertion-idx node] + [(inc insertion-idx) + [(set-bit-position (->bit-position idx) bitmap) + (array.write insertion-idx (#.Left sub-node) base)]]) + ))) + [+0 [clean-bitmap + (array.new (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: hierarchy-indices (List Index) (indices-for hierarchy-nodes-size)) + +(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 (function (_ hierarchy-idx (^@ default [base-idx h-array])) + (if (bit-position-is-set? (->bit-position hierarchy-idx) + bitmap) + [(inc base-idx) + (case (array.read base-idx base) + (#.Some (#.Left sub-node)) + (array.write hierarchy-idx sub-node h-array) + + (#.Some (#.Right [key' val'])) + (array.write hierarchy-idx + (put' (level-up level) (:: Hash hash key') key' val' Hash empty) + h-array) + + #.None + (undefined))] + default)) + [+0 + (array.new hierarchy-nodes-size)] + hierarchy-indices))) + +## 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 (~~ (static ..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] (case (array.read idx hierarchy) + (#.Some sub-node) + [_size sub-node] + + _ + [(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.read 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.new +2) + (array.write +0 [key' val']) + (array.write +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 (inc base-count) + (|> (promote-base put' Hash level bitmap base) + (array.write (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) + (|> (array.new +1) + (array.write +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.read 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 (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.read 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 did not 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.read (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.read (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) + (:: maybe.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 (function (_ 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 (function (_ sub-node tail) (list/compose (entries' sub-node) tail)) + #.Nil + hierarchy) + + (#Base bitmap base) + (array/fold (function (_ branch tail) + (case branch + (#.Left sub-node) + (list/compose (entries' sub-node) tail) + + (#.Right [key' val']) + (#.Cons [key' val'] tail))) + #.Nil + base) + + (#Collisions hash colls) + (array/fold (function (_ [key' val'] tail) (#.Cons [key' val'] tail)) + #.Nil + colls))) + +## [Exports] +(type: #export (Dictionary 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) (Dictionary k v))) + {#hash Hash + #root empty}) + +(def: #export (put key val dict) + (All [k v] (-> k v (Dictionary k v) (Dictionary 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 (Dictionary k v) (Dictionary 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 (Dictionary k v) (Maybe v))) + (let [[Hash node] dict] + (get' root-level (:: Hash hash key) key Hash node))) + +(def: #export (contains? key dict) + (All [k v] (-> k (Dictionary k v) Bool)) + (case (get key dict) + #.None false + (#.Some _) true)) + +(def: #export (put~ key val dict) + {#.doc "Only puts the KV-pair if the key is not already present."} + (All [k v] (-> k v (Dictionary k v) (Dictionary k v))) + (if (contains? key dict) + dict + (put key val dict))) + +(def: #export (update key f dict) + {#.doc "Transforms the value located at key (if available), using the given function."} + (All [k v] (-> k (-> v v) (Dictionary k v) (Dictionary k v))) + (case (get key dict) + #.None + dict + + (#.Some val) + (put key (f val) dict))) + +(def: #export (update~ key default f dict) + {#.doc "Transforms the value located at key (if available), using the given function."} + (All [k v] (-> k v (-> v v) (Dictionary k v) (Dictionary k v))) + (put key + (f (maybe.default default + (get key dict))) + dict)) + +(def: #export size + (All [k v] (-> (Dictionary k v) Nat)) + (|>> product.right size')) + +(def: #export empty? + (All [k v] (-> (Dictionary k v) Bool)) + (|>> size (n/= +0))) + +(def: #export (entries dict) + (All [k v] (-> (Dictionary k v) (List [k v]))) + (entries' (product.right dict))) + +(def: #export (from-list Hash kvs) + (All [k v] (-> (Hash k) (List [k v]) (Dictionary k v))) + (list/fold (function (_ [k v] dict) + (put k v dict)) + (new Hash) + kvs)) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dictionary 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] (-> (Dictionary k v) (Dictionary k v) (Dictionary k v))) + (list/fold (function (_ [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) (Dictionary k v) (Dictionary k v) (Dictionary k v))) + (list/fold (function (_ [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 (Dictionary k v) (Dictionary 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) (Dictionary k v) (Dictionary k v))) + (let [[Hash _] dict] + (list/fold (function (_ key new-dict) + (case (get key dict) + #.None new-dict + (#.Some val) (put key val new-dict))) + (new Hash) + keys))) + +## [Structures] +(structure: #export (Equivalence Equivalence) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) + (def: (= test subject) + (and (n/= (size test) + (size subject)) + (list.every? (function (_ k) + (case [(get k test) (get k subject)] + [(#.Some tk) (#.Some sk)] + (:: Equivalence = tk sk) + + _ + false)) + (keys test))))) diff --git a/stdlib/source/lux/data/collection/dictionary/ordered.lux b/stdlib/source/lux/data/collection/dictionary/ordered.lux new file mode 100644 index 000000000..478b75a2a --- /dev/null +++ b/stdlib/source/lux/data/collection/dictionary/ordered.lux @@ -0,0 +1,569 @@ +(.module: + lux + (lux (control [monad #+ do Monad] + equivalence + [order #+ Order]) + (data (collection [list "L/" Monad Monoid Fold]) + ["p" product] + [maybe]) + [macro] + (macro [code] + ["s" syntax #+ syntax: Syntax]))) + +(def: error-message Text "Invariant violation") + +(type: Color #Red #Black) + +(type: (Node k v) + {#color Color + #key k + #value v + #left (Maybe (Node k v)) + #right (Maybe (Node k v))}) + +(do-template [ ] + [(def: ( key value left right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + {#color + #key key + #value value + #left left + #right right})] + + [red #Red] + [black #Black] + ) + +(type: #export (Dictionary k v) + {#order (Order k) + #root (Maybe (Node k v))}) + +(def: #export (new Order) + (All [k v] (-> (Order k) (Dictionary k v))) + {#order Order + #root #.None}) + +## TODO: Doing inneficient access of Order functions due to compiler bug. +## TODO: Must improve it as soon as bug is fixed. +(def: #export (get key dict) + (All [k v] (-> k (Dictionary k v) (Maybe v))) + (let [## (^open "T/") (get@ #order dict) + ] + (loop [node (get@ #root dict)] + (case node + #.None + #.None + + (#.Some node) + (let [node-key (get@ #key node)] + (cond (:: dict = node-key key) + ## (T/= node-key key) + (#.Some (get@ #value node)) + + (:: dict < node-key key) + ## (T/< node-key key) + (recur (get@ #left node)) + + ## (T/> (get@ #key node) key) + (recur (get@ #right node)))) + )))) + +(def: #export (contains? key dict) + (All [k v] (-> k (Dictionary k v) Bool)) + (let [## (^open "T/") (get@ #order dict) + ] + (loop [node (get@ #root dict)] + (case node + #.None + false + + (#.Some node) + (let [node-key (get@ #key node)] + (or (:: dict = node-key key) + ## (T/= node-key key) + (if (:: dict < node-key key) + ## (T/< node-key key) + (recur (get@ #left node)) + (recur (get@ #right node))))))))) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dictionary k v) (Maybe v))) + (case (get@ #root dict) + #.None + #.None + + (#.Some node) + (loop [node node] + (case (get@ node) + #.None + (#.Some (get@ #value node)) + + (#.Some side) + (recur side)))))] + + [min #left] + [max #right] + ) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dictionary k v) Nat)) + (loop [node (get@ #root dict)] + (case node + #.None + +0 + + (#.Some node) + (inc ( (recur (get@ #left node)) + (recur (get@ #right node)))))))] + + [size n/+] + [depth n/max] + ) + +(do-template [ ] + [(def: ( self) + (All [k v] (-> (Node k v) (Node k v))) + (case (get@ #color self) + + (set@ #color self) + + + + ))] + + [blacken #Red #Black self] + [redden #Black #Red (error! error-message)] + ) + +(def: (balance-left-add parent self) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (with-expansions + [ (as-is (black (get@ #key parent) + (get@ #value parent) + (#.Some self) + (get@ #right parent)))] + (case (get@ #color self) + #Red + (case (get@ #left self) + (^multi (#.Some left) + [(get@ #color left) #Red]) + (red (get@ #key self) + (get@ #value self) + (#.Some (blacken left)) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #right self) + (get@ #right parent)))) + + _ + (case (get@ #right self) + (^multi (#.Some right) + [(get@ #color right) #Red]) + (red (get@ #key right) + (get@ #value right) + (#.Some (black (get@ #key self) + (get@ #value self) + (get@ #left self) + (get@ #left right))) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #right right) + (get@ #right parent)))) + + _ + )) + + #Black + + ))) + +(def: (balance-right-add parent self) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (with-expansions + [ (as-is (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (#.Some self)))] + (case (get@ #color self) + #Red + (case (get@ #right self) + (^multi (#.Some right) + [(get@ #color right) #Red]) + (red (get@ #key self) + (get@ #value self) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (get@ #left self))) + (#.Some (blacken right))) + + _ + (case (get@ #left self) + (^multi (#.Some left) + [(get@ #color left) #Red]) + (red (get@ #key left) + (get@ #value left) + (#.Some (black (get@ #key parent) + (get@ #value parent) + (get@ #left parent) + (get@ #left left))) + (#.Some (black (get@ #key self) + (get@ #value self) + (get@ #right left) + (get@ #right self)))) + + _ + )) + + #Black + + ))) + +(def: (add-left addition center) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (case (get@ #color center) + #Red + (red (get@ #key center) (get@ #value center) (#.Some addition) (get@ #right center)) + + #Black + (balance-left-add center addition) + )) + +(def: (add-right addition center) + (All [k v] (-> (Node k v) (Node k v) (Node k v))) + (case (get@ #color center) + #Red + (red (get@ #key center) (get@ #value center) (get@ #left center) (#.Some addition)) + + #Black + (balance-right-add center addition) + )) + +(def: #export (put key value dict) + (All [k v] (-> k v (Dictionary k v) (Dictionary k v))) + (let [(^open "T/") (get@ #order dict) + root' (loop [?root (get@ #root dict)] + (case ?root + #.None + (#.Some (red key value #.None #.None)) + + (#.Some root) + (let [reference (get@ #key root)] + (`` (cond (~~ (do-template [ ] + [( reference key) + (let [side-root (get@ root) + outcome (recur side-root)] + (if (is? side-root outcome) + ?root + (#.Some ( (maybe.assume outcome) + root))))] + + [T/< #left add-left] + [T/> #right add-right] + )) + + ## (T/= reference key) + ?root + ))) + ))] + (set@ #root root' dict))) + +(def: (left-balance key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?left + (^multi (#.Some left) + [(get@ #color left) #Red] + [(get@ #left left) (#.Some left>>left)] + [(get@ #color left>>left) #Red]) + (red (get@ #key left) + (get@ #value left) + (#.Some (blacken left>>left)) + (#.Some (black key value (get@ #right left) ?right))) + + (^multi (#.Some left) + [(get@ #color left) #Red] + [(get@ #right left) (#.Some left>>right)] + [(get@ #color left>>right) #Red]) + (red (get@ #key left>>right) + (get@ #value left>>right) + (#.Some (black (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left left>>right))) + (#.Some (black key value + (get@ #right left>>right) + ?right))) + + _ + (black key value ?left ?right))) + +(def: (right-balance key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?right + (^multi (#.Some right) + [(get@ #color right) #Red] + [(get@ #right right) (#.Some right>>right)] + [(get@ #color right>>right) #Red]) + (red (get@ #key right) + (get@ #value right) + (#.Some (black key value ?left (get@ #left right))) + (#.Some (blacken right>>right))) + + (^multi (#.Some right) + [(get@ #color right) #Red] + [(get@ #left right) (#.Some right>>left)] + [(get@ #color right>>left) #Red]) + (red (get@ #key right>>left) + (get@ #value right>>left) + (#.Some (black key value ?left (get@ #left right>>left))) + (#.Some (black (get@ #key right) + (get@ #value right) + (get@ #right right>>left) + (get@ #right right)))) + + _ + (black key value ?left ?right))) + +(def: (balance-left-remove key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?left + (^multi (#.Some left) + [(get@ #color left) #Red]) + (red key value (#.Some (blacken left)) ?right) + + _ + (case ?right + (^multi (#.Some right) + [(get@ #color right) #Black]) + (right-balance key value ?left (#.Some (redden right))) + + (^multi (#.Some right) + [(get@ #color right) #Red] + [(get@ #left right) (#.Some right>>left)] + [(get@ #color right>>left) #Black]) + (red (get@ #key right>>left) + (get@ #value right>>left) + (#.Some (black key value ?left (get@ #left right>>left))) + (#.Some (right-balance (get@ #key right) + (get@ #value right) + (get@ #right right>>left) + (:: maybe.Functor map redden (get@ #right right))))) + + _ + (error! error-message)) + )) + +(def: (balance-right-remove key value ?left ?right) + (All [k v] (-> k v (Maybe (Node k v)) (Maybe (Node k v)) (Node k v))) + (case ?right + (^multi (#.Some right) + [(get@ #color right) #Red]) + (red key value ?left (#.Some (blacken right))) + + _ + (case ?left + (^multi (#.Some left) + [(get@ #color left) #Black]) + (left-balance key value (#.Some (redden left)) ?right) + + (^multi (#.Some left) + [(get@ #color left) #Red] + [(get@ #right left) (#.Some left>>right)] + [(get@ #color left>>right) #Black]) + (red (get@ #key left>>right) + (get@ #value left>>right) + (#.Some (left-balance (get@ #key left) + (get@ #value left) + (:: maybe.Functor map redden (get@ #left left)) + (get@ #left left>>right))) + (#.Some (black key value (get@ #right left>>right) ?right))) + + _ + (error! error-message) + ))) + +(def: (prepend ?left ?right) + (All [k v] (-> (Maybe (Node k v)) (Maybe (Node k v)) (Maybe (Node k v)))) + (case [?left ?right] + [#.None _] + ?right + + [_ #.None] + ?left + + [(#.Some left) (#.Some right)] + (case [(get@ #color left) (get@ #color right)] + [#Red #Red] + (do maybe.Monad + [fused (prepend (get@ #right left) (get@ #right right))] + (case (get@ #color fused) + #Red + (wrap (red (get@ #key fused) + (get@ #value fused) + (#.Some (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left fused))) + (#.Some (red (get@ #key right) + (get@ #value right) + (get@ #right fused) + (get@ #right right))))) + + #Black + (wrap (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (#.Some (red (get@ #key right) + (get@ #value right) + (#.Some fused) + (get@ #right right))))))) + + [#Red #Black] + (#.Some (red (get@ #key left) + (get@ #value left) + (get@ #left left) + (prepend (get@ #right left) + ?right))) + + [#Black #Red] + (#.Some (red (get@ #key right) + (get@ #value right) + (prepend ?left + (get@ #left right)) + (get@ #right right))) + + [#Black #Black] + (do maybe.Monad + [fused (prepend (get@ #right left) (get@ #left right))] + (case (get@ #color fused) + #Red + (wrap (red (get@ #key fused) + (get@ #value fused) + (#.Some (black (get@ #key left) + (get@ #value left) + (get@ #left left) + (get@ #left fused))) + (#.Some (black (get@ #key right) + (get@ #value right) + (get@ #right fused) + (get@ #right right))))) + + #Black + (wrap (balance-left-remove (get@ #key left) + (get@ #value left) + (get@ #left left) + (#.Some (black (get@ #key right) + (get@ #value right) + (#.Some fused) + (get@ #right right))))) + )) + ) + + _ + (undefined))) + +(def: #export (remove key dict) + (All [k v] (-> k (Dictionary k v) (Dictionary k v))) + (let [(^open "T/") (get@ #order dict) + [?root found?] (loop [?root (get@ #root dict)] + (case ?root + #.None + [#.None false] + + (#.Some root) + (let [root-key (get@ #key root) + root-val (get@ #value root)] + (if (T/= root-key key) + [(prepend (get@ #left root) + (get@ #right root)) + true] + (let [go-left? (T/< root-key key)] + (case (recur (if go-left? + (get@ #left root) + (get@ #right root))) + [#.None false] + [#.None false] + + [side-outcome _] + (if go-left? + (case (get@ #left root) + (^multi (#.Some left) + [(get@ #color left) #Black]) + [(#.Some (balance-left-remove root-key root-val side-outcome (get@ #right root))) + false] + + _ + [(#.Some (red root-key root-val side-outcome (get@ #right root))) + false]) + (case (get@ #right root) + (^multi (#.Some right) + [(get@ #color right) #Black]) + [(#.Some (balance-right-remove root-key root-val (get@ #left root) side-outcome)) + false] + + _ + [(#.Some (red root-key root-val (get@ #left root) side-outcome)) + false]) + ))) + )) + ))] + (case ?root + #.None + (if found? + (set@ #root ?root dict) + dict) + + (#.Some root) + (set@ #root (#.Some (blacken root)) dict) + ))) + +(def: #export (update key transform dict) + (All [k v] (-> k (-> v v) (Dictionary k v) (Maybe (Dictionary k v)))) + (do maybe.Monad + [old (get key dict)] + (wrap (put key (transform old) dict)))) + +(def: #export (from-list Order list) + (All [k v] (-> (Order k) (List [k v]) (Dictionary k v))) + (L/fold (function (_ [key value] dict) + (put key value dict)) + (new Order) + list)) + +(do-template [ ] + [(def: #export ( dict) + (All [k v] (-> (Dictionary k v) (List ))) + (loop [node (get@ #root dict)] + (case node + #.None + (list) + + (#.Some node') + ($_ L/compose + (recur (get@ #left node')) + (list ) + (recur (get@ #right node'))))))] + + [entries [k v] [(get@ #key node') (get@ #value node')]] + [keys k (get@ #key node')] + [values v (get@ #value node')] + ) + +(structure: #export (Equivalence Equivalence) (All [k v] (-> (Equivalence v) (Equivalence (Dictionary k v)))) + (def: (= reference sample) + (let [Equivalence (:: sample eq)] + (loop [entriesR (entries reference) + entriesS (entries sample)] + (case [entriesR entriesS] + [#.Nil #.Nil] + true + + [(#.Cons [keyR valueR] entriesR') (#.Cons [keyS valueS] entriesS')] + (and (:: Equivalence = keyR keyS) + (:: Equivalence = valueR valueS) + (recur entriesR' entriesS')) + + _ + false))))) diff --git a/stdlib/source/lux/data/collection/dictionary/plist.lux b/stdlib/source/lux/data/collection/dictionary/plist.lux new file mode 100644 index 000000000..c483a3287 --- /dev/null +++ b/stdlib/source/lux/data/collection/dictionary/plist.lux @@ -0,0 +1,62 @@ +(.module: + lux + (lux (data [text "text/" Equivalence]))) + +(type: #export (PList a) + (List [Text a])) + +(def: #export (get key properties) + (All [a] (-> Text (PList a) (Maybe a))) + (case properties + #.Nil + #.None + + (#.Cons [k' v'] properties') + (if (text/= key k') + (#.Some v') + (get key properties')))) + +(def: #export (contains? key properties) + (All [a] (-> Text (PList a) Bool)) + (case (get key properties) + (#.Some _) + true + + #.None + false)) + +(def: #export (put key val properties) + (All [a] (-> Text a (PList a) (PList a))) + (case properties + #.Nil + (list [key val]) + + (#.Cons [k' v'] properties') + (if (text/= key k') + (#.Cons [key val] + properties') + (#.Cons [k' v'] + (put key val properties'))))) + +(def: #export (update key f properties) + (All [a] (-> Text (-> a a) (PList a) (PList a))) + (case properties + #.Nil + #.Nil + + (#.Cons [k' v'] properties') + (if (text/= key k') + (#.Cons [k' (f v')] properties') + (#.Cons [k' v'] (update key f properties'))))) + +(def: #export (remove key properties) + (All [a] (-> Text (PList a) (PList a))) + (case properties + #.Nil + properties + + (#.Cons [k' v'] properties') + (if (text/= key k') + properties' + (#.Cons [k' v'] + (remove key properties'))))) diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux new file mode 100644 index 000000000..74ef2e5cc --- /dev/null +++ b/stdlib/source/lux/data/collection/list.lux @@ -0,0 +1,554 @@ +(.module: + lux + (lux (control [monoid #+ Monoid] + [functor #+ Functor] + [apply #+ Apply] + [monad #+ do Monad] + [equivalence #+ Equivalence] + [fold]) + (data [number "nat/" Codec] + bool + [product]))) + +## [Types] +## (type: (List a) +## #Nil +## (#Cons a (List a))) + +## [Functions] +(structure: #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 (function (_ 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 do not."} + (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 (dec n) xs')]) #.Nil] + [drop (drop (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 (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 (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 (search check xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (Maybe b))) + (case xs + #.Nil + #.None + + (#.Cons [x xs']) + (case (check x) + (#.Some output) + (#.Some output) + + #.None + (search check xs')))) + +(def: #export (search-all check xs) + (All [a b] + (-> (-> a (Maybe b)) (List a) (List b))) + (case xs + #.Nil + #.None + + (#.Cons [x xs']) + (case (check x) + (#.Some output) + (#.Cons output (search-all check xs')) + + #.None + (search-all check 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 (function (_ _ acc) (n/+ +1 acc)) +0 list)) + +(do-template [ ] + [(def: #export ( p xs) + (All [a] + (-> (-> a Bool) (List a) Bool)) + (loop [xs xs] + (case xs + #.Nil + + + (#.Cons x xs') + (case (p x) + + (recur xs') + + output + output))))] + + [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 (dec i) xs')))) + +## [Structures] +(structure: #export (Equivalence Equivalence) + (All [a] (-> (Equivalence a) (Equivalence (List a)))) + (def: (= xs ys) + (case [xs ys] + [#.Nil #.Nil] + true + + [(#.Cons x xs') (#.Cons y ys')] + (and (:: Equivalence = x y) + (= xs' ys')) + + [_ _] + false + ))) + +(structure: #export Monoid (All [a] + (Monoid (List a))) + (def: identity #.Nil) + (def: (compose xs ys) + (case xs + #.Nil ys + (#.Cons x xs') (#.Cons x (compose xs' ys))))) + +(open: Monoid) + +(structure: #export _ (Functor List) + (def: (map f ma) + (case ma + #.Nil #.Nil + (#.Cons a ma') (#.Cons (f a) (map f ma'))))) + +(open: Functor) + +(structure: #export _ (Apply List) + (def: functor Functor) + + (def: (apply ff fa) + (case ff + #.Nil + #.Nil + + (#.Cons f ff') + (compose (map f fa) (apply ff' fa))))) + +(structure: #export _ (Monad List) + (def: functor Functor) + + (def: (wrap a) + (#.Cons a #.Nil)) + + (def: join (|>> reverse (fold compose identity)))) + +## [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 (function (_ x' [pre post]) + (if (< x x') + [(#.Cons x' pre) post] + [pre (#.Cons x' post)])) + [(list) (list)] + xs')] + ($_ compose (sort < pre) (list x) (sort < post))))) + +(do-template [ ] + [(def: #export ( from to) + {#.doc "Generates an inclusive interval of values [from, to]."} + (-> (List )) + (cond ( to from) + (list& from ( (inc from) to)) + + ( to from) + (list& from ( (dec from) to)) + + ## (= to from) + (list from)))] + + [i/range Int i/< i/>] + [n/range Nat n/< n/>] + ) + +(def: #export (empty? xs) + (All [a] (-> (List a) Bool)) + (case xs + #.Nil true + _ false)) + +(def: #export (member? eq xs x) + (All [a] (-> (Equivalence 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 Code) + [["" +0 +0] (#.Symbol "" 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 [_ (#.Nat num-lists)])) + (if (n/> +0 num-lists) + (let [(^open) Functor + indices (n/range +0 (dec num-lists)) + type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) + zip-type (` (All [(~+ type-vars)] + (-> (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) + type-vars)) + (List [(~+ type-vars)])))) + vars+lists (|> indices + (map inc) + (map (function (_ idx) + (let [base (nat/encode idx)] + [(symbol$ base) + (symbol$ ("lux text concat" base "'"))])))) + pattern (` [(~+ (map (function (_ [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) + (function ((~ 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 "Cannot 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 [_ (#.Nat num-lists)])) + (if (n/> +0 num-lists) + (let [(^open) Functor + indices (n/range +0 (dec num-lists)) + g!return-type (symbol$ "\treturn-type\t") + g!func (symbol$ "\tfunc\t") + type-vars (: (List Code) (map (|>> nat/encode symbol$) indices)) + zip-type (` (All [(~+ type-vars) (~ g!return-type)] + (-> (-> (~+ type-vars) (~ g!return-type)) + (~+ (map (: (-> Code Code) (function (_ var) (` (List (~ var))))) + type-vars)) + (List (~ g!return-type))))) + vars+lists (|> indices + (map inc) + (map (function (_ idx) + (let [base (nat/encode idx)] + [(symbol$ base) + (symbol$ ("lux text concat" base "'"))])))) + pattern (` [(~+ (map (function (_ [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) + (function ((~ 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 "Cannot 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)) + +(structure: #export (ListT Monad) + (All [M] (-> (Monad M) (Monad (All [a] (M (List a)))))) + + (def: functor (functor.compose (get@ #monad.functor Monad) Functor)) + + (def: wrap (|>> (:: Monad wrap) (:: Monad wrap))) + + (def: (join MlMla) + (do Monad + [lMla MlMla + ## TODO: Remove this version ASAP and use one below. + lla (: (($ +0) (List (List ($ +1)))) + (monad.seq @ lMla)) + ## lla (monad.seq @ lMla) + ] + (wrap (concat lla))))) + +(def: #export (lift Monad) + (All [M a] (-> (Monad M) (-> (M a) (M (List a))))) + (monad.lift 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' (inc idx) xs')))) + +(def: #export (enumerate xs) + {#.doc "Pairs every element in the list with its 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 dec (n/range +0)))) diff --git a/stdlib/source/lux/data/collection/queue.lux b/stdlib/source/lux/data/collection/queue.lux new file mode 100644 index 000000000..a0206a9eb --- /dev/null +++ b/stdlib/source/lux/data/collection/queue.lux @@ -0,0 +1,78 @@ +(.module: + lux + (lux (control [equivalence #+ Equivalence] + ["F" functor]) + (data (collection [list "L/" Monoid Functor])))) + +(type: #export (Queue a) + {#front (List a) + #rear (List a)}) + +(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] + (L/compose 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? Equivalence queue member) + (All [a] (-> (Equivalence a) (Queue a) a Bool)) + (let [(^slots [#front #rear]) queue] + (or (list.member? Equivalence front member) + (list.member? Equivalence rear member)))) + +(def: #export (pop queue) + (All [a] (-> (Queue a) (Queue a))) + (case (get@ #front queue) + (^ (list)) ## Empty... + 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))) + +(structure: #export (Equivalence Equivalence) + (All [a] (-> (Equivalence a) (Equivalence (Queue a)))) + (def: (= qx qy) + (:: (list.Equivalence Equivalence) = (to-list qx) (to-list qy)))) + +(structure: #export _ (F.Functor Queue) + (def: (map f fa) + {#front (|> fa (get@ #front) (L/map f)) + #rear (|> fa (get@ #rear) (L/map f))})) diff --git a/stdlib/source/lux/data/collection/queue/priority.lux b/stdlib/source/lux/data/collection/queue/priority.lux new file mode 100644 index 000000000..d697b91c7 --- /dev/null +++ b/stdlib/source/lux/data/collection/queue/priority.lux @@ -0,0 +1,102 @@ +(.module: + lux + (lux (control [equivalence #+ Equivalence] + [monad #+ do Monad]) + (data (collection (tree [finger #+ Tree])) + [number "nat/" Interval] + [maybe]))) + +(type: #export Priority Nat) + +(type: #export (Queue a) + (Maybe (Tree Priority a))) + +(def: #export max Priority nat/top) +(def: #export min Priority nat/bottom) + +(def: #export empty + Queue + #.None) + +(def: #export (peek queue) + (All [a] (-> (Queue a) (Maybe a))) + (do maybe.Monad + [fingers queue] + (wrap (maybe.assume (finger.search (n/= (finger.tag fingers)) fingers))))) + +(def: #export (size queue) + (All [a] (-> (Queue a) Nat)) + (case queue + #.None + +0 + + (#.Some fingers) + (loop [node (get@ #finger.node fingers)] + (case node + (#finger.Leaf _ _) + +1 + + (#finger.Branch _ left right) + (n/+ (recur left) (recur right)))))) + +(def: #export (member? Equivalence queue member) + (All [a] (-> (Equivalence a) (Queue a) a Bool)) + (case queue + #.None + false + + (#.Some fingers) + (loop [node (get@ #finger.node fingers)] + (case node + (#finger.Leaf _ reference) + (:: Equivalence = reference member) + + (#finger.Branch _ left right) + (or (recur left) + (recur right)))))) + +(def: #export (pop queue) + (All [a] (-> (Queue a) (Queue a))) + (do maybe.Monad + [fingers queue + #let [highest-priority (finger.tag fingers)] + node' (loop [node (get@ #finger.node fingers)] + (case node + (#finger.Leaf priority reference) + (if (n/= highest-priority priority) + #.None + (#.Some node)) + + (#finger.Branch priority left right) + (if (n/= highest-priority (finger.tag (set@ #finger.node left fingers))) + (case (recur left) + #.None + (#.Some right) + + (#.Some =left) + (|> (finger.branch (set@ #finger.node =left fingers) + (set@ #finger.node right fingers)) + (get@ #finger.node) + #.Some)) + (case (recur right) + #.None + (#.Some left) + + (#.Some =right) + (|> (finger.branch (set@ #finger.node left fingers) + (set@ #finger.node =right fingers)) + (get@ #finger.node) + #.Some)) + )))] + (wrap (set@ #finger.node node' fingers)))) + +(def: #export (push priority value queue) + (All [a] (-> Priority a (Queue a) (Queue a))) + (let [addition {#finger.monoid number.Max@Monoid + #finger.node (#finger.Leaf priority value)}] + (case queue + #.None + (#.Some addition) + + (#.Some fingers) + (#.Some (finger.branch fingers addition))))) diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux new file mode 100644 index 000000000..ca38f4961 --- /dev/null +++ b/stdlib/source/lux/data/collection/row.lux @@ -0,0 +1,437 @@ +(.module: + lux + (lux (control [functor #+ Functor] + [apply #+ Apply] + [monad #+ do Monad] + [equivalence #+ Equivalence] + monoid + fold + ["p" parser]) + (data [maybe] + (collection [list "list/" Fold Functor Monoid] + [array "array/" Functor Fold]) + [bit] + [product]) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax: Syntax]) + )) + +## [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.left-shift branching-exponent +1)) + +(def: branch-idx-mask + Nat + (dec full-node-size)) + +(def: branch-idx + (-> Index Index) + (bit.and branch-idx-mask)) + +(def: (new-hierarchy _) + (All [a] (-> Any (Hierarchy a))) + (array.new full-node-size)) + +(def: (tail-off vec-size) + (-> Nat Nat) + (if (n/< full-node-size vec-size) + +0 + (|> (dec vec-size) + (bit.logical-right-shift branching-exponent) + (bit.left-shift branching-exponent)))) + +(def: (new-path level tail) + (All [a] (-> Level (Base a) (Node a))) + (if (n/= +0 level) + (#Base tail) + (|> (new-hierarchy []) + (array.write +0 (new-path (level-down level) tail)) + #Hierarchy))) + +(def: (new-tail singleton) + (All [a] (-> a (Base a))) + (|> (array.new +1) + (array.write +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.logical-right-shift level (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.read 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.write sub-idx sub-node)))) + +(def: (expand-tail val tail) + (All [a] (-> a (Base a) (Base a))) + (let [tail-size (array.size tail)] + (|> (array.new (inc tail-size)) + (array.copy tail-size +0 tail +0) + (array.write tail-size val)))) + +(def: (put' level idx val hierarchy) + (All [a] (-> Level Index a (Hierarchy a) (Hierarchy a))) + (let [sub-idx (branch-idx (bit.logical-right-shift level idx))] + (case (array.read sub-idx hierarchy) + (#.Some (#Hierarchy sub-node)) + (|> (array.clone hierarchy) + (array.write sub-idx (#Hierarchy (put' (level-down level) idx val sub-node)))) + + (^multi (#.Some (#Base base)) + (n/= +0 (level-down level))) + (|> (array.clone hierarchy) + (array.write sub-idx (|> (array.clone base) + (array.write (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.logical-right-shift level (n/- +2 size)))] + (cond (n/= +0 sub-idx) + #.None + + (n/> branching-exponent level) + (do maybe.Monad + [base|hierarchy (array.read sub-idx hierarchy) + sub (case base|hierarchy + (#Hierarchy sub) + (pop-tail size (level-down level) sub) + + (#Base _) + (undefined))] + (|> (array.clone hierarchy) + (array.write sub-idx (#Hierarchy sub)) + #.Some)) + + ## Else... + (|> (array.clone hierarchy) + (array.delete 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 (function (_ sub acc) (list/compose (to-list' sub) acc)) + #.Nil)))) + +## [Types] +(type: #export (Row a) + {#level Level + #size Nat + #root (Hierarchy a) + #tail (Base a)}) + +## [Exports] +(def: #export empty + Row + {#level (level-up root-level) + #size +0 + #root (array.new full-node-size) + #tail (array.new +0)}) + +(def: #export (size row) + (All [a] (-> (Row a) Nat)) + (get@ #size row)) + +(def: #export (add val vec) + (All [a] (-> a (Row a) (Row 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 inc) + (update@ #tail (expand-tail val))) + ## Otherwise, push tail into the tree + ## -------------------------------------------------------- + ## Will the root experience an overflow with this addition? + (|> (if (n/> (bit.left-shift (get@ #level vec) +1) + (bit.logical-right-shift 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 [])) + ## TODO: Remove version above once new-luxc becomes the standard compiler. + ## (new-hierarchy []) + (array.write +0 (#Hierarchy (get@ #root vec))) + (array.write +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 row and grow a new + ## tail with the new element as it's sole member. + (update@ #size inc) + (set@ #tail (new-tail val))) + ))) + +(def: (base-for idx vec) + (All [a] (-> Index (Row 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.read (branch-idx (bit.logical-right-shift level idx)) hierarchy)] + [true (#.Some (#Hierarchy sub))] + (recur (level-down level) sub) + + [false (#.Some (#Base base))] + (#.Some base) + + [_ #.None] + #.None + + _ + (error! "Incorrect row structure.")))) + #.None))) + +(def: #export (nth idx vec) + (All [a] (-> Nat (Row a) (Maybe a))) + (do maybe.Monad + [base (base-for idx vec)] + (array.read (branch-idx idx) base))) + +(def: #export (put idx val vec) + (All [a] (-> Nat a (Row a) (Row 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 (|>> array.clone (array.write (branch-idx idx) val))) + ## TODO: Remove once new-luxc becomes the standard compiler. + (update@ #tail (: (-> (Base ($ +0)) (Base ($ +0))) + (|>> array.clone (array.write (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) (Row a) (Row a))) + (case (nth idx vec) + (#.Some val) + (put idx (f val) vec) + + #.None + vec)) + +(def: #export (pop vec) + (All [a] (-> (Row a) (Row 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 (dec (array.size old-tail))] + (|> vec + (update@ #size dec) + (set@ #tail (|> (array.new new-tail-size) + (array.copy new-tail-size +0 old-tail +0))))) + (maybe.assume + (do maybe.Monad + [new-tail (base-for (n/- +2 vec-size) vec) + #let [[level' root'] (let [init-level (get@ #level vec)] + (loop [level init-level + root (maybe.default (new-hierarchy []) + (pop-tail vec-size init-level (get@ #root vec)))] + (if (n/> branching-exponent level) + (case [(array.read +1 root) (array.read +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 dec) + (set@ #level level') + (set@ #root root') + (set@ #tail new-tail)))))) + )) + +(def: #export (to-list vec) + (All [a] (-> (Row a) (List a))) + (list/compose (to-list' (#Hierarchy (get@ #root vec))) + (to-list' (#Base (get@ #tail vec))))) + +(def: #export (from-list list) + (All [a] (-> (List a) (Row a))) + (list/fold add + empty + list)) + +(def: #export (member? a/Equivalence vec val) + (All [a] (-> (Equivalence a) (Row a) a Bool)) + (list.member? a/Equivalence (to-list vec) val)) + +(def: #export empty? + (All [a] (-> (Row a) Bool)) + (|>> (get@ #size) (n/= +0))) + +## [Syntax] +(syntax: #export (row {elems (p.some s.any)}) + {#.doc (doc "Row literals." + (row 10 20 30 40))} + (wrap (list (` (from-list (list (~+ elems))))))) + +## [Structures] +(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Node a)))) + (def: (= v1 v2) + (case [v1 v2] + [(#Base b1) (#Base b2)] + (:: (array.Equivalence Equivalence) = b1 b2) + + [(#Hierarchy h1) (#Hierarchy h2)] + (:: (array.Equivalence (Equivalence Equivalence)) = h1 h2) + + _ + false))) + +(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Row a)))) + (def: (= v1 v2) + (and (n/= (get@ #size v1) (get@ #size v2)) + (let [(^open "Node/") (Equivalence Equivalence)] + (and (Node/= (#Base (get@ #tail v1)) + (#Base (get@ #tail v2))) + (Node/= (#Hierarchy (get@ #root v1)) + (#Hierarchy (get@ #root v2)))))))) + +(structure: _ (Fold Node) + (def: (fold f init xs) + (case xs + (#Base base) + (array/fold f init base) + + (#Hierarchy hierarchy) + (array/fold (function (_ node init') (fold f init' node)) + init + hierarchy)) + )) + +(structure: #export _ (Fold Row) + (def: (fold f init xs) + (let [(^open) Fold] + (fold f + (fold f + init + (#Hierarchy (get@ #root xs))) + (#Base (get@ #tail xs)))) + )) + +(structure: #export Monoid (All [a] (Monoid (Row a))) + (def: identity empty) + (def: (compose xs ys) + (list/fold add xs (to-list ys)))) + +(structure: _ (Functor Node) + (def: (map f xs) + (case xs + (#Base base) + (#Base (array/map f base)) + + (#Hierarchy hierarchy) + (#Hierarchy (array/map (map f) hierarchy))) + )) + +(structure: #export _ (Functor Row) + (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)) + })) + +(structure: #export _ (Apply Row) + (def: functor Functor) + + (def: (apply ff fa) + (let [(^open) Functor + (^open) Fold + (^open) Monoid + results (map (function (_ f) (map f fa)) + ff)] + (fold compose identity results)))) + +(structure: #export _ (Monad Row) + (def: functor Functor) + + (def: wrap (|>> row)) + + (def: join + (let [(^open) Fold + (^open) Monoid] + (fold (function (_ post pre) (compose pre post)) identity)))) + +(def: #export (reverse xs) + (All [a] (-> (Row a) (Row a))) + (let [(^open) Fold + (^open) Monoid] + (fold add identity xs))) diff --git a/stdlib/source/lux/data/collection/sequence.lux b/stdlib/source/lux/data/collection/sequence.lux new file mode 100644 index 000000000..1776855c5 --- /dev/null +++ b/stdlib/source/lux/data/collection/sequence.lux @@ -0,0 +1,146 @@ +(.module: + lux + (lux (control functor + monad + comonad + [continuation #+ pending Cont] + ["p" parser]) + [macro #+ with-gensyms] + (macro [code] + ["s" syntax #+ syntax: Syntax]) + (data (collection [list "List/" Monad]) + bool))) + +## [Types] +(type: #export (Sequence a) + {#.doc "An infinite sequence of values."} + (Cont [a (Sequence a)])) + +## [Utils] +(def: (cycle' x xs init full) + (All [a] + (-> a (List a) a (List a) (Sequence a))) + (case xs + #.Nil (pending [x (cycle' init full init full)]) + (#.Cons x' xs') (pending [x (cycle' x' xs' init full)]))) + +## [Functions] +(def: #export (iterate f x) + {#.doc "Create a sequence by applying a function to a value, and to its result, on and on..."} + (All [a] + (-> (-> a a) a (Sequence a))) + (pending [x (iterate f (f x))])) + +(def: #export (repeat x) + {#.doc "Repeat a value forever."} + (All [a] + (-> a (Sequence a))) + (pending [x (repeat x)])) + +(def: #export (cycle xs) + {#.doc "Go over the elements of a list forever. + + The list should not be empty."} + (All [a] + (-> (List a) (Maybe (Sequence a)))) + (case xs + #.Nil #.None + (#.Cons x xs') (#.Some (cycle' x xs' x xs')))) + +(do-template [ ] + [(def: #export ( s) + (All [a] (-> (Sequence a) )) + (let [[h t] (continuation.run s)] + ))] + + [head a h] + [tail (Sequence a) t]) + +(def: #export (nth idx s) + (All [a] (-> Nat (Sequence a) a)) + (let [[h t] (continuation.run s)] + (if (n/> +0 idx) + (nth (dec idx) t) + h))) + +(do-template [ ] + [(def: #export ( pred xs) + (All [a] + (-> (Sequence a) (List a))) + (let [[x xs'] (continuation.run xs)] + (if + (list& x ( xs')) + (list)))) + + (def: #export ( pred xs) + (All [a] + (-> (Sequence a) (Sequence a))) + (let [[x xs'] (continuation.run xs)] + (if + ( xs') + xs))) + + (def: #export ( pred xs) + (All [a] + (-> (Sequence a) [(List a) (Sequence a)])) + (let [[x xs'] (continuation.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) (dec pred)] + ) + +(def: #export (unfold step init) + {#.doc "A stateful way of infinitely calculating the values of a sequence."} + (All [a b] + (-> (-> a [a b]) a (Sequence b))) + (let [[next x] (step init)] + (pending [x (unfold step next)]))) + +(def: #export (filter p xs) + (All [a] (-> (-> a Bool) (Sequence a) (Sequence a))) + (let [[x xs'] (continuation.run xs)] + (if (p x) + (pending [x (filter p xs')]) + (filter p xs')))) + +(def: #export (partition p xs) + {#.doc "Split a sequence 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) (Sequence a) [(Sequence a) (Sequence a)])) + [(filter p xs) (filter (complement p) xs)]) + +## [Structures] +(structure: #export _ (Functor Sequence) + (def: (map f fa) + (let [[h t] (continuation.run fa)] + (pending [(f h) (map f t)])))) + +(structure: #export _ (CoMonad Sequence) + (def: functor Functor) + (def: unwrap head) + (def: (split wa) + (let [[head tail] (continuation.run wa)] + (pending [wa (split tail)])))) + +## [Pattern-matching] +(syntax: #export (^sequence& {patterns (s.form (p.many s.any))} + body + {branches (p.some s.any)}) + {#.doc (doc "Allows destructuring of sequences in pattern-matching expressions." + "Caveat emptor: Only use it for destructuring, and not for testing values within the sequences." + (let [(^sequence& x y z _tail) (some-sequence-func 1 2 3)] + (func x y z)))} + (with-gensyms [g!sequence] + (let [body+ (` (let [(~+ (List/join (List/map (function (_ pattern) + (list (` [(~ pattern) (~ g!sequence)]) + (` ((~! continuation.run) (~ g!sequence))))) + patterns)))] + (~ body)))] + (wrap (list& g!sequence body+ branches))))) diff --git a/stdlib/source/lux/data/collection/set.lux b/stdlib/source/lux/data/collection/set.lux new file mode 100644 index 000000000..10b7600ca --- /dev/null +++ b/stdlib/source/lux/data/collection/set.lux @@ -0,0 +1,81 @@ +(.module: + lux + (lux (control [equivalence #+ Equivalence] + [hash #+ Hash]) + (data (collection ["dict" dictionary #+ Dictionary] + [list "list/" Fold])) + (type abstract))) + +(abstract: #export (Set a) + {} + + (Dictionary a a) + + (def: #export new + (All [a] (-> (Hash a) (Set a))) + (|>> dict.new :abstraction)) + + (def: #export size + (All [a] (-> (Set a) Nat)) + (|>> :representation dict.size)) + + (def: #export (add elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (dict.put elem elem) :abstraction)) + + (def: #export (remove elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (dict.remove elem) :abstraction)) + + (def: #export (member? set elem) + (All [a] (-> (Set a) a Bool)) + (|> set :representation (dict.contains? elem))) + + (def: #export to-list + (All [a] (-> (Set a) (List a))) + (|>> :representation dict.keys)) + + (def: #export (union xs yx) + (All [a] (-> (Set a) (Set a) (Set a))) + (:abstraction (dict.merge (:representation xs) (:representation 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))) + (:abstraction (dict.select (dict.keys (:representation filter)) + (:representation base)))) + + (structure: #export Equivalence (All [a] (Equivalence (Set a))) + (def: (= reference sample) + (let [[Hash _] (:representation reference)] + (:: (list.Equivalence (get@ #hash.eq Hash)) = + (..to-list reference) (..to-list sample))))) + + (structure: #export Hash (All [a] (Hash (Set a))) + (def: eq ..Equivalence) + + (def: (hash set) + (let [[Hash _] (:representation set)] + (list/fold (function (_ elem acc) (n/+ (:: Hash hash elem) acc)) + +0 + (..to-list set))))) + ) + +(def: #export empty? + (All [a] (-> (Set a) Bool)) + (|>> ..size (n/= +0))) + +(def: #export (from-list Hash xs) + (All [a] (-> (Hash a) (List a) (Set a))) + (list/fold ..add (..new Hash) xs)) + +(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)) diff --git a/stdlib/source/lux/data/collection/set/ordered.lux b/stdlib/source/lux/data/collection/set/ordered.lux new file mode 100644 index 000000000..f947d0b11 --- /dev/null +++ b/stdlib/source/lux/data/collection/set/ordered.lux @@ -0,0 +1,86 @@ +(.module: + lux + (lux (control [equivalence #+ Equivalence] + [order #+ Order]) + (data (collection [list "list/" Fold] + (dictionary ["//" ordered]))) + (type abstract))) + +(abstract: #export (Set a) + {} + + (//.Dictionary a a) + + (def: #export new + (All [a] (-> (Order a) (Set a))) + (|>> //.new :abstraction)) + + (def: #export (member? set elem) + (All [a] (-> (Set a) a Bool)) + (|> set :representation (//.contains? elem))) + + (do-template [ ] + [(def: #export + (All [a] (-> (Set a) (Maybe a))) + (|>> :representation ))] + + [min //.min] + [max //.max] + ) + + (do-template [ ] + [(def: #export + (-> (Set Any) Nat) + (|>> :representation ))] + + [size //.size] + [depth //.depth] + ) + + (def: #export (add elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (//.put elem elem) :abstraction)) + + (def: #export (remove elem set) + (All [a] (-> a (Set a) (Set a))) + (|> set :representation (//.remove elem) :abstraction)) + + (def: #export to-list + (All [a] (-> (Set a) (List a))) + (|>> :representation //.keys)) + + (def: #export (from-list Order list) + (All [a] (-> (Order a) (List a) (Set a))) + (list/fold add (new Order) list)) + + (def: #export (union left right) + (All [a] (-> (Set a) (Set a) (Set a))) + (list/fold ..add right (..to-list left))) + + (def: #export (intersection left right) + (All [a] (-> (Set a) (Set a) (Set a))) + (|> (..to-list right) + (list.filter (..member? left)) + (..from-list (get@ #//.order (:representation right))))) + + (def: #export (difference param subject) + (All [a] (-> (Set a) (Set a) (Set a))) + (|> (..to-list subject) + (list.filter (|>> (..member? param) not)) + (..from-list (get@ #//.order (:representation subject))))) + + (structure: #export Equivalence (All [a] (Equivalence (Set a))) + (def: (= reference sample) + (:: (list.Equivalence (:: (:representation sample) eq)) + = (..to-list reference) (..to-list sample)))) + ) + +(def: #export (sub? super sub) + (All [a] (-> (Set a) (Set a) Bool)) + (|> sub + ..to-list + (list.every? (..member? super)))) + +(def: #export (super? sub super) + (All [a] (-> (Set a) (Set a) Bool)) + (sub? super sub)) diff --git a/stdlib/source/lux/data/collection/stack.lux b/stdlib/source/lux/data/collection/stack.lux new file mode 100644 index 000000000..c0e1af182 --- /dev/null +++ b/stdlib/source/lux/data/collection/stack.lux @@ -0,0 +1,42 @@ +(.module: + lux + (lux (data (collection [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/collection/tree/finger.lux b/stdlib/source/lux/data/collection/tree/finger.lux new file mode 100644 index 000000000..ea1ff0eee --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/finger.lux @@ -0,0 +1,61 @@ +(.module: + lux + (lux (control ["m" monoid]) + (data text/format))) + +(type: #export (Node m a) + (#Leaf m a) + (#Branch m (Node m a) (Node m a))) + +(type: #export (Tree m a) + {#monoid (m.Monoid m) + #node (Node m a)}) + +(def: #export (tag tree) + (All [m a] (-> (Tree m a) m)) + (case (get@ #node tree) + (^or (#Leaf tag _) (#Branch tag _ _)) + tag)) + +(def: #export (value tree) + (All [m a] (-> (Tree m a) a)) + (case (get@ #node tree) + (#Leaf tag value) + value + + (#Branch tag left right) + (value (set@ #node left tree)))) + +(def: #export (branch left right) + (All [m a] (-> (Tree m a) (Tree m a) (Tree m a))) + (let [Monoid (get@ #monoid right)] + {#monoid Monoid + #node (#Branch (:: Monoid compose (tag left) (tag right)) + (get@ #node left) + (get@ #node right))})) + +(def: #export (search pred tree) + (All [m a] (-> (-> m Bool) (Tree m a) (Maybe a))) + (let [tag/compose (get@ [#monoid #m.compose] tree)] + (if (pred (tag tree)) + (loop [_tag (get@ [#monoid #m.identity] tree) + _node (get@ #node tree)] + (case _node + (#Leaf _ value) + (#.Some value) + + (#Branch _ left right) + (let [shifted-tag (tag/compose _tag (tag (set@ #node left tree)))] + (if (pred shifted-tag) + (recur _tag left) + (recur shifted-tag right))))) + #.None))) + +(def: #export (found? pred tree) + (All [m a] (-> (-> m Bool) (Tree m a) Bool)) + (case (search pred tree) + (#.Some _) + true + + #.None + false)) diff --git a/stdlib/source/lux/data/collection/tree/rose.lux b/stdlib/source/lux/data/collection/tree/rose.lux new file mode 100644 index 000000000..9eae689d3 --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/rose.lux @@ -0,0 +1,73 @@ +(.module: + lux + (lux (control functor + [monad #+ do Monad] + equivalence + ["p" parser] + fold) + (data (collection [list "L/" Monad Fold])) + [macro] + (macro [code] + ["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) + (L/join (L/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-Code + [Code (List Tree-Code)]) + +(def: tree^ + (Syntax Tree-Code) + (|> (|>> p.some s.record (p.seq s.any)) + p.rec + p.some + s.record + (p.seq s.any) + s.tuple)) + +(syntax: #export (tree {root tree^}) + {#.doc (doc "Tree literals." + (tree Int [10 {20 {} + 30 {} + 40 {}}]))} + (wrap (list (` (~ (loop [[value children] root] + (` {#value (~ value) + #children (list (~+ (L/map recur children)))}))))))) + +## [Structs] +(structure: #export (Equivalence Equivalence) (All [a] (-> (Equivalence a) (Equivalence (Tree a)))) + (def: (= tx ty) + (and (:: Equivalence = (get@ #value tx) (get@ #value ty)) + (:: (list.Equivalence (Equivalence Equivalence)) = (get@ #children tx) (get@ #children ty))))) + +(structure: #export _ (Functor Tree) + (def: (map f fa) + {#value (f (get@ #value fa)) + #children (L/map (map f) + (get@ #children fa))})) + +(structure: #export _ (Fold Tree) + (def: (fold f init tree) + (L/fold (function (_ tree' init') (fold f init' tree')) + (f (get@ #value tree) + init) + (get@ #children tree)))) diff --git a/stdlib/source/lux/data/collection/tree/rose/parser.lux b/stdlib/source/lux/data/collection/tree/rose/parser.lux new file mode 100644 index 000000000..3e3535649 --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/rose/parser.lux @@ -0,0 +1,50 @@ +(.module: + lux + (lux (control ["p" parser] + ["ex" exception #+ exception:]) + (data ["E" error])) + [// #+ Tree] + (// [zipper #+ Zipper])) + +(type: #export (Parser t a) + (p.Parser (Zipper t) a)) + +(def: #export (run-zipper zipper parser) + (All [t a] (-> (Zipper t) (Parser t a) (E.Error a))) + (case (p.run zipper parser) + (#E.Success [zipper output]) + (#E.Success output) + + (#E.Error error) + (#E.Error error))) + +(def: #export (run tree parser) + (All [t a] (-> (Tree t) (Parser t a) (E.Error a))) + (run-zipper (zipper.zip tree) parser)) + +(def: #export value + (All [t] (Parser t t)) + (function (_ zipper) + (#E.Success [zipper (zipper.value zipper)]))) + +(exception: #export cannot-move-further) + +(do-template [ ] + [(def: #export + (All [t] (Parser t [])) + (function (_ zipper) + (let [next ( zipper)] + (if (is? zipper next) + (ex.throw cannot-move-further []) + (#E.Success [next []])))))] + + [up zipper.up] + [down zipper.down] + [left zipper.left] + [right zipper.right] + [root zipper.root] + [rightmost zipper.rightmost] + [leftmost zipper.leftmost] + [next zipper.next] + [prev zipper.prev] + ) diff --git a/stdlib/source/lux/data/collection/tree/rose/zipper.lux b/stdlib/source/lux/data/collection/tree/rose/zipper.lux new file mode 100644 index 000000000..4a85c68c6 --- /dev/null +++ b/stdlib/source/lux/data/collection/tree/rose/zipper.lux @@ -0,0 +1,235 @@ +(.module: + lux + (lux (control functor + comonad) + (data (collection [list "L/" Monad Fold Monoid] + (tree [rose #+ Tree "T/" Functor]) + [stack #+ Stack]) + [maybe "M/" Monad]) + [macro] + (macro [code] + ["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 (zip tree) + (All [a] (-> (Tree a) (Zipper a))) + {#parent #.None + #lefts stack.empty + #rights stack.empty + #node tree}) + +(def: #export (unzip zipper) + (All [a] (-> (Zipper a) (Tree a))) + (get@ #node zipper)) + +(def: #export (value zipper) + (All [a] (-> (Zipper a) a)) + (|> zipper (get@ [#node #rose.value]))) + +(def: #export (children zipper) + (All [a] (-> (Zipper a) (List (Tree a)))) + (|> zipper (get@ [#node #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 (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)) + +(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 + ## TODO: Remove once new-luxc becomes the standard compiler. + (update@ #node (: (-> (Tree ($ +0)) (Tree ($ +0))) + (function (_ node) + (set@ #rose.children (L/compose (list.reverse (get@ #lefts zipper)) + (#.Cons (get@ #node zipper) + (get@ #rights zipper))) + node)))) + ## (update@ #node (function (_ node) + ## (set@ #rose.children (L/compose (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@ (function (_ op-side) + (#.Cons (get@ #node zipper) op-side))) + (set@ side') + (set@ #node next)))) + + (def: #export ( zipper) + (All [a] (-> (Zipper a) (Zipper a))) + (L/fold (function (_ _) ) zipper (get@ zipper)))] + + [right rightmost #rights #lefts] + [left leftmost #lefts #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 (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] + (function (_ children) + ## TODO: Remove once new-luxc becomes the standard compiler. + (list& (: (Tree ($ +0)) + (rose.tree [value {}])) + children) + ## (list& (rose.tree [value {}]) + ## children) + ) + zipper)) + +(def: #export (append-child value zipper) + (All [a] (-> a (Zipper a) (Zipper a))) + (update@ [#node #rose.children] + (function (_ children) + (L/compose children + ## TODO: Remove once new-luxc becomes the standard compiler. + (list (: (Tree ($ +0)) + (rose.tree [value {}]))) + ## (list (rose.tree [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 (maybe.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@ (function (_ side) + ## TODO: Remove once new-luxc becomes the standard compiler. + (#.Cons (: (Tree ($ +0)) + (rose.tree [value {}])) + side) + ## (#.Cons (rose.tree [value {}]) + ## side) + ))))))] + + [insert-left #lefts] + [insert-right #rights] + ) + +(structure: #export _ (Functor Zipper) + (def: (map f fa) + {#parent (|> fa (get@ #parent) (M/map (map f))) + #lefts (|> fa (get@ #lefts) (L/map (T/map f))) + #rights (|> fa (get@ #rights) (L/map (T/map f))) + #node (T/map f (get@ #node fa))})) + +## TODO: Add again once new-luxc becomes the standard compiler. +## (structure: #export _ (CoMonad Zipper) +## (def: functor Functor) + +## (def: unwrap (get@ [#node #rose.value])) + +## (def: (split wa) +## (let [tree-splitter (function (tree-splitter tree) +## {#rose.value (zip tree) +## #rose.children (L/map tree-splitter +## (get@ #rose.children tree))})] +## {#parent (|> wa (get@ #parent) (M/map split)) +## #lefts (|> wa (get@ #lefts) (L/map tree-splitter)) +## #rights (|> wa (get@ #rights) (L/map tree-splitter)) +## #node (|> fa (get@ #node) tree-splitter)}))) diff --git a/stdlib/source/lux/data/color.lux b/stdlib/source/lux/data/color.lux index 7a23be703..bf11c378a 100644 --- a/stdlib/source/lux/data/color.lux +++ b/stdlib/source/lux/data/color.lux @@ -1,7 +1,7 @@ (.module: lux (lux (control ["eq" equivalence]) - (data (coll [list "L/" Functor])) + (data (collection [list "L/" Functor])) [math] (type abstract))) diff --git a/stdlib/source/lux/data/format/context.lux b/stdlib/source/lux/data/format/context.lux index f9874f6d2..0a4d8bd92 100644 --- a/stdlib/source/lux/data/format/context.lux +++ b/stdlib/source/lux/data/format/context.lux @@ -4,7 +4,7 @@ ["ex" exception #+ exception:] [monad #+ do]) (data ["E" error] - (coll ["dict" dictionary #+ Dictionary])))) + (collection ["dict" dictionary #+ Dictionary])))) (exception: #export (unknown-property {property Text}) property) diff --git a/stdlib/source/lux/data/format/css.lux b/stdlib/source/lux/data/format/css.lux index d76242045..685bd9d6d 100644 --- a/stdlib/source/lux/data/format/css.lux +++ b/stdlib/source/lux/data/format/css.lux @@ -4,7 +4,7 @@ [number] [text] text/format - (coll [list "L/" Functor Monoid])))) + (collection [list "L/" Functor Monoid])))) (type: #export Selector Text) diff --git a/stdlib/source/lux/data/format/html.lux b/stdlib/source/lux/data/format/html.lux index ef2e0abf0..891800e8a 100644 --- a/stdlib/source/lux/data/format/html.lux +++ b/stdlib/source/lux/data/format/html.lux @@ -2,7 +2,7 @@ [lux #- comment] (lux (data [text] text/format - (coll [list "L/" Functor])))) + (collection [list "L/" Functor])))) (type: #export Attributes {#.doc "Attributes for an HTML tag."} diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux index c3069c939..392e16c3b 100644 --- a/stdlib/source/lux/data/format/json.lux +++ b/stdlib/source/lux/data/format/json.lux @@ -14,9 +14,9 @@ ["e" error] [sum] [product] - (coll [list "list/" Fold Monad] - [row #+ Row row "row/" Monad] - ["dict" dictionary #+ Dictionary])) + (collection [list "list/" Fold Monad] + [row #+ Row row "row/" Monad] + ["dict" dictionary #+ Dictionary])) [macro #+ Monad with-gensyms] (macro ["s" syntax #+ syntax:] [code]))) diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux index dd389c55b..a966b1bfa 100644 --- a/stdlib/source/lux/data/format/xml.lux +++ b/stdlib/source/lux/data/format/xml.lux @@ -12,8 +12,8 @@ [product] [maybe "m/" Monad] [ident "ident/" Equivalence Codec] - (coll [list "list/" Monad] - ["d" dictionary])))) + (collection [list "list/" Monad] + ["d" dictionary])))) (type: #export Tag Ident) (type: #export Attrs (d.Dictionary Ident Text)) diff --git a/stdlib/source/lux/data/number/complex.lux b/stdlib/source/lux/data/number/complex.lux index 91a10fd59..3c92e181d 100644 --- a/stdlib/source/lux/data/number/complex.lux +++ b/stdlib/source/lux/data/number/complex.lux @@ -9,7 +9,7 @@ (data [number "frac/" Number "f/" Codec] [text "text/" Monoid] [maybe] - (coll [list "L/" Monad])) + (collection [list "L/" Monad])) [macro] (macro [code] ["s" syntax #+ syntax: Syntax]))) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index d09b713c9..1e1a660d7 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -6,7 +6,7 @@ [monad #+ do Monad] [codec #+ Codec] hash) - (data (coll [list]) + (data (collection [list]) [maybe]))) ## [Functions] diff --git a/stdlib/source/lux/data/text/buffer.lux b/stdlib/source/lux/data/text/buffer.lux index 423a1ba3c..0641ba215 100644 --- a/stdlib/source/lux/data/text/buffer.lux +++ b/stdlib/source/lux/data/text/buffer.lux @@ -2,7 +2,7 @@ lux (lux (data [product] text/format - (coll [row #+ Row "row/" Fold])) + (collection [row #+ Row "row/" Fold])) (lang ["_" host]) (type abstract) [host #+ import:]) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 847e4ac4f..26fca323d 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -6,7 +6,7 @@ [number] [text] [ident] - (coll [list "list/" Monad]) + (collection [list "list/" Monad]) (format [xml] [json])) (time [instant] diff --git a/stdlib/source/lux/data/text/lexer.lux b/stdlib/source/lux/data/text/lexer.lux index 84495a6a8..9f8bbb664 100644 --- a/stdlib/source/lux/data/text/lexer.lux +++ b/stdlib/source/lux/data/text/lexer.lux @@ -6,7 +6,7 @@ [product] [maybe] ["e" error] - (coll [list])) + (collection [list])) (macro [code]))) (type: Offset Nat) diff --git a/stdlib/source/lux/data/text/regex.lux b/stdlib/source/lux/data/text/regex.lux index cf0d69475..f0e471ef4 100644 --- a/stdlib/source/lux/data/text/regex.lux +++ b/stdlib/source/lux/data/text/regex.lux @@ -9,7 +9,7 @@ [product] ["e" error] [maybe] - (coll [list "list/" Fold Monad])) + (collection [list "list/" Fold Monad])) [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax:]))) diff --git a/stdlib/source/lux/data/text/unicode.lux b/stdlib/source/lux/data/text/unicode.lux index e00f23e84..8a88e1184 100644 --- a/stdlib/source/lux/data/text/unicode.lux +++ b/stdlib/source/lux/data/text/unicode.lux @@ -3,8 +3,8 @@ (lux (control [interval #+ Interval] [monoid #+ Monoid]) (data [number #+ hex "nat/" Interval] - (coll [list] - (tree [finger #+ Tree]))) + (collection [list] + (tree [finger #+ Tree]))) (type abstract))) (type: #export Char Nat) diff --git a/stdlib/source/lux/host.js.lux b/stdlib/source/lux/host.js.lux index 876ab0c38..a0d1d0c3f 100644 --- a/stdlib/source/lux/host.js.lux +++ b/stdlib/source/lux/host.js.lux @@ -2,7 +2,7 @@ lux (lux (control monad ["p" parser]) - (data (coll [list #* "L/" Fold])) + (data (collection [list #* "L/" Fold])) [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax: Syntax]) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 108ab2db9..43a78472b 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -5,7 +5,7 @@ ["p" parser]) [io #+ IO Monad io] function - (data (coll [list "list/" Monad Fold Monoid]) + (data (collection [list "list/" Monad Fold Monoid]) number [maybe] [product] diff --git a/stdlib/source/lux/io.lux b/stdlib/source/lux/io.lux index 7579a1463..ca9b80467 100644 --- a/stdlib/source/lux/io.lux +++ b/stdlib/source/lux/io.lux @@ -5,7 +5,7 @@ [monad #+ do Monad] ["ex" exception #+ Exception]) (data ["e" error #+ Error] - (coll [list])))) + (collection [list])))) (type: #export (IO a) {#.doc "A type that represents synchronous, effectful computations that may interact with the outside world."} diff --git a/stdlib/source/lux/lang/compiler/analysis.lux b/stdlib/source/lux/lang/compiler/analysis.lux index c9e9b8be1..87a4cbe4f 100644 --- a/stdlib/source/lux/lang/compiler/analysis.lux +++ b/stdlib/source/lux/lang/compiler/analysis.lux @@ -3,7 +3,7 @@ (lux (data [product] [error] [text "text/" Equivalence] - (coll [list "list/" Fold])) + (collection [list "list/" Fold])) [function]) [///reference #+ Register Variable Reference] [//]) diff --git a/stdlib/source/lux/lang/compiler/analysis/case.lux b/stdlib/source/lux/lang/compiler/analysis/case.lux index 233ac114a..fc1e83d4a 100644 --- a/stdlib/source/lux/lang/compiler/analysis/case.lux +++ b/stdlib/source/lux/lang/compiler/analysis/case.lux @@ -6,7 +6,7 @@ [error] [maybe] text/format - (coll [list "list/" Fold Monoid Functor])) + (collection [list "list/" Fold Monoid Functor])) [macro] (macro [code])) (//// [type] diff --git a/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux index c76f98091..70c9fa80f 100644 --- a/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux +++ b/stdlib/source/lux/lang/compiler/analysis/case/coverage.lux @@ -8,8 +8,8 @@ ["e" error "error/" Monad] [maybe] text/format - (coll [list "list/" Fold] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Fold] + ["dict" dictionary #+ Dictionary]))) [//// "operation/" Monad] [/// #+ Pattern Variant Operation]) diff --git a/stdlib/source/lux/lang/compiler/analysis/function.lux b/stdlib/source/lux/lang/compiler/analysis/function.lux index b16b18e59..f8d8b826b 100644 --- a/stdlib/source/lux/lang/compiler/analysis/function.lux +++ b/stdlib/source/lux/lang/compiler/analysis/function.lux @@ -5,7 +5,7 @@ (data [maybe] [text] text/format - (coll [list "list/" Fold Monoid Monad])) + (collection [list "list/" Fold Monoid Monad])) [macro] (macro [code]) (lang [type] diff --git a/stdlib/source/lux/lang/compiler/analysis/inference.lux b/stdlib/source/lux/lang/compiler/analysis/inference.lux index 42ab27a6c..a89ed40f8 100644 --- a/stdlib/source/lux/lang/compiler/analysis/inference.lux +++ b/stdlib/source/lux/lang/compiler/analysis/inference.lux @@ -5,7 +5,7 @@ (data [maybe] [text] text/format - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) [macro]) (//// [type] (type ["tc" check])) diff --git a/stdlib/source/lux/lang/compiler/analysis/structure.lux b/stdlib/source/lux/lang/compiler/analysis/structure.lux index dd832fe47..087ffa8c5 100644 --- a/stdlib/source/lux/lang/compiler/analysis/structure.lux +++ b/stdlib/source/lux/lang/compiler/analysis/structure.lux @@ -6,8 +6,8 @@ [number] [product] [maybe] - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary]) + (collection [list "list/" Functor] + ["dict" dictionary #+ Dictionary]) text/format) [macro] (macro [code])) diff --git a/stdlib/source/lux/lang/compiler/default/repl/type.lux b/stdlib/source/lux/lang/compiler/default/repl/type.lux index 2fc2c74b6..b78d1785c 100644 --- a/stdlib/source/lux/lang/compiler/default/repl/type.lux +++ b/stdlib/source/lux/lang/compiler/default/repl/type.lux @@ -8,7 +8,7 @@ text/format (format [xml #+ XML] [json #+ JSON]) - (coll [list])) + (collection [list])) (time [instant #+ Instant] [duration #+ Duration] [date #+ Date]) diff --git a/stdlib/source/lux/lang/compiler/extension.lux b/stdlib/source/lux/lang/compiler/extension.lux index ce01c16ae..e23e9b511 100644 --- a/stdlib/source/lux/lang/compiler/extension.lux +++ b/stdlib/source/lux/lang/compiler/extension.lux @@ -4,7 +4,7 @@ ["ex" exception #+ exception:]) (data [error #+ Error] [text] - (coll ["dict" dictionary #+ Dictionary]))) + (collection ["dict" dictionary #+ Dictionary]))) [// #+ Operation Compiler]) (type: #export (Extension i) diff --git a/stdlib/source/lux/lang/compiler/extension/analysis.lux b/stdlib/source/lux/lang/compiler/extension/analysis.lux index b770e2f7e..9f48c79b4 100644 --- a/stdlib/source/lux/lang/compiler/extension/analysis.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis.lux @@ -1,8 +1,8 @@ (.module: lux (lux (data [text] - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor] + ["dict" dictionary #+ Dictionary]))) [///analysis #+ Analysis State] [///synthesis #+ Synthesis] [//] diff --git a/stdlib/source/lux/lang/compiler/extension/analysis/common.lux b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux index 1afbc13aa..62a01cee7 100644 --- a/stdlib/source/lux/lang/compiler/extension/analysis/common.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis/common.lux @@ -6,9 +6,9 @@ (concurrency [atom #+ Atom]) (data [text] text/format - (coll [list "list/" Functor] - [array] - ["dict" dictionary #+ Dictionary])) + (collection [list "list/" Functor] + [array] + ["dict" dictionary #+ Dictionary])) [lang] (lang (type ["tc" check])) [io #+ IO]) diff --git a/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux index 4316c4a53..265836e66 100644 --- a/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux +++ b/stdlib/source/lux/lang/compiler/extension/analysis/host.jvm.lux @@ -10,9 +10,9 @@ [text "text/" Equivalence] (text format ["l" lexer]) - (coll [list "list/" Fold Functor Monoid] - [array] - ["dict" dictionary #+ Dictionary])) + (collection [list "list/" Fold Functor Monoid] + [array] + ["dict" dictionary #+ Dictionary])) [macro "macro/" Monad] (macro [code] ["s" syntax]) diff --git a/stdlib/source/lux/lang/compiler/extension/bundle.lux b/stdlib/source/lux/lang/compiler/extension/bundle.lux index e4f918ef3..4e011d2ca 100644 --- a/stdlib/source/lux/lang/compiler/extension/bundle.lux +++ b/stdlib/source/lux/lang/compiler/extension/bundle.lux @@ -4,8 +4,8 @@ ["ex" exception #+ exception:]) (data [text] text/format - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor] + ["dict" dictionary #+ Dictionary]))) [//]) (exception: #export (incorrect-arity {name Text} {arity Nat} {args Nat}) diff --git a/stdlib/source/lux/lang/compiler/extension/synthesis.lux b/stdlib/source/lux/lang/compiler/extension/synthesis.lux index d06a2b144..48073d012 100644 --- a/stdlib/source/lux/lang/compiler/extension/synthesis.lux +++ b/stdlib/source/lux/lang/compiler/extension/synthesis.lux @@ -1,7 +1,7 @@ (.module: lux (lux (data [text] - (coll ["dict" dictionary #+ Dictionary]))) + (collection ["dict" dictionary #+ Dictionary]))) [//]) (def: #export defaults diff --git a/stdlib/source/lux/lang/compiler/extension/translation.lux b/stdlib/source/lux/lang/compiler/extension/translation.lux index 367288981..ae05fd61c 100644 --- a/stdlib/source/lux/lang/compiler/extension/translation.lux +++ b/stdlib/source/lux/lang/compiler/extension/translation.lux @@ -1,7 +1,7 @@ (.module: lux (lux (data [text] - (coll ["dict" dictionary #+ Dictionary]))) + (collection ["dict" dictionary #+ Dictionary]))) [//]) (def: #export defaults diff --git a/stdlib/source/lux/lang/compiler/meta/archive.lux b/stdlib/source/lux/lang/compiler/meta/archive.lux index 4a86055e8..53c3baa65 100644 --- a/stdlib/source/lux/lang/compiler/meta/archive.lux +++ b/stdlib/source/lux/lang/compiler/meta/archive.lux @@ -7,7 +7,7 @@ [ident] [text] text/format - (coll ["dict" dictionary #+ Dictionary])) + (collection ["dict" dictionary #+ Dictionary])) (lang [type #+ :share]) (type abstract) (world [file #+ File])) diff --git a/stdlib/source/lux/lang/compiler/meta/cache.lux b/stdlib/source/lux/lang/compiler/meta/cache.lux index 54919feb8..7c6b558db 100644 --- a/stdlib/source/lux/lang/compiler/meta/cache.lux +++ b/stdlib/source/lux/lang/compiler/meta/cache.lux @@ -10,9 +10,9 @@ (format [binary #+ Binary]) [text] text/format - (coll [list "list/" Functor Fold] - ["dict" dictionary #+ Dictionary] - [set #+ Set])) + (collection [list "list/" Functor Fold] + ["dict" dictionary #+ Dictionary] + [set #+ Set])) (world [file #+ File System])) [//io #+ Context Module] [//io/context] diff --git a/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux index 843644887..f489f04ed 100644 --- a/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux +++ b/stdlib/source/lux/lang/compiler/meta/cache/dependency.lux @@ -1,8 +1,8 @@ (.module: [lux #- Module] (lux (data [text] - (coll [list "list/" Functor Fold] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor Fold] + ["dict" dictionary #+ Dictionary]))) [///io #+ Module] [///archive #+ Archive]) diff --git a/stdlib/source/lux/lang/compiler/synthesis.lux b/stdlib/source/lux/lang/compiler/synthesis.lux index 46f376adf..36db1fe5e 100644 --- a/stdlib/source/lux/lang/compiler/synthesis.lux +++ b/stdlib/source/lux/lang/compiler/synthesis.lux @@ -2,7 +2,7 @@ [lux #- i64 Scope] (lux (control [monad #+ do]) (data [error #+ Error] - (coll ["dict" dictionary #+ Dictionary]))) + (collection ["dict" dictionary #+ Dictionary]))) [///reference #+ Register Variable Reference] [// #+ Operation Compiler] [//analysis #+ Environment Arity Analysis]) diff --git a/stdlib/source/lux/lang/compiler/synthesis/case.lux b/stdlib/source/lux/lang/compiler/synthesis/case.lux index bdf06f05f..5fca60a99 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/case.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/case.lux @@ -8,7 +8,7 @@ [text "text/" Equivalence] text/format [number "frac/" Equivalence] - (coll [list "list/" Fold Monoid]))) + (collection [list "list/" Fold Monoid]))) [///reference] [///compiler #+ Operation "operation/" Monad] [///analysis #+ Pattern Match Analysis] diff --git a/stdlib/source/lux/lang/compiler/synthesis/expression.lux b/stdlib/source/lux/lang/compiler/synthesis/expression.lux index c9e3c577a..6db9a8fd5 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/expression.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/expression.lux @@ -3,8 +3,8 @@ (lux (control [monad #+ do] ["ex" exception #+ exception:]) (data [maybe] - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor] + ["dict" dictionary #+ Dictionary]))) [///reference] [///compiler "operation/" Monad] [///analysis #+ Analysis] diff --git a/stdlib/source/lux/lang/compiler/synthesis/function.lux b/stdlib/source/lux/lang/compiler/synthesis/function.lux index 2d2fffbf8..ae7b5c3b3 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/function.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/function.lux @@ -6,8 +6,8 @@ ["ex" exception #+ exception:]) (data [maybe "maybe/" Monad] [error] - (coll [list "list/" Functor Monoid Fold] - ["dict" dictionary #+ Dictionary]))) + (collection [list "list/" Functor Monoid Fold] + ["dict" dictionary #+ Dictionary]))) [///reference #+ Variable] [///compiler #+ Operation] [///analysis #+ Environment Arity Analysis] diff --git a/stdlib/source/lux/lang/compiler/synthesis/loop.lux b/stdlib/source/lux/lang/compiler/synthesis/loop.lux index eb57eb7ad..e4722ee1f 100644 --- a/stdlib/source/lux/lang/compiler/synthesis/loop.lux +++ b/stdlib/source/lux/lang/compiler/synthesis/loop.lux @@ -3,7 +3,7 @@ (lux (control [monad #+ do] ["p" parser]) (data [maybe "maybe/" Monad] - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) (macro [code] [syntax])) [///] diff --git a/stdlib/source/lux/lang/compiler/translation.lux b/stdlib/source/lux/lang/compiler/translation.lux index 1400cb446..8791c8d5e 100644 --- a/stdlib/source/lux/lang/compiler/translation.lux +++ b/stdlib/source/lux/lang/compiler/translation.lux @@ -6,8 +6,8 @@ [error #+ Error] [text] text/format - (coll [row #+ Row] - ["dict" dictionary #+ Dictionary])) + (collection [row #+ Row] + ["dict" dictionary #+ Dictionary])) (world [file #+ File])) [// #+ Operation Compiler] [//synthesis #+ Synthesis]) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux index 70da9d5d8..39b5bdae1 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/case.jvm.lux @@ -5,8 +5,8 @@ (data [number] [text] text/format - (coll [list "list/" Functor Fold] - [set #+ Set]))) + (collection [list "list/" Functor Fold] + [set #+ Set]))) (///// [reference #+ Register] (host ["_" scheme #+ Expression Computation Var]) [compiler #+ "operation/" Monad] @@ -93,9 +93,9 @@ (def: (pm-catch handler) (-> Expression Computation) (_.lambda [(list $alt_error) #.None] - (_.if (|> $alt_error (_.eqv?/2 pm-error)) - handler - (_.raise/1 $alt_error)))) + (_.if (|> $alt_error (_.eqv?/2 pm-error)) + handler + (_.raise/1 $alt_error)))) (def: (pattern-matching' translate pathP) (-> Translator Path (Operation Expression)) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux index c894053d2..9fa0abc55 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension.jvm.lux @@ -4,7 +4,7 @@ ["ex" exception #+ exception:]) (data [maybe] text/format - (coll ["dict" dictionary #+ Dictionary]))) + (collection ["dict" dictionary #+ Dictionary]))) (///// [reference #+ Register Variable] (host ["_" scheme #+ Computation]) [compiler "operation/" Monad] diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux index e79b11c3b..11743b076 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/extension/common.jvm.lux @@ -7,8 +7,8 @@ [text] text/format [number #+ hex] - (coll [list "list/" Functor] - ["dict" dictionary #+ Dictionary])) + (collection [list "list/" Functor] + ["dict" dictionary #+ Dictionary])) [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax:]) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux index 4ec601257..1ac433ec4 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/function.jvm.lux @@ -4,7 +4,7 @@ pipe) (data [product] text/format - (coll [list "list/" Functor]))) + (collection [list "list/" Functor]))) (///// [reference #+ Register Variable] [name] (host ["_" scheme #+ Expression Computation Var]) diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux index e9ea1c3e8..f77f7cf10 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/loop.jvm.lux @@ -4,7 +4,7 @@ (data [product] [text] text/format - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) [macro]) (///// (host ["_" scheme #+ Computation Var]) [compiler] diff --git a/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux index 7ba873999..89707cdc4 100644 --- a/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux +++ b/stdlib/source/lux/lang/compiler/translation/scheme/runtime.jvm.lux @@ -4,7 +4,7 @@ [monad #+ do]) (data [number #+ hex] text/format - (coll [list "list/" Monad])) + (collection [list "list/" Monad])) [function] (macro [code] ["s" syntax #+ syntax:])) diff --git a/stdlib/source/lux/lang/host/scheme.lux b/stdlib/source/lux/lang/host/scheme.lux index adc8504bb..93d1b2017 100644 --- a/stdlib/source/lux/lang/host/scheme.lux +++ b/stdlib/source/lux/lang/host/scheme.lux @@ -4,7 +4,7 @@ (data [text] text/format [number] - (coll [list "list/" Functor Fold])) + (collection [list "list/" Functor Fold])) (type abstract))) (abstract: Global' {} Any) diff --git a/stdlib/source/lux/lang/module.lux b/stdlib/source/lux/lang/module.lux index b93b5e27b..dbb1cc0ea 100644 --- a/stdlib/source/lux/lang/module.lux +++ b/stdlib/source/lux/lang/module.lux @@ -6,8 +6,8 @@ (data [text "text/" Equivalence] text/format ["e" error] - (coll [list "list/" Fold Functor] - (dictionary [plist]))) + (collection [list "list/" Fold Functor] + (dictionary [plist]))) [macro]) [//compiler] (//compiler [analysis])) diff --git a/stdlib/source/lux/lang/scope.lux b/stdlib/source/lux/lang/scope.lux index 191eb5e5d..9cb1de1c2 100644 --- a/stdlib/source/lux/lang/scope.lux +++ b/stdlib/source/lux/lang/scope.lux @@ -6,8 +6,8 @@ [maybe "maybe/" Monad] [product] ["e" error] - (coll [list "list/" Functor Fold Monoid] - (dictionary [plist]))) + (collection [list "list/" Functor Fold Monoid] + (dictionary [plist]))) [macro]) [//reference #+ Register Variable]) diff --git a/stdlib/source/lux/lang/syntax.lux b/stdlib/source/lux/lang/syntax.lux index 2822e5e31..b9214ca11 100644 --- a/stdlib/source/lux/lang/syntax.lux +++ b/stdlib/source/lux/lang/syntax.lux @@ -36,8 +36,8 @@ [text] (text ["l" lexer] format) - (coll [row #+ Row] - ["dict" dictionary #+ Dictionary])))) + (collection [row #+ Row] + ["dict" dictionary #+ Dictionary])))) (type: #export Aliases (Dictionary Text Text)) diff --git a/stdlib/source/lux/lang/type.lux b/stdlib/source/lux/lang/type.lux index 8f3c2eb77..b7e04afa4 100644 --- a/stdlib/source/lux/lang/type.lux +++ b/stdlib/source/lux/lang/type.lux @@ -7,7 +7,7 @@ [ident "ident/" Equivalence Codec] [number "nat/" Codec] [maybe] - (coll [list #+ "list/" Functor Monoid Fold])) + (collection [list #+ "list/" Functor Monoid Fold])) [macro] (macro [code] ["s" syntax #+ Syntax syntax:]) diff --git a/stdlib/source/lux/lang/type/check.lux b/stdlib/source/lux/lang/type/check.lux index fa21654b7..84b9f808d 100644 --- a/stdlib/source/lux/lang/type/check.lux +++ b/stdlib/source/lux/lang/type/check.lux @@ -8,8 +8,8 @@ [number "nat/" Codec] [maybe] [product] - (coll [list] - [set #+ Set]) + (collection [list] + [set #+ Set]) ["e" error]) (lang [type "type/" Equivalence]) )) diff --git a/stdlib/source/lux/macro.lux b/stdlib/source/lux/macro.lux index 8aaa567ae..f55eb2392 100644 --- a/stdlib/source/lux/macro.lux +++ b/stdlib/source/lux/macro.lux @@ -9,7 +9,7 @@ [maybe] ["e" error] [text "text/" Monoid Equivalence] - (coll [list "list/" Monoid Monad]))) + (collection [list "list/" Monoid Monad]))) (/ [code])) ## (type: (Meta a) diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux index 42f575a57..cb977f36e 100644 --- a/stdlib/source/lux/macro/code.lux +++ b/stdlib/source/lux/macro/code.lux @@ -5,7 +5,7 @@ number [text #+ Equivalence "text/" Monoid] ident - (coll [list #* "" Functor Fold]) + (collection [list #* "" Functor Fold]) ))) ## [Types] diff --git a/stdlib/source/lux/macro/poly.lux b/stdlib/source/lux/macro/poly.lux index 429a93bde..05f800653 100644 --- a/stdlib/source/lux/macro/poly.lux +++ b/stdlib/source/lux/macro/poly.lux @@ -6,8 +6,8 @@ ["ex" exception #+ exception:]) [function] (data [text "text/" Monoid] - (coll [list "list/" Fold Monad Monoid] - ["dict" dictionary #+ Dictionary]) + (collection [list "list/" Fold Monad Monoid] + ["dict" dictionary #+ Dictionary]) [number "nat/" Codec] [product] [bool] diff --git a/stdlib/source/lux/macro/poly/equivalence.lux b/stdlib/source/lux/macro/poly/equivalence.lux index f8e178700..a01f70c74 100644 --- a/stdlib/source/lux/macro/poly/equivalence.lux +++ b/stdlib/source/lux/macro/poly/equivalence.lux @@ -5,13 +5,13 @@ ["p" parser]) (data [text "text/" Monoid] text/format - (coll [list "list/" Monad] - [row] - [array] - [queue] - [set] - ["dict" dictionary #+ Dictionary] - (tree [rose])) + (collection [list "list/" Monad] + [row] + [array] + [queue] + [set] + ["dict" dictionary #+ Dictionary] + (tree [rose])) [number "nat/" Codec] [product] [bool] diff --git a/stdlib/source/lux/macro/poly/functor.lux b/stdlib/source/lux/macro/poly/functor.lux index a0e5bb463..c7a000e61 100644 --- a/stdlib/source/lux/macro/poly/functor.lux +++ b/stdlib/source/lux/macro/poly/functor.lux @@ -5,7 +5,7 @@ ["p" parser]) (data [text] text/format - (coll [list "L/" Monad Monoid]) + (collection [list "L/" Monad Monoid]) [product]) [macro] (macro [code] diff --git a/stdlib/source/lux/macro/poly/json.lux b/stdlib/source/lux/macro/poly/json.lux index 8f7a1170e..1414bb38c 100644 --- a/stdlib/source/lux/macro/poly/json.lux +++ b/stdlib/source/lux/macro/poly/json.lux @@ -14,9 +14,9 @@ ["e" error] [sum] [product] - (coll [list "list/" Fold Monad] - [row #+ Row row "row/" Monad] - ["d" dictionary]) + (collection [list "list/" Fold Monad] + [row #+ Row row "row/" Monad] + ["d" dictionary]) (format ["//" json #+ JSON])) (time ## ["i" instant] ["du" duration] diff --git a/stdlib/source/lux/macro/syntax.lux b/stdlib/source/lux/macro/syntax.lux index 5739886ea..c333b3d8f 100644 --- a/stdlib/source/lux/macro/syntax.lux +++ b/stdlib/source/lux/macro/syntax.lux @@ -8,7 +8,7 @@ [number] [text "text/" Monoid] [ident] - (coll [list "list/" Functor]) + (collection [list "list/" Functor]) [maybe] [error #+ Error])) (// [code "code/" Equivalence])) diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index 0237d579a..0db5f645b 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -2,7 +2,7 @@ lux (lux (control monad ["p" parser "p/" Monad]) - (data (coll [list]) + (data (collection [list]) [ident "ident/" Equivalence] [product] [maybe]) diff --git a/stdlib/source/lux/macro/syntax/common/writer.lux b/stdlib/source/lux/macro/syntax/common/writer.lux index 9c304223e..06edd114a 100644 --- a/stdlib/source/lux/macro/syntax/common/writer.lux +++ b/stdlib/source/lux/macro/syntax/common/writer.lux @@ -1,7 +1,7 @@ (.module: {#.doc "Commons syntax writers."} lux - (lux (data (coll [list "list/" Functor]) + (lux (data (collection [list "list/" Functor]) [product]) (macro [code])) [//]) diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux index 0ca31a34c..66b35f320 100644 --- a/stdlib/source/lux/math.lux +++ b/stdlib/source/lux/math.lux @@ -4,7 +4,7 @@ ["p" parser "p/" Functor]) (data [product] [number] - (coll [list "L/" Fold])) + (collection [list "L/" Fold])) [macro] (macro ["s" syntax #+ syntax: Syntax] [code]))) diff --git a/stdlib/source/lux/math/logic/fuzzy.lux b/stdlib/source/lux/math/logic/fuzzy.lux index 9ee9b1685..5b31a6379 100644 --- a/stdlib/source/lux/math/logic/fuzzy.lux +++ b/stdlib/source/lux/math/logic/fuzzy.lux @@ -1,10 +1,7 @@ (.module: lux - (lux (data [number "Rev/" Interval] - (coll [list] - [set #+ Set]) - text/format) - [math]) + (lux (data (collection [list] + [set #+ Set]))) (// ["&" continuous])) (type: #export (Fuzzy a) diff --git a/stdlib/source/lux/math/random.lux b/stdlib/source/lux/math/random.lux index 218c9131b..7a1fb7225 100644 --- a/stdlib/source/lux/math/random.lux +++ b/stdlib/source/lux/math/random.lux @@ -12,14 +12,14 @@ [number #+ hex] (number ["r" ratio] ["c" complex]) - (coll [list "list/" Fold] - [array] - ["dict" dictionary #+ Dictionary] - [queue #+ Queue] - [set #+ Set] - [stack #+ Stack] - [row #+ Row] - (tree [finger #+ Tree]))) + (collection [list "list/" Fold] + [array] + ["dict" dictionary #+ Dictionary] + [queue #+ Queue] + [set #+ Set] + [stack #+ Stack] + [row #+ Row] + (tree [finger #+ Tree]))) (type [refinement #+ Refiner Refined]) )) diff --git a/stdlib/source/lux/test.lux b/stdlib/source/lux/test.lux index 33ac37423..bd804cfb0 100644 --- a/stdlib/source/lux/test.lux +++ b/stdlib/source/lux/test.lux @@ -6,12 +6,12 @@ (control [monad #+ do Monad] ["p" parser]) (concurrency [promise #+ Promise]) - (data (coll [list "list/" Monad Fold]) - [product] + (data [product] [maybe] + ["e" error] [text] text/format - ["e" error]) + (collection [list "list/" Monad Fold])) [io #+ IO io] (time [instant] [duration]) diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux index 38fc89800..fe0cff9b8 100644 --- a/stdlib/source/lux/time/date.lux +++ b/stdlib/source/lux/time/date.lux @@ -11,7 +11,7 @@ [number "int/" Codec] [text "text/" Monoid] (text ["l" lexer]) - (coll [row #+ Row row])))) + (collection [row #+ Row row])))) (type: #export Year Int) diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux index 88058868b..1765c524e 100644 --- a/stdlib/source/lux/time/instant.lux +++ b/stdlib/source/lux/time/instant.lux @@ -12,8 +12,8 @@ [number "int/" Codec] ["e" error] [maybe] - (coll [list "L/" Fold Functor] - [row #+ Row row "row/" Functor Fold])) + (collection [list "L/" Fold Functor] + [row #+ Row row "row/" Functor Fold])) (type abstract)) (// [duration "duration/" Order] [date])) diff --git a/stdlib/source/lux/type/abstract.lux b/stdlib/source/lux/type/abstract.lux index d9aa8a8bb..28c90bbc8 100644 --- a/stdlib/source/lux/type/abstract.lux +++ b/stdlib/source/lux/type/abstract.lux @@ -4,7 +4,7 @@ ["p" parser]) (data [text "text/" Equivalence Monoid] [error] - (coll [list "list/" Functor Monoid])) + (collection [list "list/" Functor Monoid])) [macro #+ "meta/" Monad] (macro [code] ["s" syntax #+ syntax:] diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux index aa0326b93..ea82200df 100644 --- a/stdlib/source/lux/type/implicit.lux +++ b/stdlib/source/lux/type/implicit.lux @@ -6,8 +6,8 @@ (data [text "text/" Equivalence] text/format [number] - (coll [list "list/" Monad Fold] - ["dict" dictionary #+ Dictionary]) + (collection [list "list/" Monad Fold] + ["dict" dictionary #+ Dictionary]) [bool] [product] [maybe]) diff --git a/stdlib/source/lux/type/object/interface.lux b/stdlib/source/lux/type/object/interface.lux index c2eca52ce..f48ccab0a 100644 --- a/stdlib/source/lux/type/object/interface.lux +++ b/stdlib/source/lux/type/object/interface.lux @@ -7,8 +7,8 @@ [product] [maybe] [ident #+ "ident/" Equivalence] - (coll [list "list/" Functor Fold Monoid] - [set #+ Set])) + (collection [list "list/" Functor Fold Monoid] + [set #+ Set])) [macro #+ Monad "meta/" Monad] (macro [code] ["s" syntax #+ syntax:] diff --git a/stdlib/source/lux/type/object/protocol.lux b/stdlib/source/lux/type/object/protocol.lux index 3499b436a..5407b8f3f 100644 --- a/stdlib/source/lux/type/object/protocol.lux +++ b/stdlib/source/lux/type/object/protocol.lux @@ -3,7 +3,7 @@ (lux (control ["p" parser] [monad #+ do]) (data [sum] - (coll [list "list/" Functor])) + (collection [list "list/" Functor])) [macro "meta/" Monad] (macro [code] ["s" syntax #+ syntax:] diff --git a/stdlib/source/lux/type/resource.lux b/stdlib/source/lux/type/resource.lux index cf2650f74..636939a1b 100644 --- a/stdlib/source/lux/type/resource.lux +++ b/stdlib/source/lux/type/resource.lux @@ -9,10 +9,10 @@ [product] [number] text/format - (coll ["dict" dictionary #+ Dictionary] - [set] - [row #+ Row] - [list "list/" Functor Fold])) + (collection ["dict" dictionary #+ Dictionary] + [set] + [row #+ Row] + [list "list/" Functor Fold])) (concurrency [promise #+ Promise]) [macro] (macro ["s" syntax #+ Syntax syntax:]) diff --git a/stdlib/source/lux/world/env.jvm.lux b/stdlib/source/lux/world/env.jvm.lux index 39c5f9472..56d2c9bf8 100644 --- a/stdlib/source/lux/world/env.jvm.lux +++ b/stdlib/source/lux/world/env.jvm.lux @@ -2,7 +2,7 @@ lux (lux (data [text] (format [context #+ Context]) - (coll ["dict" dictionary])) + (collection ["dict" dictionary])) [io #- run] [host])) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 3e0a6c65e..de93d940a 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -5,7 +5,7 @@ pipe) (data [error #+ Error] text/format - (coll [array])) + (collection [array])) (time [instant #+ Instant] [duration]) (world [blob #+ Blob]) diff --git a/stdlib/source/lux/world/net/udp.jvm.lux b/stdlib/source/lux/world/net/udp.jvm.lux index a11405132..527d957c6 100644 --- a/stdlib/source/lux/world/net/udp.jvm.lux +++ b/stdlib/source/lux/world/net/udp.jvm.lux @@ -6,7 +6,7 @@ ["T" task]) (data ["e" error] [maybe] - (coll [array])) + (collection [array])) (type abstract) (world [blob #+ Blob]) [io] -- cgit v1.2.3