- Tree parsing.

2 files changed, 82 insertions, 36 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))