aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/coll/tree/parser.lux50
-rw-r--r--stdlib/source/lux/data/coll/tree/zipper.lux68
-rw-r--r--stdlib/test/test/lux/data/coll/tree/zipper.lux73
-rw-r--r--stdlib/test/tests.lux11
4 files changed, 124 insertions, 78 deletions
diff --git a/stdlib/source/lux/data/coll/tree/parser.lux b/stdlib/source/lux/data/coll/tree/parser.lux
new file mode 100644
index 000000000..203f55b16
--- /dev/null
+++ b/stdlib/source/lux/data/coll/tree/parser.lux
@@ -0,0 +1,50 @@
+(;module:
+ lux
+ (lux (control ["p" parser]
+ ["ex" exception #+ exception:])
+ (data ["R" result]))
+ (.. ["T" rose]
+ ["Z" zipper]))
+
+(type: #export (Parser t a)
+ (p;Parser (Z;Zipper t) a))
+
+(def: #export (run-zipper zipper parser)
+ (All [t a] (-> (Z;Zipper t) (Parser t a) (R;Result a)))
+ (case (p;run zipper parser)
+ (#R;Success [zipper output])
+ (#R;Success output)
+
+ (#R;Error error)
+ (#R;Error error)))
+
+(def: #export (run tree parser)
+ (All [t a] (-> (T;Tree t) (Parser t a) (R;Result a)))
+ (run-zipper (Z;zip tree) parser))
+
+(def: #export value
+ (All [t] (Parser t t))
+ (function [zipper]
+ (#R;Success [zipper (Z;value zipper)])))
+
+(exception: #export Cannot-Move-Further)
+
+(do-template [<name> <direction>]
+ [(def: #export <name>
+ (All [t] (Parser t []))
+ (function [zipper]
+ (let [next (<direction> zipper)]
+ (if (is zipper next)
+ (ex;throw Cannot-Move-Further "")
+ (#R;Success [next []])))))]
+
+ [up Z;up]
+ [down Z;down]
+ [left Z;left]
+ [right Z;right]
+ [root Z;root]
+ [rightmost Z;rightmost]
+ [leftmost Z;leftmost]
+ [next Z;next]
+ [prev Z;prev]
+ )
diff --git a/stdlib/source/lux/data/coll/tree/zipper.lux b/stdlib/source/lux/data/coll/tree/zipper.lux
index b217a0677..6b39178bc 100644
--- a/stdlib/source/lux/data/coll/tree/zipper.lux
+++ b/stdlib/source/lux/data/coll/tree/zipper.lux
@@ -21,24 +21,24 @@
#node (Tree a)})
## [Values]
-(def: #export (from-tree tree)
+(def: #export (zip tree)
(All [a] (-> (Tree a) (Zipper a)))
{#parent #;None
#lefts stack;empty
#rights stack;empty
#node tree})
-(def: #export (to-tree zipper)
+(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) (get@ #rose;value)))
+ (|> zipper (get@ [#node #rose;value])))
(def: #export (children zipper)
(All [a] (-> (Zipper a) (List (Tree a))))
- (|> zipper (get@ #node) (get@ #rose;children)))
+ (|> zipper (get@ [#node #rose;children])))
(def: #export (branch? zipper)
(All [a] (-> (Zipper a) Bool))
@@ -48,9 +48,19 @@
(All [a] (-> (Zipper a) Bool))
(|> zipper branch? not))
-(def: #export (parent zipper)
- (All [a] (-> (Zipper a) (Maybe (Zipper a))))
- (get@ #parent zipper))
+(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)))
@@ -108,6 +118,20 @@
[left leftmost #lefts #rights]
)
+(do-template [<name> <h-side> <h-op> <v-op>]
+ [(def: #export (<name> zipper)
+ (All [a] (-> (Zipper a) (Zipper a)))
+ (case (get@ <h-side> zipper)
+ #;Nil
+ (<v-op> zipper)
+
+ _
+ (<h-op> 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))
@@ -169,34 +193,6 @@
[insert-right #rights]
)
-(do-template [<name> <h-side> <h-op> <v-op>]
- [(def: #export (<name> zipper)
- (All [a] (-> (Zipper a) (Zipper a)))
- (case (get@ <h-side> zipper)
- #;Nil
- (<v-op> zipper)
-
- _
- (<h-op> zipper)))]
-
- [next #rights right down]
- [prev #lefts left up]
- )
-
-(def: #export (end? zipper)
- (All [a] (-> (Zipper a) Bool))
- (and (list;empty? (get@ #rights zipper))
- (list;empty? (children zipper))))
-
-(def: #export (root? zipper)
- (All [a] (-> (Zipper a) Bool))
- (case (get@ #parent zipper)
- #;None
- true
-
- _
- false))
-
(struct: #export _ (Functor Zipper)
(def: (map f fa)
{#parent (|> fa (get@ #parent) (M/map (map f)))
@@ -211,7 +207,7 @@
## (def: (split wa)
## (let [tree-splitter (function tree-splitter [tree]
-## {#rose;value (from-tree tree)
+## {#rose;value (zip tree)
## #rose;children (L/map tree-splitter
## (get@ #rose;children tree))})]
## {#parent (|> wa (get@ #parent) (M/map split))
diff --git a/stdlib/test/test/lux/data/coll/tree/zipper.lux b/stdlib/test/test/lux/data/coll/tree/zipper.lux
index b7936b140..9154459b9 100644
--- a/stdlib/test/test/lux/data/coll/tree/zipper.lux
+++ b/stdlib/test/test/lux/data/coll/tree/zipper.lux
@@ -3,23 +3,23 @@
(lux [io]
(control [monad #+ do Monad]
pipe)
- (data (coll [list "List/" Fold<List> Functor<List>]
+ (data (coll [list "L/" Fold<List> Functor<List>]
(tree ["&" zipper]
[rose]))
- [text "Text/" Monoid<Text>]
+ [text]
text/format
[number])
- ["R" math/random])
+ ["r" math/random])
lux/test)
(def: gen-tree
- (R;Random (rose;Tree Nat))
- (R;rec (function [gen-tree]
- (do R;Monad<Random>
+ (r;Random (rose;Tree Nat))
+ (r;rec (function [gen-tree]
+ (do r;Monad<Random>
## Each branch can have, at most, 1 child.
- [size (|> R;nat (:: @ map (n.% +2)))]
- (R;seq R;nat
- (R;list size gen-tree))))))
+ [size (|> r;nat (:: @ map (n.% +2)))]
+ (r;seq r;nat
+ (r;list size gen-tree))))))
(def: (to-end zipper)
(All [a] (-> (&;Zipper a) (&;Zipper a)))
@@ -28,35 +28,34 @@
zipper
(recur (&;next zipper)))))
-(context: "Zippers"
+(context: "Zippers."
[sample gen-tree
- new-val R;nat
- pre-val R;nat
- post-val R;nat
- #let [(^open "Tree/") (rose;Eq<Tree> number;Eq<Nat>)
- (^open "List/") (list;Eq<List> number;Eq<Nat>)]]
+ new-val r;nat
+ pre-val r;nat
+ post-val r;nat
+ #let [(^open "tree/") (rose;Eq<Tree> number;Eq<Nat>)
+ (^open "L/") (list;Eq<List> number;Eq<Nat>)]]
($_ seq
(test "Trees can be converted to/from zippers."
(|> sample
- &;from-tree &;to-tree
- (Tree/= sample)))
+ &;zip &;unzip
+ (tree/= sample)))
(test "Creating a zipper gives you a root node."
- (|> sample &;from-tree &;root?))
+ (|> sample &;zip &;root?))
(test "Can move down inside branches. Can move up from lower nodes."
- (let [zipper (&;from-tree sample)]
+ (let [zipper (&;zip sample)]
(if (&;branch? zipper)
(let [child (|> zipper &;down)]
- (and (not (Tree/= sample (&;to-tree child)))
- (|> child &;parent (default (undefined)) (is zipper))
+ (and (not (tree/= sample (&;unzip child)))
(|> child &;up (is zipper) not)
(|> child &;root (is zipper) not)))
(and (&;leaf? zipper)
(|> zipper (&;prepend-child new-val) &;branch?)))))
(test "Can prepend and append children."
- (let [zipper (&;from-tree sample)]
+ (let [zipper (&;zip sample)]
(if (&;branch? zipper)
(let [mid-val (|> zipper &;down &;value)
zipper (|> zipper
@@ -71,7 +70,7 @@
true)))
(test "Can insert children around a node (unless it's root)."
- (let [zipper (&;from-tree sample)]
+ (let [zipper (&;zip sample)]
(if (&;branch? zipper)
(let [mid-val (|> zipper &;down &;value)
zipper (|> zipper
@@ -93,26 +92,26 @@
#;None true))))))
(test "Can set and update the value of a node."
- (|> sample &;from-tree (&;set new-val) &;value (n.= new-val)))
+ (|> sample &;zip (&;set new-val) &;value (n.= new-val)))
(test "Zipper traversal follows the outline of the tree depth-first."
- (List/= (rose;flatten sample)
- (loop [zipper (&;from-tree sample)]
- (if (&;end? zipper)
- (list (&;value zipper))
- (#;Cons (&;value zipper)
- (recur (&;next zipper)))))))
+ (L/= (rose;flatten sample)
+ (loop [zipper (&;zip sample)]
+ (if (&;end? zipper)
+ (list (&;value zipper))
+ (#;Cons (&;value zipper)
+ (recur (&;next zipper)))))))
(test "Backwards zipper traversal yield reverse tree flatten."
- (List/= (list;reverse (rose;flatten sample))
- (loop [zipper (to-end (&;from-tree sample))]
- (if (&;root? zipper)
- (list (&;value zipper))
- (#;Cons (&;value zipper)
- (recur (&;prev zipper)))))))
+ (L/= (list;reverse (rose;flatten sample))
+ (loop [zipper (to-end (&;zip sample))]
+ (if (&;root? zipper)
+ (list (&;value zipper))
+ (#;Cons (&;value zipper)
+ (recur (&;prev zipper)))))))
(test "Can remove nodes (except root nodes)."
- (let [zipper (&;from-tree sample)]
+ (let [zipper (&;zip sample)]
(if (&;branch? zipper)
(and (|> zipper &;down &;root? not)
(|> zipper &;down &;remove (case> #;None false
diff --git a/stdlib/test/tests.lux b/stdlib/test/tests.lux
index 598c488fd..62683aea5 100644
--- a/stdlib/test/tests.lux
+++ b/stdlib/test/tests.lux
@@ -52,10 +52,10 @@
["_;" seq]
["_;" priority-queue]
["_;" stream]
- (tree ["_;" rose]
- ["_;" zipper])
- (ordered ["_o;" dict]
- ["_o;" set]))
+ (tree ["tree_;" rose]
+ ["tree_;" zipper])
+ (ordered ["ordered_;" dict]
+ ["ordered_;" set]))
(text ["_;" format]
["_;" lexer]
["_;" regex]))
@@ -85,7 +85,8 @@
[tainted]
(format [context]
[html]
- [css]))
+ [css])
+ (coll (tree ["tree_;" parser])))
[macro]
(math [random])
(type [unit])
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 07:48:54 +0000