pattern-guards.scm

;;; pattern guards a la Haskell
;;; 元ネタ: http://d.hatena.ne.jp/gengar/20130909/1378719785

(use util.match)

(define-syntax do-match*
  (syntax-rules ()
    ((_ binds body ...)
     (%do-match* #f binds body ...))))

(define-syntax %do-match*
  (syntax-rules ()
    ((_ cont () body ...)
     (let () body ...))
    ((_ #f ((pat expr) rest ...) body ...)
     (match expr
       (pat
        (=> cont)
        (%do-match* cont (rest ...) body ...))
       (_ #f)))
    ((_ cont ((pat expr) rest ...) body ...)
     (match expr
       (pat
        (%do-match* cont (rest ...) body ...))
       (_ (cont))))))

(define (add-assoc alist x y)
  (or (do-match* (((_ . m) (assoc x alist))
                  ((_ . n) (assoc y alist)))
        (+ m n))
      0))

(print (add-assoc '((1 . 2)
                    (3 . 4))
                  1 3))