For comprehensionをCommon Lispで書く

for-comprehension.lisp

(defmacro left (x)
  `(multiple-value-bind (left) ,x left))

(defmacro right (x)
  `(multiple-value-bind (_ right) ,x _ right))

(defmacro return-left (x)
  `(values ,x nil))

(defmacro return-right (x)
  `(values nil ,x))

(assert (eq (left (return-left t)) t))
(assert (eq (right (return-right t)) t))

(defmacro maybe-map (f xform)
      `(multiple-value-bind (left right) ,xform
         ;; left projection
         (if left
             ,f
             right)))

(defmacro flatmap (f xform)
      `(multiple-value-bind (left right) ,xform
         ;; left projection
         (if left
             ,f
             (return-right right))))

(ql:quickload '(:iterate :alexandria))
(use-package :iterate)
(use-package :alexandria)

(defun sanitize-variables-for-for-comprehension (form var)
  (mapcar #'(lambda (x) (etypecase x
                          (list (sanitize-variables-for-for-comprehension x var))
                          (t (if (eq x var)
                                 `(get *for-comprehension-variables* ,(make-keyword (concatenate 'string "%" (string var))))
                                 x))))
          form))

(defmacro for-comprehension (&rest clauses)
  (iter (for c :in clauses)
    (with vars)
    (for code
         :first
         (ecase (second c) ;; '<-' or '='
           (<-
            (progn
              (push (first c) vars)
              `(multiple-value-bind (left right) (flatmap ,(third c) t)
                 (setf (get *for-comprehension-variables* ,(make-keyword (concatenate 'string "%" (string (first c))))) (if left left right))
                 (values left right)))))
         :then
         (if (eq (first c) 'yield)
             `(maybe-map ,(second c) ,code)
             (ecase (second c)
               (<-
                (progn
                  (push (first c) vars)
                  `(multiple-value-bind (left right) (flatmap ,(third c) ,code)
                     (setf (get *for-comprehension-variables* ,(make-keyword (concatenate 'string "%" (string (first c))))) (if left left right))
                     (values left right)))))))
    (finally (return
               `(progn
                  (let ((*for-comprehension-variables* nil)) ;; has property
                    ,(progn
                       (dolist (v vars) (setf code (sanitize-variables-for-for-comprehension code v)))
                       code)))))))

(for-comprehension (a <- (return-left 100))
                   (z <- (return-right "error!"))
                   (b <- (return-left (* a 2)))
                   (c <- (- b a z))
                   (yield c)) ;; => "error!"