Merge pull request #45 from xsc/ys/position-tracking-optional

make position-tracking zipper optional.

Author: Yannick Scherer

src/rewrite_clj/zip/zip.clj renamed to src/rewrite_clj/custom_zipper/core.clj

@@ -12,37 +12,68 @@
 (ns ^{:doc "Functional hierarchical zipper, with navigation, editing,
   and enumeration.  See Huet"
        :author "Rich Hickey"}
-  rewrite-clj.zip.zip
+  rewrite-clj.custom-zipper.core
   (:refer-clojure :exclude (replace remove next))
-  (:require [rewrite-clj.node.protocols :as node]))
+  (:require [rewrite-clj.node.protocols :as node]
+            [clojure.zip :as clj-zip]))
 
-(defn ^:no-doc zipper
-  "Creates a new zipper structure."
+;; ## Switch
+;;
+;; To not force users into using this custom zipper, the following flag
+;; is used to dispatch to `clojure.zip` when set to `false`.
+
+(defn ^:no-doc custom-zipper
   [root]
-  {:node root
+  {::custom? true
+   :node     root
    :position [1 1]
-   :parent nil
-   :left []
-   :right '()})
+   :parent   nil
+   :left     []
+   :right   '()})
+
+(defn ^:no-doc zipper
+  [root]
+  (clj-zip/zipper
+    node/inner?
+    (comp seq node/children)
+    node/replace-children
+    root))
+
+(defn ^:no-doc custom-zipper?
+  [value]
+  (::custom? value))
+
+(defmacro ^:private defn-switchable
+  [sym docstring params & body]
+  (let [placeholders (repeatedly (count params) gensym)]
+    `(defn ~sym
+       ~docstring
+       [~@placeholders]
+       (if (custom-zipper? ~(first placeholders))
+         (let [~@(interleave params placeholders)]
+           ~@body)
+         (~(symbol "clojure.zip" (name sym)) ~@placeholders)))))
+
+;; ## Implementation
 
-(defn node
+(defn-switchable node
   "Returns the node at loc"
   [{:keys [node]}]
   node)
 
-(defn branch?
+(defn-switchable branch?
   "Returns true if the node at loc is a branch"
   [{:keys [node]}]
   (node/inner? node))
 
-(defn children
+(defn-switchable children
   "Returns a seq of the children of node at loc, which must be a branch"
   [{:keys [node] :as loc}]
   (if (branch? loc)
     (seq (node/children node))
     (throw (Exception. "called children on a leaf node"))))
 
-(defn ^:no-doc make-node
+(defn-switchable ^:no-doc make-node
   "Returns a new branch node, given an existing node and new
   children. The loc is only used to supply the constructor."
   [loc node children]
@@ -51,28 +82,35 @@
 (defn position
   "Returns the ones-based [row col] of the start of the current node"
   [loc]
-  (:position loc))
+  (if (custom-zipper? loc)
+    (:position loc)
+    (throw
+      (IllegalStateException.
+        (str
+          "to use the 'position' function, please construct your zipper with "
+           "':track-position?'  set to true.")))))
 
-(defn lefts
+(defn-switchable lefts
   "Returns a seq of the left siblings of this loc"
   [loc]
   (map first (:left loc)))
 
-(defn down
+(defn-switchable down
   "Returns the loc of the leftmost child of the node at this loc, or
   nil if no children"
   [loc]
   (when (branch? loc)
     (let [{:keys [node path] [row col] :position} loc
           [c & cnext :as cs] (children loc)]
       (when cs
-        {:node c
+        {::custom? true
+         :node     c
          :position [row (+ col (node/leader-length node))]
-         :parent loc
-         :left []
-         :right cnext}))))
+         :parent   loc
+         :left     []
+         :right    cnext}))))
 
-(defn up
+(defn-switchable up
   "Returns the loc of the parent of the node at this loc, or nil if at
   the top"
   [loc]
@@ -86,7 +124,7 @@
                                 (concat (map first left) (cons node right))))
         parent))))
 
-(defn root
+(defn-switchable root
   "zips all the way up and returns the root node, reflecting any changes."
   [{:keys [end?] :as loc}]
   (if end?
@@ -96,7 +134,7 @@
         (recur p)
         (node loc)))))
 
-(defn right
+(defn-switchable right
   "Returns the loc of the right sibling of the node at this loc, or nil"
   [loc]
   (let [{:keys [node parent position left] [r & rnext :as right] :right} loc]
@@ -107,14 +145,14 @@
              :right rnext
              :position (node/+extent position (node/extent node))))))
 
-(defn rightmost
+(defn-switchable rightmost
   "Returns the loc of the rightmost sibling of the node at this loc, or self"
   [loc]
   (if-let [next (right loc)]
     (recur next)
     loc))
 
-(defn left
+(defn-switchable left
   "Returns the loc of the left sibling of the node at this loc, or nil"
   [loc]
   (let [{:keys [node parent left right]} loc]
@@ -126,7 +164,7 @@
                :left (pop left)
                :right (cons node right))))))
 
-(defn leftmost
+(defn-switchable leftmost
   "Returns the loc of the leftmost sibling of the node at this loc, or self"
   [loc]
   (let [{:keys [node parent left right]} loc]
@@ -139,7 +177,7 @@
                :right (concat (map first (rest left)) [node] right)))
       loc)))
 
-(defn insert-left
+(defn-switchable insert-left
   "Inserts the item as the left sibling of the node at this loc,
  without moving"
   [loc item]
@@ -151,7 +189,7 @@
              :left (conj left [item position])
              :position (node/+extent position (node/extent item))))))
 
-(defn insert-right
+(defn-switchable insert-right
   "Inserts the item as the right sibling of the node at this loc,
   without moving"
   [loc item]
@@ -162,29 +200,31 @@
              :changed? true
              :right (cons item right)))))
 
-(defn replace
+(defn-switchable replace
   "Replaces the node at this loc, without moving"
   [loc node]
   (assoc loc :changed? true :node node))
 
 (defn edit
   "Replaces the node at this loc with the value of (f node args)"
   [loc f & args]
-  (replace loc (apply f (node loc) args)))
+  (if (custom-zipper? loc)
+    (replace loc (apply f (node loc) args))
+    (apply clj-zip/edit loc f args)))
 
-(defn insert-child
+(defn-switchable insert-child
   "Inserts the item as the leftmost child of the node at this loc,
   without moving"
   [loc item]
   (replace loc (make-node loc (node loc) (cons item (children loc)))))
 
-(defn append-child
+(defn-switchable append-child
   "Inserts the item as the rightmost child of the node at this loc,
   without moving"
   [loc item]
   (replace loc (make-node loc (node loc) (concat (children loc) [item]))))
 
-(defn next
+(defn-switchable next
   "Moves to the next loc in the hierarchy, depth-first. When reaching
   the end, returns a distinguished loc detectable via end?. If already
   at the end, stays there."
@@ -199,7 +239,7 @@
          (or (right (up p)) (recur (up p)))
          (assoc p :end? true))))))
 
-(defn prev
+(defn-switchable prev
   "Moves to the previous loc in the hierarchy, depth-first. If already
   at the root, returns nil."
   [loc]
@@ -210,12 +250,12 @@
         loc))
     (up loc)))
 
-(defn end?
+(defn-switchable end?
   "Returns true if loc represents the end of a depth-first walk"
   [loc]
   (:end? loc))
 
-(defn remove
+(defn-switchable remove
   "Removes the node at loc, returning the loc that would have preceded
   it in a depth-first walk."
   [loc]

src/rewrite_clj/custom_zipper/utils.clj

@@ -0,0 +1,101 @@
+(ns ^:no-doc rewrite-clj.custom-zipper.utils
+  (:require [rewrite-clj.custom-zipper.core :as z]))
+
+;; ## Remove
+
+(defn- update-in-path
+  [[node path :as loc] k f]
+  (let [v (get path k)]
+    (if (seq v)
+      (with-meta
+        [node (assoc path k (f v) :changed? true)]
+        (meta loc))
+      loc)))
+
+(defn remove-right
+  "Remove right sibling of the current node (if there is one)."
+  [loc]
+  (if (z/custom-zipper? loc)
+    (let [{[r & rs] :right} loc]
+      (assoc loc
+             :right rs
+             :changed? true))
+    (update-in-path loc :r next)))
+
+(defn remove-left
+  "Remove left sibling of the current node (if there is one)."
+  [loc]
+  (if (z/custom-zipper? loc)
+    (let [{:keys [left]} loc]
+      (if-let [[_ lpos] (peek left)]
+        (assoc loc
+               :left (pop left)
+               :position lpos
+               :changed? true)
+        loc))
+    (update-in-path loc :l pop)))
+
+(defn remove-right-while
+  "Remove elements to the right of the current zipper location as long as
+   the given predicate matches."
+  [zloc p?]
+  (loop [zloc zloc]
+    (if-let [rloc (z/right zloc)]
+      (if (p? rloc)
+        (recur (remove-right zloc))
+        zloc)
+      zloc)))
+
+(defn remove-left-while
+  "Remove elements to the left of the current zipper location as long as
+   the given predicate matches."
+  [zloc p?]
+  (loop [zloc zloc]
+    (if-let [lloc (z/left zloc)]
+      (if (p? lloc)
+        (recur (remove-left zloc))
+        zloc)
+      zloc)))
+
+;; ## Remove and Move
+
+(defn remove-and-move-left
+  "Remove current node and move left. If current node is at the leftmost
+   location, returns `nil`."
+  [loc]
+  (if (z/custom-zipper? loc)
+    (let [{:keys [position left]} loc]
+      (if (seq left)
+        (let [[lnode lpos] (peek left)]
+          (assoc loc
+                 :changed? true
+                 :node lnode
+                 :position lpos
+                 :left (pop left)))))
+    (let [[_ {:keys [l] :as path}] loc]
+      (if (seq l)
+        (with-meta
+          [(peek l) (-> path
+                        (update-in [:l] pop)
+                        (assoc :changed? true))]
+          (meta loc))))))
+
+(defn remove-and-move-right
+  "Remove current node and move right. If current node is at the rightmost
+   location, returns `nil`."
+  [loc]
+  (if (z/custom-zipper? loc)
+    (let [{:keys [position right]} loc]
+      (if (seq right)
+        (assoc loc
+               :changed? true
+               :node (first right)
+               :right (next right))))
+
+    (let [[_ {:keys [r] :as path}] loc]
+      (if (seq r)
+        (with-meta
+          [(first r) (-> path
+                         (update-in [:r] next)
+                         (assoc :changed? true))]
+          (meta loc))))))

src/rewrite_clj/zip.clj

@@ -17,12 +17,12 @@
             [rewrite-clj
              [parser :as p]
              [node :as node]]
-            [rewrite-clj.zip.zip :as z]))
+            [rewrite-clj.custom-zipper.core :as z]))
 
 ;; ## API Facade
 
 (import-vars
-  [rewrite-clj.zip.zip
+  [rewrite-clj.custom-zipper.core
    node position root]
 
   [rewrite-clj.zip.base
@@ -92,19 +92,19 @@
                :arglists `(quote ~arglists)})]
     `(def ~sym ~base)))
 
-(defbase right* rewrite-clj.zip.zip/right)
-(defbase left* rewrite-clj.zip.zip/left)
-(defbase up* rewrite-clj.zip.zip/up)
-(defbase down* rewrite-clj.zip.zip/down)
-(defbase next* rewrite-clj.zip.zip/next)
-(defbase prev* rewrite-clj.zip.zip/prev)
-(defbase rightmost* rewrite-clj.zip.zip/rightmost)
-(defbase leftmost* rewrite-clj.zip.zip/leftmost)
-(defbase replace* rewrite-clj.zip.zip/replace)
-(defbase edit* rewrite-clj.zip.zip/edit)
-(defbase remove* rewrite-clj.zip.zip/remove)
-(defbase insert-left* rewrite-clj.zip.zip/insert-left)
-(defbase insert-right* rewrite-clj.zip.zip/insert-right)
+(defbase right* rewrite-clj.custom-zipper.core/right)
+(defbase left* rewrite-clj.custom-zipper.core/left)
+(defbase up* rewrite-clj.custom-zipper.core/up)
+(defbase down* rewrite-clj.custom-zipper.core/down)
+(defbase next* rewrite-clj.custom-zipper.core/next)
+(defbase prev* rewrite-clj.custom-zipper.core/prev)
+(defbase rightmost* rewrite-clj.custom-zipper.core/rightmost)
+(defbase leftmost* rewrite-clj.custom-zipper.core/leftmost)
+(defbase replace* rewrite-clj.custom-zipper.core/replace)
+(defbase edit* rewrite-clj.custom-zipper.core/edit)
+(defbase remove* rewrite-clj.custom-zipper.core/remove)
+(defbase insert-left* rewrite-clj.custom-zipper.core/insert-left)
+(defbase insert-right* rewrite-clj.custom-zipper.core/insert-right)
 
 ;; ## DEPRECATED