refactor iterator to be simpler

4 files changed, 98 insertions, 215 deletions

diff --git a/generic-iterator.scm b/generic-iterator.scm
index c38c346..080f276 100644
--- a/generic-iterator.scm
+++ b/generic-iterator.scm
@@ -13,29 +13,21 @@
  | limitations under the License.
  |#
 
-(define-record-type <iterator-implementation>
-  (make-iterator-implementation start end
-                                start? end?
-                                advance
-                                ref
-                                to-index from-index
-                                comparator)
-  iterator-implementation?
-  (start get-start)
-  (end get-end)
+(define-record-type <iterator>
+  (make-iterator start? end?
+                 advance
+                 ref
+                 to-index
+                 comparison
+                 private)
+  iterator?
   (start? get-start-predicate)
   (end? get-end-predicate)
   (advance get-advance)
   (ref get-ref)
   (to-index get-to-index-procedure)
-  (from-index get-from-index-procedure)
-  (comparator get-comparator))
-
-(define-record-type <iterator>
-  (make-iterator implementation data)
-  iterator?
-  (implementation get-implementation)
-  (data get-data))
+  (comparison get-comparison-procedure)
+  (private iterator-get-private))
 
 ;;; Define a function that invokes a field of the iterator on the data
 ;;; object inside the iterator and any other arguments supplied to the
@@ -44,44 +36,10 @@
   (syntax-rules ()
     ((define-invoker name field-accessor emsg args ...)
      (define (name iterator args ...)
-       (let ((proc (field-accessor (get-implementation iterator))))
+       (let ((proc (field-accessor iterator)))
          (if (not proc)
              (error emsg iterator)
-             (proc (get-data iterator) args ...)))))))
-
-;;; Define a constructor (something that makes an iterator from something
-;;; that is not an iterator).
-;;; 
-;;; The constructor can take as arguments either
-;;; 
-;;; 1) The implementation and any data objects necessary to make the
-;;;    iterator, or
-;;; 2) The iterator and any objects necessary to make the iterator, where
-;;;    the data in the iterator is the first such object.
-;;; 
-;;; This is implemented as a macro to catch arity issues.
-(define-syntax define-constructor-for-iterator-or-implementation
-  (syntax-rules ()
-    ((_ name field emsg args ...)
-     (define name
-       (case-lambda
-         ((iterator args ...)
-          (name (get-implementation iterator)
-                (get-data iterator)
-                args ...))
-         ((implementation data args ...)
-          (let ((constructor (field implementation)))
-            (if (not constructor)
-                (error emsg implementation data args ...)
-                (constructor data args ...)))))))))
-
-(define-constructor-for-iterator-or-implementation iterator-at-start
-  get-start
-  "no start constructor")
-
-(define-constructor-for-iterator-or-implementation iterator-at-end
-  get-end
-  "no end")
+             (proc args ...)))))))
 
 (define-invoke-field-of-iterator iterator-at-start?
   get-start-predicate
@@ -103,32 +61,16 @@
   get-to-index-procedure
   "no procedure to convert iterator->index")
 
-(define-constructor-for-iterator-or-implementation index->iterator
-  get-from-index-procedure
-  "no procedure to convert index->iterator"
-  index)
-
-;;; Create a procedure that calls COMPARISON on all (ITER1 . ITER-REST).
-;;; COMPARATOR-TYPE? is a predicate against the comparator, and if the
-;;; comparator fails the predicate an error message with string EMSG
-;;; will thrown.
-(define (generate-comparison comparison comparator-type? emsg)
-  (lambda (iter1 . iter-rest)
-    (let ((comparator (get-comparator (get-implementation iter1))))
-      (if (not (comparator-type? comparator))
-          (apply error emsg iter1 iter-rest)
-          (apply comparison comparator
-                 (map get-data (cons iter1 iter-rest)))))))
-
-(define iterator=?
-  (generate-comparison =? comparator? "no comparator"))
-
-(define iterator<?
-  (generate-comparison <? comparator-ordered? "no ordered comparator"))
-(define iterator>?
-  (generate-comparison >? comparator-ordered? "no ordered comparator"))
+(define-syntax define-comparison
+  (syntax-rules ()
+    ((_ name comparison-function)
+     (define (name itr1 . itr-rest)
+       ((get-comparison-procedure itr1)
+        comparison-function
+        itr-rest)))))
 
-(define iterator<=?
-  (generate-comparison <=? comparator-ordered? "no ordered comparator"))
-(define iterator>=?
-  (generate-comparison >=? comparator-ordered? "no ordered comparator"))
+(define-comparison iterator=? =?)
+(define-comparison iterator<=? <=?)
+(define-comparison iterator>=? >=?)
+(define-comparison iterator<? <?)
+(define-comparison iterator>? >?)
diff --git a/mcgoron.iterator.base.sld b/mcgoron.iterator.base.sld
index 22fd3c4..3c7fe84 100644
--- a/mcgoron.iterator.base.sld
+++ b/mcgoron.iterator.base.sld
@@ -15,15 +15,12 @@
 
 (define-library (mcgoron iterator base)
   (import (scheme base) (scheme write) (scheme case-lambda) (srfi 128))
-  (export make-iterator-implementation iterator-implementation?
-          make-iterator iterator?
-          get-implementation get-data
-          iterator-at-start iterator-at-end
+  (export make-iterator iterator?
           iterator-at-start? iterator-at-end?
           iterator-advance
           iterator-ref
           iterator->index
-          index->iterator
+          iterator-get-private
           iterator=? iterator<? iterator>? iterator<=? iterator>=?)
   (include "generic-iterator.scm"))
 
diff --git a/mcgoron.iterator.string.sld b/mcgoron.iterator.string.sld
index a72b9d0..d024e47 100644
--- a/mcgoron.iterator.string.sld
+++ b/mcgoron.iterator.string.sld
@@ -14,10 +14,10 @@
  |#
 
 (define-library (mcgoron iterator string)
-  (import (scheme base) (mcgoron iterator base)
-          (scheme case-lambda)
-          (srfi 130) (srfi 128) (srfi 26))
-  (export string-iterator-implementation
+  (import (scheme base)
+          (srfi 130) (srfi 128) (srfi 26)
+          (mcgoron iterator base))
+  (export cursor->iterator
           string-iterator-start
           string-iterator-end
           string-index->iterator)
diff --git a/string-iterator.scm b/string-iterator.scm
index 8589bdf..6a7730a 100644
--- a/string-iterator.scm
+++ b/string-iterator.scm
@@ -14,40 +14,16 @@
  |#
 
 (define-record-type <fat-cursor>
-  (make-fat-cursor str srfi-130-cursor)
+  (raw-fat-cursor str cursor)
   fat-cursor?
   (str get-str)
-  (srfi-130-cursor get-srfi-130-cursor))
+  (cursor get-cursor))
 
-(define-syntax lambda-fat-cursor
-  (syntax-rules ()
-    ((lambda-fat-cursor (str cursor rest ...) body ...)
-     (lambda (fat-cursor rest ...)
-       (let ((str (get-str fat-cursor))
-             (cursor (get-srfi-130-cursor fat-cursor)))
-         body ...)))))
-
-(define (recursively-compare predicate?)
-  (letrec ((cmp
-            (case-lambda
-              ((_) #t)
-              ((fc1 fc2)
-               (and (eq? (get-str fc1) (get-str fc2))
-                    (predicate? (get-srfi-130-cursor fc1)
-                                (get-srfi-130-cursor fc2))))
-              ((fc1 fc2 . fc-rest)
-               (and (cmp fc1 fc2)
-                    (apply cmp fc2 fc-rest))))))
-    cmp))
-
-(define fat-cursor=? (recursively-compare string-cursor=?))
-(define fat-cursor<? (recursively-compare string-cursor<?))
-
-(define fat-cursor-comparator
+(define string-cursor-comparator
   (make-comparator
-   fat-cursor?
-   fat-cursor=?
-   fat-cursor<?
+   string-cursor?
+   string-cursor=?
+   string-cursor<?
    #f))
 
 (define (string-cursor-valid-movement? str cursor spaces)
@@ -62,99 +38,67 @@
          (string-cursor-diff str cursor (string-cursor-end str))))
     (else #t)))
 
-(define string-iterator-implementation
-  (letrec* ((make-string-iterator
-             (lambda (str cursor)
-               (make-iterator impl
-                              (make-fat-cursor str cursor))))
-            (start
-             (lambda (object)
-               (cond
-                 ((string? object)
-                  (make-string-iterator object
-                                        (string-cursor-start object)))
-                 ((fat-cursor? object)
-                  (make-string-iterator (get-str object)
-                                        (string-cursor-start
-                                         (get-str object))))
-                 (else (error "invalid object for start" object)))))
-            (end
-             (lambda (object)
-               (cond
-                 ((string? object)
-                  (make-string-iterator object
-                                        (string-cursor-end object)))
-                 ((fat-cursor? object)
-                  (make-string-iterator (get-str object)
-                                        (string-cursor-end
-                                         (get-str object))))
-                 (else (error "invalid object for end" object)))))
-            (start?
-             (lambda-fat-cursor (str cursor)
-               (string-cursor=? cursor (string-cursor-start str))))
-            (end?
-             (lambda-fat-cursor (str cursor)
-               (string-cursor=? cursor (string-cursor-end str))))
-            (advance
-             (lambda-fat-cursor (str cursor spaces)
-               (cond
-                 ((not (string-cursor-valid-movement? str cursor spaces))
-                  #f)
-                 ((negative? spaces)
-                  (make-string-iterator str
-                                        (string-cursor-back str
-                                                            cursor
-                                                            (- spaces))))
-                 (else
-                  (make-string-iterator str
-                                        (string-cursor-forward str
-                                                               cursor
-                                                               spaces))))))
-            (ref
-             (lambda (fat-cursor)
-               (if (end? fat-cursor)
-                   (error "cannot ref one past the end of the sequence"
-                          fat-cursor)
-                   (string-ref/cursor (get-str fat-cursor)
-                                      (get-srfi-130-cursor fat-cursor)))))
-            (to-index
-             (lambda-fat-cursor (str cursor)
-               (string-cursor->index str cursor)))
-            (from-index%string
-             (lambda (str index)
-               (make-string-iterator str
-                                     (string-index->cursor str index))))
-            (from-index
-             (lambda (obj index)
-               (cond
-                 ((string? obj) (from-index%string obj index))
-                 ((fat-cursor? obj)
-                  (from-index%string (get-str obj) index))
-                 (else (error "invalid object for from-index" obj index)))))
-            (impl
-             (make-iterator-implementation
-              start end
-              start? end?
-              advance ref
-              to-index from-index
-              fat-cursor-comparator)))
-    impl))
+(define (cursor->iterator str cursor)
+  (make-iterator
+   (lambda ()
+     (string-cursor=? cursor (string-cursor-start str)))
+   (lambda ()
+     (string-cursor=? cursor (string-cursor-end str)))
+   (lambda (spaces)
+     (cond
+       ((not (string-cursor-valid-movement? str cursor spaces))
+        #f)
+       ((negative? spaces)
+        (cursor->iterator str
+                          (string-cursor-back str
+                                              cursor
+                                              (- spaces))))
+       (else
+        (cursor->iterator str
+                          (string-cursor-forward str
+                                                 cursor
+                                                 spaces)))))
+   (lambda ()
+     (string-ref/cursor str cursor))
+   (lambda ()
+     (string-cursor->index str cursor))
+   (lambda (predicate? other-iterators)
+     (let loop ((rest other-iterators)
+                (current cursor))
+       (if (null? rest)
+           #t
+           (let* ((next-private (iterator-get-private (car rest)))
+                  (next-str (get-str next-private))
+                  (next (get-cursor next-private)))
+             ;; All comparisons are to STR, the string in the first
+             ;; iterator, since they all must be equal.
+             (if (or (not (eq? next-str str))
+                     (not (predicate? string-cursor-comparator
+                                      current
+                                      next)))
+                 #f
+                 (loop (cdr rest) next))))))
+   (raw-fat-cursor str cursor)))
+
+(define-syntax define-for-iterator-or-string
+  (syntax-rules ()
+    ((_ (name str args ...) body ...)
+     (define (name object args ...)
+       (define (internal str args ...)
+         body ...)
+       (cond
+         ((string? object) (internal object args ...))
+         ((iterator? object) (internal (get-str (iterator-get-private
+                                                 object))
+                                       args ...))
+         (else (error "invalid type of object" object)))))))
+
+(define-for-iterator-or-string (string-iterator-start str)
+  (cursor->iterator str (string-cursor-start str)))
+
+(define-for-iterator-or-string (string-iterator-end str)
+  (cursor->iterator str (string-cursor-end str)))
 
-(define (constructor-for-iterator-or-string procedure)
-  (lambda (object . rest)
-    (cond
-      ((string? object) (apply procedure
-                               string-iterator-implementation
-                               object
-                               rest))
-      ((iterator? object) (apply procedure
-                                 object
-                                 rest))
-      (else (error "invalid object" object rest)))))
+(define-for-iterator-or-string (string-index->iterator str idx)
+  (cursor->iterator str (string-index->cursor str idx)))
 
-(define string-iterator-start
-  (constructor-for-iterator-or-string iterator-at-start))
-(define string-iterator-end
-  (constructor-for-iterator-or-string iterator-at-end))
-(define string-index->iterator
-  (constructor-for-iterator-or-string index->iterator))