diff options
Diffstat (limited to 'stdlib')
31 files changed, 557 insertions, 323 deletions
diff --git a/stdlib/source/lux.lux b/stdlib/source/lux.lux index fa33ac0b4..01401ea29 100644 --- a/stdlib/source/lux.lux +++ b/stdlib/source/lux.lux @@ -1,7 +1,7 @@ ("lux def" dummy-location ["" 0 0] [["" 0 0] (9 #1 (0 #0))] - #1) + #0) ("lux def" double-quote ("lux i64 char" +34) @@ -5856,15 +5856,6 @@ _ (fail (..wrong-syntax-error (name-of ..^code))))) -(def: #export (location-description [file line column]) - (-> Location Text) - (let [separator ", " - fields ($_ "lux text concat" - (text@encode file) separator - (nat@encode line) separator - (nat@encode column))] - ($_ "lux text concat" "[" fields "]"))) - (template [<zero> <one>] [(def: #export <zero> #0) (def: #export <one> #1)] diff --git a/stdlib/source/lux/abstract/comonad.lux b/stdlib/source/lux/abstract/comonad.lux index 14515da25..0722d7a1b 100644 --- a/stdlib/source/lux/abstract/comonad.lux +++ b/stdlib/source/lux/abstract/comonad.lux @@ -4,7 +4,9 @@ [number ["n" nat]] [collection - ["." list ("#@." fold)]]]] + ["." list ("#@." fold)]]] + [meta + ["." location]]] [// [functor (#+ Functor)]]) @@ -44,7 +46,7 @@ (if (|> bindings list.size (n.% 2) (n.= 0)) (let [[module short] (name-of ..be) gensym (: (-> Text Code) - (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [.dummy-location])) + (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy])) g!_ (gensym "_") g!map (gensym "map") g!split (gensym "split") @@ -62,7 +64,7 @@ (list.reverse (list.as-pairs bindings)))] (#.Right [state (list (case ?name (#.Some name) - (let [name [.dummy-location (#.Identifier ["" name])]] + (let [name [location.dummy (#.Identifier ["" name])]] (` ({(~ name) ({[(~ g!map) (~' unwrap) (~ g!split)] (~ body')} diff --git a/stdlib/source/lux/abstract/monad.lux b/stdlib/source/lux/abstract/monad.lux index c2b19362d..7cc5ae263 100644 --- a/stdlib/source/lux/abstract/monad.lux +++ b/stdlib/source/lux/abstract/monad.lux @@ -1,5 +1,7 @@ (.module: - [lux #*] + [lux #* + [meta + ["." location]]] [// [functor (#+ Functor)]]) @@ -70,7 +72,7 @@ (if (|> bindings list@size .int ("lux i64 %" +2) ("lux i64 =" +0)) (let [[module short] (name-of ..do) gensym (: (-> Text Code) - (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [.dummy-location])) + (|>> ($_ "lux text concat" module " " short " ") [""] #.Identifier [location.dummy])) g!_ (gensym "_") g!map (gensym "map") g!join (gensym "join") @@ -88,7 +90,7 @@ (reverse (as-pairs bindings)))] (#.Right [state (list (case ?name (#.Some name) - (let [name [.dummy-location (#.Identifier ["" name])]] + (let [name [location.dummy (#.Identifier ["" name])]] (` ({(~ name) ({[(~ g!map) (~' wrap) (~ g!join)] (~ body')} diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux index 5d0a04ea9..0b773a08e 100644 --- a/stdlib/source/lux/control/exception.lux +++ b/stdlib/source/lux/control/exception.lux @@ -70,12 +70,12 @@ (def: #export (construct exception message) {#.doc "Constructs an exception."} (All [e] (-> (Exception e) e Text)) - ((get@ #constructor exception) message)) + ((get@ #..constructor exception) message)) (def: #export (throw exception message) {#.doc "Decorate an error message with an Exception and lift it into the error-handling context."} (All [e a] (-> (Exception e) e (Try a))) - (#//.Failure (construct exception message))) + (#//.Failure (..construct exception message))) (def: #export (assert exception message test) (All [e] (-> (Exception e) e Bit (Try Any))) diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux index 28466fc05..2aef71e06 100644 --- a/stdlib/source/lux/control/thread.lux +++ b/stdlib/source/lux/control/thread.lux @@ -25,7 +25,7 @@ (All [a] (-> a (All [!] (Thread ! (Box ! a))))) (function (_ !) (|> (array.new 1) - (array.write 0 init) + (array.write! 0 init) :abstraction))) (def: #export (read box) @@ -48,7 +48,7 @@ (def: #export (write value box) (All [a] (-> a (All [!] (-> (Box ! a) (Thread ! Any))))) (function (_ !) - (|> box :representation (array.write 0 value) :abstraction))) + (|> box :representation (array.write! 0 value) :abstraction))) ) (def: #export (run thread) diff --git a/stdlib/source/lux/control/try.lux b/stdlib/source/lux/control/try.lux index 74707c51b..8f710b0f0 100644 --- a/stdlib/source/lux/control/try.lux +++ b/stdlib/source/lux/control/try.lux @@ -4,7 +4,9 @@ [apply (#+ Apply)] [equivalence (#+ Equivalence)] ["." functor (#+ Functor)] - ["." monad (#+ Monad do)]]]) + ["." monad (#+ Monad do)]] + [meta + ["." location]]]) (type: #export (Try a) (#Failure Text) @@ -143,7 +145,7 @@ (#..Success (~' g!temp)) (~' g!temp) - (#..Failure (~ [.dummy-location (#.Identifier ["" ""])])) + (#..Failure (~ [location.dummy (#.Identifier ["" ""])])) (~ else))))]) _ diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index 6d2e7c16d..a2a13eb5a 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -89,7 +89,7 @@ (#.Some output)))}) #.None)) - (def: #export (write index value array) + (def: #export (write! index value array) (All [a] (-> Nat a (Array a) (Array a))) (for {@.old @@ -104,15 +104,15 @@ @.js ("js array write" index value array)})) - (def: #export (delete index array) + (def: #export (delete! index array) (All [a] (-> Nat (Array a) (Array a))) (if (n.< (size array) index) (for {@.old - (write index (:assume ("jvm object null")) array) + (write! index (:assume ("jvm object null")) array) @.jvm - (write index (:assume (: <elem-type> ("jvm object null"))) array) + (write! index (:assume (: <elem-type> ("jvm object null"))) array) @.js ("js array delete" index array)}) @@ -129,7 +129,7 @@ _ false)) -(def: #export (update index transform array) +(def: #export (update! index transform array) (All [a] (-> Nat (-> a a) (Array a) (Array a))) (case (read index array) @@ -137,16 +137,16 @@ array (#.Some value) - (write index (transform value) array))) + (write! index (transform value) array))) -(def: #export (upsert index default transform array) +(def: #export (upsert! index default transform array) (All [a] (-> Nat a (-> a a) (Array a) (Array a))) - (write index - (|> array (read index) (maybe.default default) transform) - array)) + (write! index + (|> array (read index) (maybe.default default) transform) + array)) -(def: #export (copy length src-start src-array dest-start dest-array) +(def: #export (copy! length src-start src-array dest-start dest-array) (All [a] (-> Nat Nat (Array a) Nat (Array a) (Array a))) @@ -158,11 +158,11 @@ target (#.Some value) - (write (n.+ offset dest-start) value target))) + (write! (n.+ offset dest-start) value target))) dest-array (list.indices length)))) -(def: #export (occupied array) +(def: #export (occupancy array) {#.doc "Finds out how many cells in an array are occupied."} (All [a] (-> (Array a) Nat)) (list@fold (function (_ idx count) @@ -175,14 +175,14 @@ 0 (list.indices (size array)))) -(def: #export (vacant array) +(def: #export (vacancy array) {#.doc "Finds out how many cells in an array are vacant."} (All [a] (-> (Array a) Nat)) - (n.- (occupied array) (size array))) + (n.- (..occupancy array) (..size array))) (def: #export (filter! p xs) (All [a] - (-> (-> a Bit) (Array a) (Array a))) + (-> (Predicate a) (Array a) (Array a))) (list@fold (function (_ idx xs') (case (read idx xs) #.None @@ -191,13 +191,13 @@ (#.Some x) (if (p x) xs' - (delete idx xs')))) + (delete! idx xs')))) xs (list.indices (size xs)))) (def: #export (find p xs) (All [a] - (-> (-> a Bit) (Array a) (Maybe a))) + (-> (Predicate a) (Array a) (Maybe a))) (let [arr-size (size xs)] (loop [idx 0] (if (n.< arr-size idx) @@ -237,14 +237,14 @@ ys (#.Some x) - (write idx x ys))) + (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)]) + [(inc idx) (write! idx x arr)]) [0 (new (list.size xs))] xs))) @@ -254,7 +254,7 @@ (All [a] (-> (Array a) (List a))) (loop [idx (dec (size array)) output #.Nil] - (if (n.= underflow idx) + (if (n.= ..underflow idx) output (recur (dec idx) (case (read idx array) @@ -268,7 +268,7 @@ (All [a] (-> a (Array a) (List a))) (loop [idx (dec (size array)) output #.Nil] - (if (n.= underflow idx) + (if (n.= ..underflow idx) output (recur (dec idx) (#.Cons (maybe.default default (read idx array)) @@ -276,6 +276,7 @@ (structure: #export (equivalence (^open ",@.")) (All [a] (-> (Equivalence a) (Equivalence (Array a)))) + (def: (= xs ys) (let [sxs (size xs) sxy (size ys)] @@ -294,17 +295,21 @@ true (list.indices sxs)))))) -(structure: #export monoid (All [a] (Monoid (Array a))) +(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))))) + (copy! sxs 0 xs 0) + (copy! sxy 0 ys sxs))))) -(structure: #export functor (Functor Array) +(structure: #export functor + (Functor Array) + (def: (map f ma) (let [arr-size (size ma)] (if (n.= 0 arr-size) @@ -315,12 +320,14 @@ mb (#.Some x) - (write idx (f x) mb))) + (write! idx (f x) mb))) (new arr-size) (list.indices arr-size)) )))) -(structure: #export fold (Fold Array) +(structure: #export fold + (Fold Array) + (def: (fold f init xs) (let [arr-size (size xs)] (loop [so-far init @@ -337,7 +344,7 @@ (template [<name> <init> <op>] [(def: #export (<name> predicate array) (All [a] - (-> (Predicate a) (Array a) Bit)) + (-> (Predicate a) (Predicate (Array a)))) (let [size (..size array)] (loop [idx 0] (if (n.< size idx) diff --git a/stdlib/source/lux/data/collection/bits.lux b/stdlib/source/lux/data/collection/bits.lux index 2529275a3..230b35fa9 100644 --- a/stdlib/source/lux/data/collection/bits.lux +++ b/stdlib/source/lux/data/collection/bits.lux @@ -12,14 +12,18 @@ [collection ["." array (#+ Array) ("#@." fold)]]]]) -(type: #export Chunk I64) +(type: #export Chunk + I64) -(def: #export chunk-size i64.width) +(def: #export chunk-size + i64.width) (type: #export Bits (Array Chunk)) -(def: empty-chunk Chunk (.i64 0)) +(def: empty-chunk + Chunk + (.i64 0)) (def: #export empty Bits @@ -79,7 +83,7 @@ (|> (if (is? ..empty output) (: Bits (array.new size|output)) output) - (array.write idx|output (.i64 chunk)) + (array.write! idx|output (.i64 chunk)) (recur (dec size|output)))) output)))))] @@ -120,7 +124,7 @@ (|> (if (is? ..empty output) (: Bits (array.new size|output)) output) - (array.write idx (.i64 chunk)) + (array.write! idx (.i64 chunk)) (recur (dec size|output))) output)))))) @@ -147,7 +151,7 @@ (|> (if (is? ..empty output) (: Bits (array.new size|output)) output) - (array.write idx (.i64 chunk)) + (array.write! idx (.i64 chunk)) (recur (dec size|output)))) output)))))] @@ -156,7 +160,9 @@ [xor i64.xor] ) -(structure: #export equivalence (Equivalence Bits) +(structure: #export equivalence + (Equivalence Bits) + (def: (= reference sample) (let [size (n.max (array.size reference) (array.size sample))] diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux index 61c82c49b..a71acfb44 100644 --- a/stdlib/source/lux/data/collection/dictionary.lux +++ b/stdlib/source/lux/data/collection/dictionary.lux @@ -15,8 +15,7 @@ ["n" nat]] [collection ["." list ("#@." fold functor monoid)] - ["." array (#+ Array) ("#@." functor fold)]]] - ]) + ["." array (#+ Array) ("#@." functor fold)]]]]) ## This implementation of Hash Array Mapped Trie (HAMT) is based on ## Clojure's PersistentHashMap implementation. @@ -25,19 +24,23 @@ ## 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) +(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) +(type: BitPosition + Nat) ## An index into an array. -(type: Index Nat) +(type: Index + Nat) ## A hash-code derived from a key during tree-traversal. -(type: Hash-Code Nat) +(type: Hash-Code + Nat) ## Represents the nesting level of a leaf or node, when looking-it-up ## while exploring the tree. @@ -46,7 +49,8 @@ ## 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) +(type: Level + Nat) ## Nodes for the tree data-structure that organizes the data inside ## Dictionaries. @@ -128,27 +132,27 @@ (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))))) + (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))) + (|> 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))) + (|> 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)))) + (array.copy! idx 0 array 0) + (array.copy! (n.- idx new-size) (inc idx) array idx)))) ## Increases the level-shift by the branching-exponent, to explore ## levels further down the tree. @@ -231,7 +235,7 @@ [insertion-idx node] [(inc insertion-idx) [(set-bit-position (->bit-position idx) bitmap) - (array.write insertion-idx (#.Left sub-node) base)]]) + (array.write! insertion-idx (#.Left sub-node) base)]]) ))) [0 [clean-bitmap (array.new (dec h-size))]] @@ -253,12 +257,12 @@ [(inc base-idx) (case (array.read base-idx base) (#.Some (#.Left sub-node)) - (array.write hierarchy-idx sub-node h-array) + (array.write! hierarchy-idx sub-node h-array) (#.Some (#.Right [key' val'])) - (array.write hierarchy-idx - (put' (level-up level) (:: Hash<k> hash key') key' val' Hash<k> empty) - h-array) + (array.write! hierarchy-idx + (put' (level-up level) (:: Hash<k> hash key') key' val' Hash<k> empty) + h-array) #.None (undefined))] @@ -326,8 +330,8 @@ ## #Collisions node ## is added. (#Collisions hash (|> (array.new 2) - (array.write 0 [key' val']) - (array.write 1 [key val]))) + (array.write! 0 [key' val']) + (array.write! 1 [key val]))) ## Otherwise, I can ## just keep using ## #Base nodes, so I @@ -346,8 +350,8 @@ ## KV-pair as a singleton node to it. (#Hierarchy (inc base-count) (|> (promote-base put' Hash<k> level bitmap base) - (array.write (level-index level hash) - (put' (level-up level) hash key val Hash<k> empty)))) + (array.write! (level-index level hash) + (put' (level-up level) hash key val Hash<k> empty)))) ## Otherwise, I just resize the #Base node to accommodate the ## new KV-pair. (#Base (set-bit-position bit bitmap) @@ -371,7 +375,7 @@ ## contains the old #Collisions node, plus the new KV-pair. (|> (#Base (bit-position level _hash) (|> (array.new 1) - (array.write 0 (#.Left node)))) + (array.write! 0 (#.Left node)))) (put' level hash key val Hash<k>))) )) diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux index 8c0ce748c..8d0dfab29 100644 --- a/stdlib/source/lux/data/collection/row.lux +++ b/stdlib/source/lux/data/collection/row.lux @@ -85,13 +85,13 @@ (if (n.= 0 level) (#Base tail) (|> (new-hierarchy []) - (array.write 0 (new-path (level-down level) tail)) + (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))) + (array.write! 0 singleton))) (def: (push-tail size level tail parent) (All [a] (-> Nat Level (Base a) (Hierarchy a) (Hierarchy a))) @@ -113,14 +113,14 @@ (undefined)) )] (|> (array.clone parent) - (array.write sub-idx sub-node)))) + (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)))) + (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))) @@ -128,14 +128,14 @@ (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)))) + (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))) + (array.write! sub-idx (|> (array.clone base) + (array.write! (branch-idx idx) val) + #Base))) _ (undefined)))) @@ -156,12 +156,12 @@ (#Base _) (undefined))] (|> (array.clone hierarchy) - (array.write sub-idx (#Hierarchy sub)) + (array.write! sub-idx (#Hierarchy sub)) #.Some)) ## Else... (|> (array.clone hierarchy) - (array.delete sub-idx) + (array.delete! sub-idx) #.Some) ))) @@ -216,8 +216,8 @@ (: (Hierarchy ($ 0)) (new-hierarchy []))} (new-hierarchy [])) - (array.write 0 (#Hierarchy (get@ #root row))) - (array.write 1 (new-path (get@ #level row) (get@ #tail row))))) + (array.write! 0 (#Hierarchy (get@ #root row))) + (array.write! 1 (new-path (get@ #level row) (get@ #tail row))))) (update@ #level level-up)) ## Otherwise, just push the current tail onto the root. (|> row @@ -281,8 +281,8 @@ (#try.Success (if (n.>= (tail-off row-size) idx) (update@ #tail (for {@.old (: (-> (Base ($ 0)) (Base ($ 0))) - (|>> array.clone (array.write (branch-idx idx) val)))} - (|>> array.clone (array.write (branch-idx idx) val))) + (|>> array.clone (array.write! (branch-idx idx) val)))} + (|>> array.clone (array.write! (branch-idx idx) val))) row) (update@ #root (put' (get@ #level row) idx val) row))) @@ -310,7 +310,7 @@ (|> row (update@ #size dec) (set@ #tail (|> (array.new new-tail-size) - (array.copy new-tail-size 0 old-tail 0))))) + (array.copy! new-tail-size 0 old-tail 0))))) (maybe.assume (do maybe.monad [new-tail (base-for (n.- 2 row-size) row) diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux index 2e7912550..0dcb32b6e 100644 --- a/stdlib/source/lux/data/maybe.lux +++ b/stdlib/source/lux/data/maybe.lux @@ -6,7 +6,9 @@ [hash (#+ Hash)] [apply (#+ Apply)] ["." functor (#+ Functor)] - ["." monad (#+ Monad do)]]]) + ["." monad (#+ Monad do)]] + [meta + ["." location]]]) ## (type: (Maybe a) ## #.None @@ -123,7 +125,7 @@ +20)} (case tokens (^ (list else maybe)) - (let [g!temp (: Code [.dummy-location (#.Identifier ["" ""])]) + (let [g!temp (: Code [location.dummy (#.Identifier ["" ""])]) code (` (case (~ maybe) (#.Some (~ g!temp)) (~ g!temp) diff --git a/stdlib/source/lux/data/number/rev.lux b/stdlib/source/lux/data/number/rev.lux index be4959726..eef378a75 100644 --- a/stdlib/source/lux/data/number/rev.lux +++ b/stdlib/source/lux/data/number/rev.lux @@ -170,25 +170,35 @@ (-> Rev Frac) (|>> to-significand ("lux f64 /" frac-denominator))) -(structure: #export equivalence (Equivalence Rev) +(structure: #export equivalence + (Equivalence Rev) + (def: = ..=)) -(structure: #export order (Order Rev) +(structure: #export order + (Order Rev) + (def: &equivalence ..equivalence) (def: < ..<)) -(structure: #export enum (Enum Rev) +(structure: #export enum + (Enum Rev) + (def: &order ..order) (def: succ inc) (def: pred dec)) -(structure: #export interval (Interval Rev) +(structure: #export interval + (Interval Rev) + (def: &enum ..enum) (def: top (.rev -1)) (def: bottom (.rev 0))) (template [<name> <compose> <identity>] - [(structure: #export <name> (Monoid Rev) + [(structure: #export <name> + (Monoid Rev) + (def: identity (:: interval <identity>)) (def: compose <compose>))] @@ -203,7 +213,9 @@ (template [<struct> <codec> <char-bit-size> <error>] [(with-expansions [<error-output> (as-is (#try.Failure ("lux text concat" <error> repr)))] - (structure: #export <struct> (Codec Text Rev) + (structure: #export <struct> + (Codec Text Rev) + (def: (encode value) (let [raw-output (:: <codec> encode (:coerce Nat value)) max-num-chars (//nat.+ (//nat./ <char-bit-size> 64) @@ -254,53 +266,53 @@ ## targeted by Lux. (type: Digits (Array Nat)) -(def: (make-digits _) +(def: (digits::new _) (-> Any Digits) (array.new //i64.width)) -(def: (digits-get idx digits) +(def: (digits::get idx digits) (-> Nat Digits Nat) (|> digits (array.read idx) (maybe.default 0))) -(def: digits-put +(def: digits::put (-> Nat Nat Digits Digits) - array.write) + array.write!) (def: (prepend left right) (-> Text Text Text) ("lux text concat" left right)) -(def: (digits-times-5! idx output) +(def: (digits::times-5! idx output) (-> Nat Digits Digits) (loop [idx idx carry 0 output output] (if (//int.>= +0 (.int idx)) - (let [raw (|> (digits-get idx output) + (let [raw (|> (digits::get idx output) (//nat.* 5) (//nat.+ carry))] (recur (dec idx) (//nat./ 10 raw) - (digits-put idx (//nat.% 10 raw) output))) + (digits::put idx (//nat.% 10 raw) output))) output))) -(def: (digits-power power) +(def: (digits::power power) (-> Nat Digits) (loop [times power - output (|> (make-digits []) - (digits-put power 1))] + output (|> (digits::new []) + (digits::put power 1))] (if (//int.>= +0 (.int times)) (recur (dec times) - (digits-times-5! power output)) + (digits::times-5! power output)) output))) -(def: (digits-to-text digits) +(def: (digits::to-text digits) (-> Digits Text) (loop [idx (dec //i64.width) all-zeroes? #1 output ""] (if (//int.>= +0 (.int idx)) - (let [digit (digits-get idx digits)] + (let [digit (digits::get idx digits)] (if (and (//nat.= 0 digit) all-zeroes?) (recur (dec idx) #1 output) @@ -313,19 +325,19 @@ "0" output)))) -(def: (digits-add param subject) +(def: (digits::+ param subject) (-> Digits Digits Digits) (loop [idx (dec //i64.width) carry 0 - output (make-digits [])] + output (digits::new [])] (if (//int.>= +0 (.int idx)) (let [raw ($_ //nat.+ carry - (digits-get idx param) - (digits-get idx subject))] + (digits::get idx param) + (digits::get idx subject))] (recur (dec idx) (//nat./ 10 raw) - (digits-put idx (//nat.% 10 raw) output))) + (digits::put idx (//nat.% 10 raw) output))) output))) (def: (text-to-digits input) @@ -333,7 +345,7 @@ (let [length ("lux text size" input)] (if (//nat.<= //i64.width length) (loop [idx 0 - output (make-digits [])] + output (digits::new [])] (if (//nat.< length idx) (case ("lux text index" 0 ("lux text clip" idx (inc idx) input) "0123456789") #.None @@ -341,42 +353,44 @@ (#.Some digit) (recur (inc idx) - (digits-put idx digit output))) + (digits::put idx digit output))) (#.Some output))) #.None))) -(def: (digits-lt param subject) +(def: (digits::< param subject) (-> Digits Digits Bit) (loop [idx 0] (and (//nat.< //i64.width idx) - (let [pd (digits-get idx param) - sd (digits-get idx subject)] + (let [pd (digits::get idx param) + sd (digits::get idx subject)] (if (//nat.= pd sd) (recur (inc idx)) (//nat.< pd sd)))))) -(def: (digits-sub-once! idx param subject) +(def: (digits::-!' idx param subject) (-> Nat Nat Digits Digits) - (let [sd (digits-get idx subject)] + (let [sd (digits::get idx subject)] (if (//nat.>= param sd) - (digits-put idx (//nat.- param sd) subject) + (digits::put idx (//nat.- param sd) subject) (let [diff (|> sd (//nat.+ 10) (//nat.- param))] (|> subject - (digits-put idx diff) - (digits-sub-once! (dec idx) 1)))))) + (digits::put idx diff) + (digits::-!' (dec idx) 1)))))) -(def: (digits-sub! param subject) +(def: (digits::-! param subject) (-> Digits Digits Digits) (loop [idx (dec //i64.width) output subject] (if (//int.>= +0 (.int idx)) (recur (dec idx) - (digits-sub-once! idx (digits-get idx param) output)) + (digits::-!' idx (digits::get idx param) output)) output))) -(structure: #export decimal (Codec Text Rev) +(structure: #export decimal + (Codec Text Rev) + (def: (encode input) (case (:coerce Nat input) 0 @@ -385,16 +399,16 @@ input (let [last-idx (dec //i64.width)] (loop [idx last-idx - digits (make-digits [])] + digits (digits::new [])] (if (//int.>= +0 (.int idx)) (if (//i64.set? idx input) - (let [digits' (digits-add (digits-power (//nat.- idx last-idx)) - digits)] + (let [digits' (digits::+ (digits::power (//nat.- idx last-idx)) + digits)] (recur (dec idx) digits')) (recur (dec idx) digits)) - ("lux text concat" "." (digits-to-text digits)) + ("lux text concat" "." (digits::to-text digits)) ))))) (def: (decode input) @@ -413,11 +427,11 @@ idx 0 output 0] (if (//nat.< //i64.width idx) - (let [power (digits-power idx)] - (if (digits-lt power digits) + (let [power (digits::power idx)] + (if (digits::< power digits) ## Skip power (recur digits (inc idx) output) - (recur (digits-sub! power digits) + (recur (digits::-! power digits) (inc idx) (//i64.set (//nat.- idx (dec //i64.width)) output)))) (#try.Success (:coerce Rev output)))) @@ -427,6 +441,8 @@ (#try.Failure ("lux text concat" "Wrong syntax for Rev: " input)))) )) -(structure: #export hash (Hash Rev) +(structure: #export hash + (Hash Rev) + (def: &equivalence ..equivalence) (def: hash .nat)) diff --git a/stdlib/source/lux/data/text/format.lux b/stdlib/source/lux/data/text/format.lux index 388bd3638..ecbdb80df 100644 --- a/stdlib/source/lux/data/text/format.lux +++ b/stdlib/source/lux/data/text/format.lux @@ -5,8 +5,8 @@ [functor ["." contravariant]]] [control - ["p" parser - ["s" code (#+ Parser)]]] + ["<>" parser + ["<c>" code (#+ Parser)]]] [data ["." bit] ["." name] @@ -29,8 +29,10 @@ [math ["." modular]] [macro - ["." code] - [syntax (#+ syntax:)]] + [syntax (#+ syntax:)] + ["." code]] + [meta + ["." location]] ["." type]]) (type: #export (Format a) @@ -43,7 +45,7 @@ (def: (map f fb) (|>> f fb))) -(syntax: #export (format {fragments (p.many s.any)}) +(syntax: #export (format {fragments (<>.many <c>.any)}) {#.doc (doc "Text interpolation." (format "Static part " (text static) " does not match URI: " uri))} (wrap (.list (` ($_ "lux text concat" (~+ fragments)))))) @@ -71,7 +73,7 @@ [instant instant.Instant (:: instant.codec encode)] [duration duration.Duration (:: duration.codec encode)] [date date.Date (:: date.codec encode)] - [location Location .location-description] + [location Location location.format] ) (def: #export (mod modular) diff --git a/stdlib/source/lux/macro/code.lux b/stdlib/source/lux/macro/code.lux index 7678852a6..c5064c480 100644 --- a/stdlib/source/lux/macro/code.lux +++ b/stdlib/source/lux/macro/code.lux @@ -12,7 +12,9 @@ ["." frac]] ["." text ("#@." monoid equivalence)] [collection - ["." list ("#@." functor fold)]]]]) + ["." list ("#@." functor fold)]]] + [meta + ["." location]]]) ## (type: (Code' w) ## (#.Bit Bit) @@ -33,7 +35,7 @@ (template [<name> <type> <tag>] [(def: #export (<name> x) (-> <type> Code) - [.dummy-location (<tag> x)])] + [location.dummy (<tag> x)])] [bit Bit #.Bit] [nat Nat #.Nat] @@ -52,7 +54,7 @@ [(def: #export (<name> name) {#.doc <doc>} (-> Text Code) - [.dummy-location (<tag> ["" name])])] + [location.dummy (<tag> ["" name])])] [local-identifier #.Identifier "Produces a local identifier (an identifier with no module prefix)."] [local-tag #.Tag "Produces a local tag (a tag with no module prefix)."]) diff --git a/stdlib/source/lux/meta.lux b/stdlib/source/lux/meta.lux index ec23805c5..1155eaf93 100644 --- a/stdlib/source/lux/meta.lux +++ b/stdlib/source/lux/meta.lux @@ -8,16 +8,18 @@ ["." try (#+ Try)]] [data ["." product] - ["." name ("#@." codec equivalence)] ["." maybe] + ["." text ("#@." monoid equivalence)] + ["." name ("#@." codec equivalence)] [number ["n" nat] ["i" int]] - ["." text ("#@." monoid equivalence)] [collection ["." list ("#@." monoid monad)]]] [macro - ["." code]]]) + ["." code]]] + [/ + ["." location]]) ## (type: (Meta a) ## (-> Lux (Try [Lux a]))) @@ -684,7 +686,7 @@ (do ..monad [location ..location output (<func> token) - #let [_ (log! ($_ text@compose (name@encode (name-of <macro>)) " @ " (.location-description location))) + #let [_ (log! ($_ text@compose (name@encode (name-of <macro>)) " @ " (location.format location))) _ (list@map (|>> code.to-text log!) output) _ (log! "")]] diff --git a/stdlib/source/lux/meta/location.lux b/stdlib/source/lux/meta/location.lux new file mode 100644 index 000000000..351ace90c --- /dev/null +++ b/stdlib/source/lux/meta/location.lux @@ -0,0 +1,30 @@ +(.module: + [lux #*]) + +(def: #export dummy + Location + {#.module "" + #.line 0 + #.column 0}) + +(macro: #export (here tokens compiler) + (case tokens + #.Nil + (let [location (get@ #.location compiler)] + (#.Right [compiler + (list (` [(~ [..dummy (#.Text (get@ #.module location))]) + (~ [..dummy (#.Nat (get@ #.line location))]) + (~ [..dummy (#.Nat (get@ #.column location))])]))])) + + _ + (#.Left "Wrong syntax for here"))) + +(def: #export (format value) + (-> Location Text) + (let [separator "," + [file line column] value] + ($_ "lux text concat" + "@" + (("lux in-module" "lux" .text@encode) file) separator + (("lux in-module" "lux" .nat@encode) line) separator + (("lux in-module" "lux" .nat@encode) column)))) diff --git a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux index 96296a39a..18189b405 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/analysis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/analysis.lux @@ -20,7 +20,9 @@ ["." text ("#@." equivalence) ["%" format (#+ Format format)]] [collection - ["." list ("#@." functor fold)]]]] + ["." list ("#@." functor fold)]]] + [meta + ["." location]]] [// [phase ["." extension (#+ Extension)]] @@ -522,7 +524,7 @@ (def: dummy-source Source - [.dummy-location 0 ""]) + [location.dummy 0 ""]) (def: type-context Type-Context @@ -540,7 +542,7 @@ (-> Info Lux) {#.info info #.source ..dummy-source - #.location .dummy-location + #.location location.dummy #.current-module #.None #.modules (list) #.scopes (list) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux index e490ba168..41c99534a 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis.lux @@ -7,7 +7,8 @@ [data [text ["%" format (#+ format)]]] - ["." meta]] + ["." meta + ["." location]]] ["." / #_ ["#." type] ["#." primitive] @@ -128,7 +129,7 @@ (/function.apply compile argsC+ functionT functionA archive functionC))) _ - (//.throw unrecognized-syntax [.dummy-location code']))) + (//.throw unrecognized-syntax [location.dummy code']))) (def: #export (phase expander) (-> Expander Phase) diff --git a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux index c0bf41a7e..f05b0e1ba 100644 --- a/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux +++ b/stdlib/source/lux/tool/compiler/language/lux/phase/analysis/inference.lux @@ -88,7 +88,7 @@ (def: (named-type location id) (-> Location Nat Type) - (let [name (format "{New Type @ " (.location-description location) " " (%.nat id) "}")] + (let [name (format "{New Type " (format.location location) " " (%.nat id) "}")] (#.Primitive name (list)))) (def: new-named-type diff --git a/stdlib/source/lux/type.lux b/stdlib/source/lux/type.lux index f7170adc4..8da9421e4 100644 --- a/stdlib/source/lux/type.lux +++ b/stdlib/source/lux/type.lux @@ -6,21 +6,22 @@ [control ["." function] ["." exception (#+ exception:)] - ["p" parser - ["s" code (#+ Parser)]]] + ["<>" parser + ["<c>" code (#+ Parser)]]] [data + ["." maybe] ["." text ("#@." monoid equivalence)] ["." name ("#@." equivalence codec)] [number ["n" nat ("#@." decimal)]] - ["." maybe] [collection ["." array] ["." list ("#@." functor monoid fold)]]] - ["." meta] [macro - ["." code] - [syntax (#+ syntax:)]]]) + [syntax (#+ syntax:)] + ["." code]] + ["." meta + ["." location]]]) (template [<name> <tag>] [(def: #export (<name> type) @@ -353,32 +354,46 @@ 0 elem-type _ (|> elem-type (array (dec depth)) (list) (#.Primitive array.type-name)))) -(syntax: #export (:log! {input (p.or s.identifier - s.any)}) +(syntax: (new-secret-marker) + (meta.with-gensyms [g!_secret-marker_] + (wrap (list g!_secret-marker_)))) + +(def: secret-marker + (`` (name-of (~~ (new-secret-marker))))) + +(syntax: #export (:log! {input (<>.or (<>.and <c>.identifier + (<>.maybe (<>.after (<c>.identifier! ..secret-marker) <c>.any))) + <c>.any)}) (case input - (#.Left valueN) + (#.Left [valueN valueC]) (do meta.monad [location meta.location valueT (meta.find-type valueN) #let [_ (log! ($_ text@compose - (name@encode (name-of ..:log!)) " @ " (.location-description location) text.new-line - "Value: " (name@encode valueN) text.new-line - " Type: " (..to-text valueT) text.new-line))]] + (name@encode (name-of ..:log!)) " " (location.format location) text.new-line + "Expression: " (case valueC + (#.Some valueC) + (code.to-text valueC) + + #.None + (name@encode valueN)) + text.new-line + " Type: " (..to-text valueT)))]] (wrap (list (code.identifier valueN)))) - + (#.Right valueC) (meta.with-gensyms [g!value] (wrap (list (` (.let [(~ g!value) (~ valueC)] - (..:log! (~ g!value))))))))) + (..:log! (~ valueC) (~ (code.identifier ..secret-marker)) (~ g!value))))))))) (def: type-parameters (Parser (List Text)) - (s.tuple (p.some s.local-identifier))) + (<c>.tuple (<>.some <c>.local-identifier))) (syntax: #export (:cast {type-vars type-parameters} input output - {value (p.maybe s.any)}) + {value (<>.maybe <c>.any)}) (let [casterC (` (: (All [(~+ (list@map code.local-identifier type-vars))] (-> (~ input) (~ output))) (|>> :assume)))] @@ -395,7 +410,7 @@ (def: typed (Parser Typed) - (s.record (p.and s.any s.any))) + (<c>.record (<>.and <c>.any <c>.any))) ## TODO: Make sure the generated code always gets optimized away. (syntax: #export (:share {type-vars type-parameters} @@ -411,7 +426,7 @@ (syntax: #export (:by-example {type-vars type-parameters} {exemplar typed} - {extraction s.any}) + {extraction <c>.any}) (wrap (list (` (:of ((~! :share) [(~+ (list@map code.local-identifier type-vars))] {(~ (get@ #type exemplar)) @@ -421,7 +436,7 @@ (exception: #export (hole-type {location Location} {type Type}) (exception.report - ["Location" (.location-description location)] + ["Location" (location.format location)] ["Type" (..to-text type)])) (syntax: #export (:hole) diff --git a/stdlib/source/program/aedifex/artifact/extension.lux b/stdlib/source/program/aedifex/artifact/extension.lux new file mode 100644 index 000000000..04d40fec4 --- /dev/null +++ b/stdlib/source/program/aedifex/artifact/extension.lux @@ -0,0 +1,37 @@ +(.module: + [lux #* + [data + [text + ["%" format (#+ format)]]]] + ["." // #_ + ["#" type]]) + +(type: #export Extension + Text) + +(def: separator + ".") + +(def: #export extension + (-> //.Type Extension) + (|>> (format ..separator))) + +(def: #export lux-library + Extension + (..extension //.lux-library)) + +(def: #export jvm-library + Extension + (..extension //.jvm-library)) + +(def: #export pom + Extension + (..extension //.pom)) + +(def: #export sha1 + Extension + (format ..separator "sha1")) + +(def: #export md5 + Extension + (format ..separator "md5")) diff --git a/stdlib/source/program/aedifex/dependency.lux b/stdlib/source/program/aedifex/dependency.lux index 3128bb3f3..52a1f00c5 100644 --- a/stdlib/source/program/aedifex/dependency.lux +++ b/stdlib/source/program/aedifex/dependency.lux @@ -29,10 +29,10 @@ [net (#+ URL) ["." uri]]]] ["." // #_ - ["#." extension] ["#." hash] ["#." artifact (#+ Artifact) - ["#/." type]]]) + ["#/." type] + ["#/." extension]]]) (type: #export Repository URL) @@ -219,10 +219,10 @@ (let [[artifact type] dependency prefix (format repository uri.separator (//artifact.path artifact))] (do (try.with io.monad) - [library (..download (format prefix "." type)) - sha1 (..verified-hash dependency library (format prefix //extension.sha1) //hash.sha1 ..sha1 ..sha1-does-not-match) - md5 (..verified-hash dependency library (format prefix //extension.md5) //hash.md5 ..md5 ..md5-does-not-match) - pom (..download (format prefix //extension.pom))] + [library (..download (format prefix (//artifact/extension.extension type))) + sha1 (..verified-hash dependency library (format prefix //artifact/extension.sha1) //hash.sha1 ..sha1 ..sha1-does-not-match) + md5 (..verified-hash dependency library (format prefix //artifact/extension.md5) //hash.md5 ..md5 ..md5-does-not-match) + pom (..download (format prefix //artifact/extension.pom))] (:: io.monad wrap (do try.monad [pom (encoding.from-utf8 pom) diff --git a/stdlib/source/program/aedifex/extension.lux b/stdlib/source/program/aedifex/extension.lux deleted file mode 100644 index 6caa343aa..000000000 --- a/stdlib/source/program/aedifex/extension.lux +++ /dev/null @@ -1,11 +0,0 @@ -(.module: - [lux #*]) - -(def: #export sha1 - ".sha1") - -(def: #export md5 - ".md5") - -(def: #export pom - ".pom") diff --git a/stdlib/source/program/aedifex/local.lux b/stdlib/source/program/aedifex/local.lux index 60b5e8881..affbb659e 100644 --- a/stdlib/source/program/aedifex/local.lux +++ b/stdlib/source/program/aedifex/local.lux @@ -30,12 +30,12 @@ ["." export]]] ["." // #_ ["/" profile (#+ Profile)] - ["#." extension] ["#." pom] ["#." dependency (#+ Package Resolution Dependency)] ["#." hash] ["#." artifact (#+ Artifact) - ["#/." type]]]) + ["#/." type] + ["#/." extension]]]) (def: (local system) (All [a] (-> (file.System a) Path)) @@ -79,10 +79,10 @@ #let [artifact-name (format repository (:: system separator) (//artifact.identity identity))] package (export.library system (set.to-list (get@ #/.sources profile))) _ (..save! system (binary.run tar.writer package) - (format artifact-name "." //artifact/type.lux-library)) + (format artifact-name //artifact/extension.lux-library)) pom (:: promise.monad wrap (//pom.project profile))] (..save! system (|> pom (:: xml.codec encode) encoding.to-utf8) - (format artifact-name //extension.pom))) + (format artifact-name //artifact/extension.pom))) _ (:: promise.monad wrap (exception.throw /.no-identity [])))) @@ -96,16 +96,16 @@ (file.get-directory promise.monad system directory)) _ (..save! system (get@ #//dependency.library package) - (format prefix "." type)) + (format prefix (//artifact/extension.extension type))) _ (..save! system (encoding.to-utf8 (get@ #//dependency.sha1 package)) - (format prefix //extension.sha1)) + (format prefix //artifact/extension.sha1)) _ (..save! system (encoding.to-utf8 (get@ #//dependency.md5 package)) - (format prefix //extension.md5)) + (format prefix //artifact/extension.md5)) _ (..save! system (|> package (get@ #//dependency.pom) (:: xml.codec encode) encoding.to-utf8) - (format prefix //extension.pom))] + (format prefix //artifact/extension.pom))] (wrap []))) (def: #export (cache-all system resolution) @@ -128,16 +128,16 @@ (do (try.with promise.monad) [directory (..guarantee-repository! system artifact) #let [prefix (format directory (:: system separator) (//artifact.identity artifact))] - pom (..read! system (format prefix //extension.pom)) + pom (..read! system (format prefix //artifact/extension.pom)) [pom dependencies] (:: promise.monad wrap (do try.monad [pom (encoding.from-utf8 pom) pom (:: xml.codec decode pom) dependencies (//dependency.from-pom pom)] (wrap [pom dependencies]))) - library (..read! system (format prefix "." type)) - sha1 (..read! system (format prefix //extension.sha1)) - md5 (..read! system (format prefix //extension.md5))] + library (..read! system (format prefix (//artifact/extension.extension type))) + sha1 (..read! system (format prefix //artifact/extension.sha1)) + md5 (..read! system (format prefix //artifact/extension.md5))] (wrap {#//dependency.library library #//dependency.pom pom #//dependency.dependencies dependencies diff --git a/stdlib/source/test/aedifex/artifact.lux b/stdlib/source/test/aedifex/artifact.lux index 72715fdef..376f26717 100644 --- a/stdlib/source/test/aedifex/artifact.lux +++ b/stdlib/source/test/aedifex/artifact.lux @@ -10,7 +10,8 @@ [math ["." random (#+ Random)]]] ["." / #_ - ["#." type]] + ["#." type] + ["#." extension]] {#program ["." /]}) @@ -31,4 +32,5 @@ ($equivalence.spec /.equivalence ..random)) /type.test + /extension.test )))) diff --git a/stdlib/source/test/aedifex/artifact/extension.lux b/stdlib/source/test/aedifex/artifact/extension.lux new file mode 100644 index 000000000..e65dd567a --- /dev/null +++ b/stdlib/source/test/aedifex/artifact/extension.lux @@ -0,0 +1,40 @@ +(.module: + [lux #* + ["_" test (#+ Test)] + [abstract + [monad (#+ do)]] + [data + ["." text ("#@." equivalence)] + [number + ["n" nat]] + [collection + ["." set] + ["." list]]] + [math + ["." random (#+ Random)]]] + {#program + ["." / + ["/#" // #_ + ["#" type]]]}) + +(def: #export test + Test + (<| (_.covering /._) + (_.with-cover [/.Extension] + ($_ _.and + (_.cover [/.lux-library /.jvm-library /.pom + /.sha1 /.md5] + (let [options (list /.lux-library /.jvm-library /.pom /.sha1 /.md5) + uniques (set.from-list text.hash options)] + (n.= (list.size options) + (set.size uniques)))) + (_.cover [/.extension] + (`` (and (~~ (template [<type> <extension>] + [(text@= <extension> + (/.extension <type>))] + + [//.lux-library /.lux-library] + [//.jvm-library /.jvm-library] + [//.pom /.pom] + ))))) + )))) diff --git a/stdlib/source/test/lux/data/collection/array.lux b/stdlib/source/test/lux/data/collection/array.lux index 63366a81d..4cd81db10 100644 --- a/stdlib/source/test/lux/data/collection/array.lux +++ b/stdlib/source/test/lux/data/collection/array.lux @@ -1,25 +1,24 @@ (.module: [lux #* - ["%" data/text/format (#+ format)] ["_" test (#+ Test)] [abstract - [monad (#+ do Monad)] + [monad (#+ do)] {[0 #spec] [/ ["$." equivalence] ["$." monoid] ["$." fold] ["$." functor (#+ Injection)]]}] - [control - pipe] [data + ["." bit] ["." maybe] [number ["n" nat]] [collection - ["." list]]] + ["." list] + ["." set]]] [math - ["r" random (#+ Random)]]] + ["." random (#+ Random)]]] {1 ["." / (#+ Array)]}) @@ -29,90 +28,167 @@ (def: bounded-size (Random Nat) - (|> r.nat - (:: r.monad map (|>> (n.% 100) (n.+ 1))))) + (:: random.monad map (|>> (n.% 100) (n.+ 1)) + random.nat)) (def: #export test Test - (<| (_.context (%.name (name-of /.Array))) - (do {@ r.monad} - [size bounded-size] + (<| (_.covering /._) + (_.with-cover [/.Array]) + (do {@ random.monad} + [size ..bounded-size + base random.nat + shift random.nat + dummy (random.filter (|>> (n.= base) not) random.nat) + #let [expected (n.+ base shift)] + the-array (random.array size random.nat)] ($_ _.and - ($equivalence.spec (/.equivalence n.equivalence) (r.array size r.nat)) - ($monoid.spec (/.equivalence n.equivalence) /.monoid (r.array size r.nat)) - ($functor.spec ..injection /.equivalence /.functor) - ($fold.spec ..injection /.equivalence /.fold) + (_.with-cover [/.equivalence] + ($equivalence.spec (/.equivalence n.equivalence) (random.array size random.nat))) + (_.with-cover [/.monoid] + ($monoid.spec (/.equivalence n.equivalence) /.monoid (random.array size random.nat))) + (_.with-cover [/.functor] + ($functor.spec ..injection /.equivalence /.functor)) + (_.with-cover [/.fold] + ($fold.spec ..injection /.equivalence /.fold)) + (_.cover [/.new /.size] + (n.= size (/.size (: (Array Nat) + (/.new size))))) + (_.cover [/.read /.write!] + (let [the-array (|> (/.new 2) + (: (Array Nat)) + (/.write! 0 expected))] + (case [(/.read 0 the-array) + (/.read 1 the-array)] + [(#.Some actual) #.None] + (n.= expected actual) + + _ + false))) + (_.cover [/.delete!] + (let [the-array (|> (/.new 1) + (: (Array Nat)) + (/.write! 0 expected))] + (case [(/.read 0 the-array) + (/.read 0 (/.delete! 0 the-array))] + [(#.Some actual) #.None] + (n.= expected actual) + + _ + false))) + (_.cover [/.contains?] + (let [the-array (|> (/.new 2) + (: (Array Nat)) + (/.write! 0 expected))] + (and (/.contains? 0 the-array) + (not (/.contains? 1 the-array))))) + + (_.cover [/.update!] + (let [the-array (|> (/.new 1) + (: (Array Nat)) + (/.write! 0 base) + (/.update! 0 (n.+ shift)))] + (case (/.read 0 the-array) + (#.Some actual) + (n.= expected actual) + + _ + false))) + (_.cover [/.upsert!] + (let [the-array (|> (/.new 2) + (: (Array Nat)) + (/.write! 0 base) + (/.upsert! 0 dummy (n.+ shift)) + (/.upsert! 1 base (n.+ shift)))] + (case [(/.read 0 the-array) + (/.read 1 the-array)] + [(#.Some actual/0) (#.Some actual/1)] + (and (n.= expected actual/0) + (n.= expected actual/1)) + + _ + false))) + (do @ + [occupancy (:: @ map (n.% (inc size)) random.nat)] + (_.cover [/.occupancy /.vacancy] + (let [the-array (loop [output (: (Array Nat) + (/.new size)) + idx 0] + (if (n.< occupancy idx) + (recur (/.write! idx expected output) + (inc idx)) + output))] + (and (n.= occupancy (/.occupancy the-array)) + (n.= size (n.+ (/.occupancy the-array) + (/.vacancy the-array))))))) (do @ - [size bounded-size - original (r.array size r.nat)] - ($_ _.and - (_.test "Size function must correctly return size of array." - (n.= size (/.size original))) - (_.test "Cloning an array should yield and identical array, but not the same one." - (let [clone (/.clone original)] - (and (:: (/.equivalence n.equivalence) = original clone) - (not (is? original clone))))) - (_.test "Full-range manual copies should give the same result as cloning." - (let [copy (: (Array Nat) - (/.new size))] - (exec (/.copy size 0 original 0 copy) - (and (:: (/.equivalence n.equivalence) = original copy) - (not (is? original copy)))))) - (_.test "Array folding should go over all values." - (let [manual-copy (: (Array Nat) - (/.new size))] - (exec (:: /.fold fold - (function (_ x idx) - (exec (/.write idx x manual-copy) - (inc idx))) - 0 - original) - (:: (/.equivalence n.equivalence) = original manual-copy)))) - (_.test "Transformations between (full) arrays and lists shouldn't cause lose or change any values." - (|> original - /.to-list /.from-list - (:: (/.equivalence n.equivalence) = original))) - )) + [the-list (random.list size random.nat)] + (_.cover [/.from-list /.to-list] + (and (|> the-list /.from-list /.to-list + (:: (list.equivalence n.equivalence) = the-list)) + (|> the-array /.to-list /.from-list + (:: (/.equivalence n.equivalence) = the-array))))) (do @ - [size bounded-size - idx (:: @ map (n.% size) r.nat) - array (|> (r.array size r.nat) - (r.filter (|>> /.to-list (list.any? n.odd?)))) - #let [value (maybe.assume (/.read idx array))]] - ($_ _.and - (_.test "Shouldn't be able to find a value in an unoccupied cell." - (case (/.read idx (/.delete idx array)) - (#.Some _) false - #.None true)) - (_.test "You should be able to access values put into the array." - (case (/.read idx (/.write idx value array)) - (#.Some value') (n.= value' value) - #.None false)) - (_.test "All cells should be occupied on a full array." - (and (n.= size (/.occupied array)) - (n.= 0 (/.vacant array)))) - (_.test "Filtering mutates the array to remove invalid values." - (exec (/.filter! n.even? array) - (and (n.< size (/.occupied array)) - (n.> 0 (/.vacant array)) - (n.= size (n.+ (/.occupied array) - (/.vacant array)))))) - )) + [amount (:: @ map (n.% (inc size)) random.nat)] + (_.cover [/.copy!] + (let [copy (: (Array Nat) + (/.new size))] + (exec (/.copy! amount 0 the-array 0 copy) + (:: (list.equivalence n.equivalence) = + (list.take amount (/.to-list the-array)) + (/.to-list copy)))))) + (_.cover [/.clone] + (let [clone (/.clone the-array)] + (and (not (is? the-array clone)) + (:: (/.equivalence n.equivalence) = the-array clone)))) + (let [the-array (/.clone the-array) + evens (|> the-array /.to-list (list.filter n.even?)) + odds (|> the-array /.to-list (list.filter n.odd?))] + (_.cover [/.filter!] + (exec (/.filter! n.even? the-array) + (and (n.= (list.size evens) (/.occupancy the-array)) + (n.= (list.size odds) (/.vacancy the-array)) + (|> the-array /.to-list (:: (list.equivalence n.equivalence) = evens)))))) (do @ - [size bounded-size - array (|> (r.array size r.nat) - (r.filter (|>> /.to-list (list.any? n.even?))))] - ($_ _.and - (_.test "Can find values inside arrays." - (|> (/.find n.even? array) - (case> (#.Some _) true - #.None false))) - (_.test "Can find values inside arrays (with access to indices)." - (|> (/.find+ (function (_ idx n) - (and (n.even? n) - (n.< size idx))) - array) - (case> (#.Some _) true - #.None false))))) + [#let [the-array (/.clone the-array) + members (|> the-array /.to-list (set.from-list n.hash))] + default (random.filter (function (_ value) + (not (or (n.even? value) + (set.member? members value)))) + random.nat)] + (_.cover [/.to-list'] + (exec (/.filter! n.even? the-array) + (list.every? (function (_ value) + (or (n.even? value) + (is? default value))) + (/.to-list' default the-array))))) + (_.cover [/.find] + (:: (maybe.equivalence n.equivalence) = + (/.find n.even? the-array) + (list.find n.even? (/.to-list the-array)))) + (_.cover [/.find+] + (case [(/.find n.even? the-array) + (/.find+ (function (_ idx member) + (n.even? member)) + the-array)] + [(#.Some expected) (#.Some [idx actual])] + (case (/.read idx the-array) + (#.Some again) + (and (n.= expected actual) + (n.= actual again)) + + #.None + false) + + [#.None #.None] + true)) + (_.cover [/.every?] + (:: bit.equivalence = + (list.every? n.even? (/.to-list the-array)) + (/.every? n.even? the-array))) + (_.cover [/.any?] + (:: bit.equivalence = + (list.any? n.even? (/.to-list the-array)) + (/.any? n.even? the-array))) )))) diff --git a/stdlib/source/test/lux/macro/code.lux b/stdlib/source/test/lux/macro/code.lux index eec419644..717d4be94 100644 --- a/stdlib/source/test/lux/macro/code.lux +++ b/stdlib/source/test/lux/macro/code.lux @@ -17,6 +17,8 @@ ["n" nat]] [collection ["." list ("#@." functor)]]] + [meta + ["." location]] [tool [compiler [language @@ -69,7 +71,7 @@ syntax.no-aliases (text.size source-code)) start (: Source - [.dummy-location 0 source-code])] + [location.dummy 0 source-code])] (case (parse start) (#.Left [end error]) (#try.Failure error) @@ -132,7 +134,7 @@ (#try.Failure error) false) (:: /.equivalence = - [.dummy-location (<tag> expected)] + [location.dummy (<tag> expected)] (<coverage> expected)))))] [/.bit random.bit #.Bit] @@ -159,7 +161,7 @@ (#try.Failure error) false) (:: /.equivalence = - [.dummy-location (<tag> ["" expected])] + [location.dummy (<tag> ["" expected])] (<coverage> expected))) ))] diff --git a/stdlib/source/test/lux/meta.lux b/stdlib/source/test/lux/meta.lux index 1f5e2c5fa..18bc370c2 100644 --- a/stdlib/source/test/lux/meta.lux +++ b/stdlib/source/test/lux/meta.lux @@ -15,6 +15,8 @@ ["%" format (#+ format)]] [number ["n" nat]]] + [meta + ["." location]] [math ["." random (#+ Random)]]] {1 @@ -46,8 +48,8 @@ #let [expected-lux {#.info {#.target target #.version version #.mode #.Build} - #.source [.dummy-location 0 source-code] - #.location .dummy-location + #.source [location.dummy 0 source-code] + #.location location.dummy #.current-module (#.Some expected-current-module) #.modules (list) #.scopes (list) @@ -93,8 +95,8 @@ #let [expected-lux {#.info {#.target target #.version version #.mode #.Build} - #.source [.dummy-location 0 source-code] - #.location .dummy-location + #.source [location.dummy 0 source-code] + #.location location.dummy #.current-module (#.Some expected-current-module) #.modules (list) #.scopes (list) @@ -167,8 +169,8 @@ #let [expected-lux {#.info {#.target target #.version version #.mode #.Build} - #.source [.dummy-location 0 source-code] - #.location .dummy-location + #.source [location.dummy 0 source-code] + #.location location.dummy #.current-module (#.Some expected-current-module) #.modules (list) #.scopes (list) @@ -245,7 +247,7 @@ #let [expected-lux {#.info {#.target target #.version version #.mode #.Build} - #.source [.dummy-location 0 source-code] + #.source [location.dummy 0 source-code] #.location expected-location #.current-module (#.Some expected-current-module) #.modules (list) diff --git a/stdlib/source/test/lux/target/jvm.lux b/stdlib/source/test/lux/target/jvm.lux index e1c4dbfe3..7df1cdd07 100644 --- a/stdlib/source/test/lux/target/jvm.lux +++ b/stdlib/source/test/lux/target/jvm.lux @@ -229,38 +229,36 @@ (|>> (:coerce java/lang/Double) host.double-to-float) random.frac)) (def: $Float::literal /.float) +(def: valid-float + (Random java/lang/Float) + (random.filter (|>> host.float-to-double (:coerce Frac) f.not-a-number? not) + ..$Float::random)) (def: $Float::primitive (Primitive java/lang/Float) {#unboxed /type.float #boxed ..$Float #wrap ..$Float::wrap - #random ..$Float::random + #random ..valid-float #literal ..$Float::literal}) -(def: valid-float - (Random java/lang/Float) - (random.filter (|>> host.float-to-double (:coerce Frac) f.not-a-number? not) - ..$Float::random)) - (def: $Double (/type.class "java.lang.Double" (list))) (def: $Double::wrap (/.invokestatic ..$Double "valueOf" (/type.method [(list /type.double) ..$Double (list)]))) (def: $Double::random (:coerce (Random java/lang/Double) random.frac)) (def: $Double::literal (-> java/lang/Double (Bytecode Any)) (|>> (:coerce Frac) /.double)) +(def: valid-double + (Random java/lang/Double) + (random.filter (|>> (:coerce Frac) f.not-a-number? not) + ..$Double::random)) (def: $Double::primitive (Primitive java/lang/Double) {#unboxed /type.double #boxed ..$Double #wrap ..$Double::wrap - #random ..$Double::random + #random ..valid-double #literal ..$Double::literal}) -(def: valid-double - (Random java/lang/Double) - (random.filter (|>> (:coerce Frac) f.not-a-number? not) - ..$Double::random)) - (def: $Character (/type.class "java.lang.Character" (list))) (def: $Character::wrap diff --git a/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux b/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux index c6ac62bc5..819f6ccf1 100644 --- a/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux +++ b/stdlib/source/test/lux/tool/compiler/language/lux/syntax.lux @@ -18,7 +18,9 @@ ["." list] ["." dictionary (#+ Dictionary)]]] [macro - ["." code]]] + ["." code]] + [meta + ["." location]]] {1 ["." /]}) @@ -77,7 +79,7 @@ (_.test "Can parse Lux code." (case (let [source-code (%.code sample)] (/.parse "" (dictionary.new text.hash) (text.size source-code) - [.dummy-location 0 source-code])) + [location.dummy 0 source-code])) (#.Left error) false @@ -89,7 +91,7 @@ (let [source-code (format (%.code sample) " " (%.code other)) source-code//size (text.size source-code)] (case (/.parse "" (dictionary.new text.hash) source-code//size - [.dummy-location 0 source-code]) + [location.dummy 0 source-code]) (#.Left error) false @@ -127,7 +129,7 @@ (case (let [source-code (format comment (%.code sample)) source-code//size (text.size source-code)] (/.parse "" (dictionary.new text.hash) source-code//size - [.dummy-location 0 source-code])) + [location.dummy 0 source-code])) (#.Left error) false |