- Tree parsing.

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])