aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib')
-rw-r--r--stdlib/source/lux/control/exception.lux2
-rw-r--r--stdlib/source/lux/control/try.lux1
-rw-r--r--stdlib/source/lux/data/collection/dictionary.lux11
-rw-r--r--stdlib/source/lux/data/collection/row.lux102
-rw-r--r--stdlib/source/lux/data/maybe.lux1
-rw-r--r--stdlib/source/lux/target/jvm/constant/pool.lux4
-rw-r--r--stdlib/source/lux/time/date.lux11
-rw-r--r--stdlib/source/lux/time/instant.lux15
-rw-r--r--stdlib/source/lux/type/check.lux6
-rw-r--r--stdlib/source/lux/type/implicit.lux3
-rw-r--r--stdlib/source/test/lux/data/collection/dictionary.lux19
-rw-r--r--stdlib/source/test/lux/data/collection/row.lux17
12 files changed, 107 insertions, 85 deletions
diff --git a/stdlib/source/lux/control/exception.lux b/stdlib/source/lux/control/exception.lux
index 118b9ed1a..ed200189c 100644
--- a/stdlib/source/lux/control/exception.lux
+++ b/stdlib/source/lux/control/exception.lux
@@ -153,7 +153,7 @@
..separator
error))
-(def: #export (with-stack exception message computation)
+(def: #export (with exception message computation)
(All [e a] (-> (Exception e) e (Try a) (Try a)))
(case computation
(#//.Failure error)
diff --git a/stdlib/source/lux/control/try.lux b/stdlib/source/lux/control/try.lux
index 3b27fd6a3..7202f5c75 100644
--- a/stdlib/source/lux/control/try.lux
+++ b/stdlib/source/lux/control/try.lux
@@ -122,6 +122,7 @@
(macro: #export (default tokens compiler)
{#.doc (doc "Allows you to provide a default value that will be used"
"if a (Try x) value turns out to be #Failure."
+ "Note: the expression for the default value will not be computed if the base computation succeeds."
(= "bar"
(default "foo" (#Success "bar")))
(= "foo"
diff --git a/stdlib/source/lux/data/collection/dictionary.lux b/stdlib/source/lux/data/collection/dictionary.lux
index 195640d66..c4c8efeb1 100644
--- a/stdlib/source/lux/data/collection/dictionary.lux
+++ b/stdlib/source/lux/data/collection/dictionary.lux
@@ -4,6 +4,9 @@
[hash (#+ Hash)]
[equivalence (#+ Equivalence)]
[functor (#+ Functor)]]
+ [control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]]
[data
["." maybe]
["." product]
@@ -569,12 +572,14 @@
#.None #0
(#.Some _) #1))
+(exception: #export key-already-exists)
+
(def: #export (try-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)))
+ (All [k v] (-> k v (Dictionary k v) (Try (Dictionary k v))))
(case (get key dict)
- #.None (put key val dict)
- (#.Some _) dict))
+ #.None (#try.Success (put key val dict))
+ (#.Some _) (exception.throw ..key-already-exists [])))
(def: #export (update key f dict)
{#.doc "Transforms the value located at key (if available), using the given function."}
diff --git a/stdlib/source/lux/data/collection/row.lux b/stdlib/source/lux/data/collection/row.lux
index d73f8bbf5..2b7b555be 100644
--- a/stdlib/source/lux/data/collection/row.lux
+++ b/stdlib/source/lux/data/collection/row.lux
@@ -10,6 +10,8 @@
[fold (#+ Fold)]
[predicate (#+ Predicate)]]
[control
+ ["." try (#+ Try)]
+ ["." exception (#+ exception:)]
["p" parser
["s" code (#+ Parser)]]]
[data
@@ -225,59 +227,71 @@
(set@ #tail (new-tail val)))
)))
+(exception: incorrect-row-structure)
+
+(exception: #export [a] (index-out-of-bounds {row (Row a)} {index Nat})
+ (exception.report ["Size" (:: n.decimal encode (get@ #size row))]
+ ["Index" (:: n.decimal encode index)]))
+
+(exception: base-was-not-found)
+
+(def: #export (within-bounds? row idx)
+ (All [a] (-> (Row a) Nat Bit))
+ (and (n.>= 0 idx)
+ (n.< (get@ #size row) idx)))
+
(def: (base-for idx row)
- (All [a] (-> Index (Row a) (Maybe (Base a))))
- (let [row-size (get@ #size row)]
- (if (and (n.>= 0 idx)
- (n.< row-size idx))
- (if (n.>= (tail-off row-size) idx)
- (#.Some (get@ #tail row))
- (loop [level (get@ #level row)
- hierarchy (get@ #root row)]
- (case [(n.> branching-exponent level)
- (array.read (branch-idx (i64.logic-right-shift level idx)) hierarchy)]
- [#1 (#.Some (#Hierarchy sub))]
- (recur (level-down level) sub)
-
- [#0 (#.Some (#Base base))]
- (#.Some base)
-
- [_ #.None]
- #.None
-
- _
- (error! "Incorrect row structure."))))
- #.None)))
+ (All [a] (-> Index (Row a) (Try (Base a))))
+ (if (within-bounds? row idx)
+ (if (n.>= (tail-off (get@ #size row)) idx)
+ (#try.Success (get@ #tail row))
+ (loop [level (get@ #level row)
+ hierarchy (get@ #root row)]
+ (case [(n.> branching-exponent level)
+ (array.read (branch-idx (i64.logic-right-shift level idx)) hierarchy)]
+ [#1 (#.Some (#Hierarchy sub))]
+ (recur (level-down level) sub)
+
+ [#0 (#.Some (#Base base))]
+ (#try.Success base)
+
+ [_ #.None]
+ (exception.throw ..base-was-not-found [])
+
+ _
+ (exception.throw ..incorrect-row-structure []))))
+ (exception.throw ..index-out-of-bounds [row idx])))
(def: #export (nth idx row)
- (All [a] (-> Nat (Row a) (Maybe a)))
- (do maybe.monad
+ (All [a] (-> Nat (Row a) (Try a)))
+ (do try.monad
[base (base-for idx row)]
- (array.read (branch-idx idx) base)))
+ (case (array.read (branch-idx idx) base)
+ (#.Some value)
+ (#try.Success value)
+
+ #.None
+ (exception.throw ..incorrect-row-structure []))))
(def: #export (put idx val row)
- (All [a] (-> Nat a (Row a) (Row a)))
+ (All [a] (-> Nat a (Row a) (Try (Row a))))
(let [row-size (get@ #size row)]
- (if (and (n.>= 0 idx)
- (n.< row-size idx))
- (if (n.>= (tail-off row-size) idx)
- (update@ #tail (`` (for {(~~ (static @.old))
- (: (-> (Base ($ 0)) (Base ($ 0)))
- (|>> 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))
- row)))
+ (if (within-bounds? row idx)
+ (#try.Success (if (n.>= (tail-off row-size) idx)
+ (update@ #tail (`` (for {(~~ (static @.old))
+ (: (-> (Base ($ 0)) (Base ($ 0)))
+ (|>> 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)))
+ (exception.throw ..index-out-of-bounds [row idx]))))
(def: #export (update idx f row)
- (All [a] (-> Nat (-> a a) (Row a) (Row a)))
- (case (nth idx row)
- (#.Some val)
- (put idx (f val) row)
-
- #.None
- row))
+ (All [a] (-> Nat (-> a a) (Row a) (Try (Row a))))
+ (do try.monad
+ [val (nth idx row)]
+ (put idx (f val) row)))
(def: #export (pop row)
(All [a] (-> (Row a) (Row a)))
diff --git a/stdlib/source/lux/data/maybe.lux b/stdlib/source/lux/data/maybe.lux
index 3a8bc8497..6d425011c 100644
--- a/stdlib/source/lux/data/maybe.lux
+++ b/stdlib/source/lux/data/maybe.lux
@@ -89,6 +89,7 @@
(macro: #export (default tokens state)
{#.doc (doc "Allows you to provide a default value that will be used"
"if a (Maybe x) value turns out to be #.None."
+ "Note: the expression for the default value will not be computed if the base computation succeeds."
(default +20 (#.Some +10))
"=>"
+10
diff --git a/stdlib/source/lux/target/jvm/constant/pool.lux b/stdlib/source/lux/target/jvm/constant/pool.lux
index b0d5c46fa..2e4ff9937 100644
--- a/stdlib/source/lux/target/jvm/constant/pool.lux
+++ b/stdlib/source/lux/target/jvm/constant/pool.lux
@@ -53,7 +53,7 @@
(with-expansions [<try-again> (as-is (recur (.inc idx)))]
(loop [idx 0]
(case (row.nth idx pool)
- (#.Some entry)
+ (#try.Success entry)
(case entry
[index (<tag> reference)]
(if (:: <equivalence> = reference <value>')
@@ -64,7 +64,7 @@
_
<try-again>)
- #.None
+ (#try.Failure _)
(let [new (<tag> <value>')]
(do try.monad
[@new (//unsigned.u2 (//.size new))
diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux
index dfb7baf7e..0e9aa8f79 100644
--- a/stdlib/source/lux/time/date.lux
+++ b/stdlib/source/lux/time/date.lux
@@ -94,21 +94,24 @@
(i.- (i./ +100 year))
(i.+ (i./ +400 year))))
-(def: normal-months
+(def: #export common-months
(Row Nat)
(row 31 28 31
30 31 30
31 31 30
31 30 31))
-(def: leap-year-months
+(def: #export leap-year-months
(Row Nat)
- (row.update [1] inc normal-months))
+ (|> common-months
+ (row.update 1 inc)
+ maybe.assume))
(def: (divisible? factor input)
(-> Int Int Bit)
(|> input (i.% factor) (i.= +0)))
+## https://en.wikipedia.org/wiki/Leap_year#Algorithm
(def: (leap-year? year)
(-> Int Bit)
(and (divisible? +4 year)
@@ -138,7 +141,7 @@
_ (p.fail "Invalid month."))
#let [months (if (leap-year? utc-year)
leap-year-months
- normal-months)
+ common-months)
month-days (|> months
(row.nth (.nat (dec utc-month)))
maybe.assume)]
diff --git a/stdlib/source/lux/time/instant.lux b/stdlib/source/lux/time/instant.lux
index b9d504f1a..a8d308951 100644
--- a/stdlib/source/lux/time/instant.lux
+++ b/stdlib/source/lux/time/instant.lux
@@ -107,17 +107,6 @@
(recur (dec reference) (duration.merge year time-left)))
))))
-(def: normal-months
- (Row Nat)
- (row 31 28 31
- 30 31 30
- 31 31 30
- 31 30 31))
-
-(def: leap-year-months
- (Row Nat)
- (row.update [1] inc normal-months))
-
(def: (find-month months time)
(-> (Row Nat) duration.Duration [Nat duration.Duration])
(if (order.>= duration.order duration.empty time)
@@ -254,8 +243,8 @@
## (and (i.>= +1 utc-month)
## (i.<= +12 utc-month)))
## #let [months (if (leap-year? utc-year)
-## leap-year-months
-## normal-months)
+## date.leap-year-months
+## date.common-months)
## month-days (|> months
## (row.nth (.nat (dec utc-month)))
## maybe.assume)]
diff --git a/stdlib/source/lux/type/check.lux b/stdlib/source/lux/type/check.lux
index 36254634e..b561823ee 100644
--- a/stdlib/source/lux/type/check.lux
+++ b/stdlib/source/lux/type/check.lux
@@ -531,9 +531,9 @@
_
(fail ""))))
-(def: (with-stack exception parameter check)
+(def: (with exception parameter check)
(All [e a] (-> (Exception e) e (Check a) (Check a)))
- (|>> check (exception.with-stack exception parameter)))
+ (|>> check (exception.with exception parameter)))
## TODO: "check'" can be optimized...
(def: #export (check' assumptions expected actual)
@@ -541,7 +541,7 @@
(Checker Type)
(if (is? expected actual)
(check@wrap assumptions)
- (with-stack type-check-failed [expected actual]
+ (with type-check-failed [expected actual]
(case [expected actual]
[(#.Var idE) (#.Var idA)]
(check-vars check' assumptions idE idA)
diff --git a/stdlib/source/lux/type/implicit.lux b/stdlib/source/lux/type/implicit.lux
index 652ff6127..55583e45f 100644
--- a/stdlib/source/lux/type/implicit.lux
+++ b/stdlib/source/lux/type/implicit.lux
@@ -4,6 +4,7 @@
["." monad (#+ Monad do)]
["eq" equivalence]]
[control
+ ["." try]
["p" parser
["s" code (#+ Parser)]]]
[data
@@ -132,7 +133,7 @@
(do macro.monad
[local-batches macro.locals
#let [total-locals (list@fold (function (_ [name type] table)
- (dict.try-put name type table))
+ (try.default table (dict.try-put name type table)))
(: (Dictionary Text Type)
(dict.new text.hash))
(list@join local-batches))]]
diff --git a/stdlib/source/test/lux/data/collection/dictionary.lux b/stdlib/source/test/lux/data/collection/dictionary.lux
index 432909629..55b569a31 100644
--- a/stdlib/source/test/lux/data/collection/dictionary.lux
+++ b/stdlib/source/test/lux/data/collection/dictionary.lux
@@ -9,6 +9,8 @@
[/
["$." equivalence]
["$." functor (#+ Injection)]]}]
+ [control
+ ["." try]]
[data
["." maybe]
[number
@@ -67,15 +69,20 @@
_ #1))
(_.test "Should be able to try-put and then get a value."
- (case (/.get non-key (/.try-put non-key test-val dict))
- (#.Some v) (n.= test-val v)
- _ #1))
+ (case (/.try-put non-key test-val dict)
+ (#try.Success dict)
+ (case (/.get non-key dict)
+ (#.Some v) (n.= test-val v)
+ _ true)
+
+ (#try.Failure _)
+ false))
(_.test "Shouldn't be able to try-put an existing key."
(or (n.= 0 size)
(let [first-key (|> dict /.keys list.head maybe.assume)]
- (case (/.get first-key (/.try-put first-key test-val dict))
- (#.Some v) (not (n.= test-val v))
- _ #1))))
+ (case (/.try-put first-key test-val dict)
+ (#try.Success _) false
+ (#try.Failure _) true))))
(_.test "Removing a key should make it's value inaccessible."
(let [base (/.put non-key test-val dict)]
(and (/.contains? non-key base)
diff --git a/stdlib/source/test/lux/data/collection/row.lux b/stdlib/source/test/lux/data/collection/row.lux
index 80917c7eb..c6f462825 100644
--- a/stdlib/source/test/lux/data/collection/row.lux
+++ b/stdlib/source/test/lux/data/collection/row.lux
@@ -12,8 +12,9 @@
["$." functor (#+ Injection)]
["$." apply]
["$." monad]]}]
+ [control
+ ["." try]]
[data
- ["." maybe]
[number
["n" nat]]
[collection
@@ -54,19 +55,19 @@
(and (n.= (inc size) (/.size (/.add non-member sample)))
(n.= (dec size) (/.size (/.pop sample)))))
(_.test (format (%.name (name-of /.put))
- " " (%.name (name-of /.nth)))
+ " &&& " (%.name (name-of /.nth)))
(|> sample
- (/.put idx non-member)
- (/.nth idx)
- maybe.assume
+ (/.put idx non-member) try.assume
+ (/.nth idx) try.assume
(is? non-member)))
(_.test (%.name (name-of /.update))
(|> sample
- (/.put idx non-member) (/.update idx inc)
- (/.nth idx) maybe.assume
+ (/.put idx non-member) try.assume
+ (/.update idx inc) try.assume
+ (/.nth idx) try.assume
(n.= (inc non-member))))
(_.test (format (%.name (name-of /.to-list))
- " " (%.name (name-of /.from-list)))
+ " &&& " (%.name (name-of /.from-list)))
(|> sample /.to-list /.from-list (/@= sample)))
(_.test (%.name (name-of /.member?))
(and (not (/.member? n.equivalence sample non-member))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 09:44:37 +0000