From b78b112dd0436d1e9f3813bba76a0af79a265a55 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 15 Apr 2020 00:38:18 -0400 Subject: Some tweaks to how dictionaries and rows work. --- lux-mode/lux-mode.el | 7 +- stdlib/source/lux/control/exception.lux | 2 +- stdlib/source/lux/control/try.lux | 1 + stdlib/source/lux/data/collection/dictionary.lux | 11 ++- stdlib/source/lux/data/collection/row.lux | 102 ++++++++++++--------- stdlib/source/lux/data/maybe.lux | 1 + stdlib/source/lux/target/jvm/constant/pool.lux | 4 +- stdlib/source/lux/time/date.lux | 11 ++- stdlib/source/lux/time/instant.lux | 15 +-- stdlib/source/lux/type/check.lux | 6 +- stdlib/source/lux/type/implicit.lux | 3 +- .../source/test/lux/data/collection/dictionary.lux | 19 ++-- stdlib/source/test/lux/data/collection/row.lux | 17 ++-- 13 files changed, 112 insertions(+), 87 deletions(-) diff --git a/lux-mode/lux-mode.el b/lux-mode/lux-mode.el index 26b31f03c..47a90d0bb 100644 --- a/lux-mode/lux-mode.el +++ b/lux-mode/lux-mode.el @@ -361,6 +361,9 @@ highlighted region)." (font-lock-syntactic-face-function . lux-font-lock-syntactic-face-function)))) +(defvar withRE (concat "with" (altRE "-" "\\'"))) +(defvar definitionRE ":\\'") + (defun lux-indent-function (indent-point state) "When indenting a line within a function call, indent properly. @@ -416,8 +419,8 @@ This function also returns nil meaning don't specify the indentation." ((or (eq method 'defun) (and (null method) (> (length function) 2) - (or (string-match "with-" function) - (string-match ":\\'" function)))) + (or (string-match withRE function) + (string-match definitionRE function)))) (lisp-indent-defform state indent-point)) ((integerp method) (lisp-indent-specform method state 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 [ (as-is (recur (.inc idx)))] (loop [idx 0] (case (row.nth idx pool) - (#.Some entry) + (#try.Success entry) (case entry [index ( reference)] (if (:: = reference ') @@ -64,7 +64,7 @@ _ ) - #.None + (#try.Failure _) (let [new ( ')] (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)) -- cgit v1.2.3