[Common Lisp]iterateのドライバを新しく定義する

Common Lisp Advent Calendar 2012で iterate というloopマクロに似たイテレーションライブラリが紹介されていました。 (iterateを使ってloopマクロの呪縛から解き放たれる)

loopマクロと異なり拡張ができるようなので、 OOPのデザインパターンに出てくる(has-next/nextを使った)イテレーターパターンっぽいコードでループできるようにしてみました。

;; イテレーターパターンっぽいインターフェースと実装を定義
;; iterator-next メソッドと has-next-p メソッドを実装したクラスを定義する

(ql:quickload :cl-fad)
(ql:quickload :cl-annot)

(defpackage pattern.iterator
  (:use :cl :cl-annot))

(in-package :pattern.iterator)

(enable-annot-syntax)

@export 
(defgeneric has-next-p (obj))

@export
(defgeneric iterator-next (obj))

@export
(defclass <sequence-iterator> ()
  ((seq :initarg :seq)
   (pos :initarg :pos :initform 0)))

(defmethod has-next-p ((obj <sequence-iterator>))
  (with-slots (seq pos) obj
    (< pos (length seq))))

(defmethod iterator-next ((obj <sequence-iterator>))
  (with-slots (seq pos) obj
    (prog1 (elt seq pos)
      (incf pos))))

@export
(defun sequence-iterator (seq)
  (make-instance '<sequence-iterator> :seq seq))

@export
(defclass <directory-walker> ()
  ((rest :initform nil)))

@export
(defun directory-walker (root)
  (make-instance '<directory-walker> :root root))

(defmethod initialize-instance ((obj <directory-walker>) &key (root "./") &allow-other-keys)
  (call-next-method)
  (push (fad:canonical-pathname root) (slot-value obj 'rest)))

(defmethod has-next-p ((obj <directory-walker>))
  (with-slots (rest) obj
    (not (null rest))))

(defmethod iterator-next ((obj <directory-walker>))
  (with-slots (rest) obj
    (let ((path (pop rest)))
      (when (fad:directory-exists-p path)
        (setf rest (nconc (fad:list-directory path) rest)))
      path)))

;; ドライバの実装
;; iterator-nextとhas-next-pを使ったループをiterateに組み込む。

(ql:quickload "iterate")
(ql:quickload :cl-fad)
(in-package :cl-user)

(defpackage test
  (:use :cl :iterate :pattern.iterator))

(in-package :test)

;; IN-ITERATORというキーワードでイテレータパターン風の処理でループできるように拡張
(defmacro-driver (FOR var IN-ITERATOR obj)
  (let ((gitr (gensym))
        (kwd (if generate 'generate 'for)))
    `(progn
       (with ,gitr = ,obj)
       (while (pattern.iterator:has-next-p ,gitr))
       (,kwd ,var next (pattern.iterator:iterator-next ,gitr)))))

(iter (for x in-iterator (pattern.iterator:sequence-iterator '(1 2)))
      (collect x))
;; => (1 2)

;; 以下のディレクトリ構成で実行
;; ./ (/home/kurohuku/tmp)
;;  |- A.txt
;;  |- B
;;  |  |- B1.txt
;;  |  |- B2.lisp
;;  |- C.txt
(iter (for x IN-ITERATOR (directory-walker "./"))
      (collect x))
;; => (#P"" #P"/home/kurohuku/tmp/A.txt" #P"/home/kurohuku/tmp/B/"
;;     #P"/home/kurohuku/tmp/B/B1.txt" #P"/home/kurohuku/tmp/B/B2.lisp"
;;     #P"/home/kurohuku/tmp/C.txt")

(iter (for x IN-ITERATOR (directory-walker "./"))
      (when (string-equal (pathname-type x) "txt")
        (collect x)))
;; => (#P"/home/kurohuku/tmp/A.txt" #P"/home/kurohuku/tmp/B/B1.txt"
;;     #P"/home/kurohuku/tmp/C.txt")