cl-annotを使ってみる

Common Lispでアノテーションを付け加えるライブラリ、cl-annotを使って遊んでみました。

`注釈'でどこまでコードをいじっていいのかよく分からないので、便利なリーダマクロな扱いになってしまっているような。

(asdf:load-system :cl-annot)
(use-package :cl-annot)

(defpackage a
  (:use)
  (:export curry
	   replace-symbol
	   subst-symbol
	   with-dot-slot-value-syntax))


;;;; シンボルの置き換えを行う

(defun replace-symbol (fn sexp &key (test (constantly t)))
  (typecase sexp
    (symbol (if (funcall test sexp) (funcall fn sexp) sexp))
    (atom sexp)
    (t ; cons
     (if (eq 'quote (car sexp))
	 sexp
	 (cons (replace-symbol fn (car sexp) :test test)
	       (if (null (cdr sexp))
		   (cdr sexp)
		   (replace-symbol fn (cdr sexp) :test test)))))))

;; form 中に from のシンボルが現れたら to に置き換える
(defannotation a:subst-symbol (from to form) (:arity 3)
  (replace-symbol
   (lambda (x)
     (declare (ignore x))
     to)
   form
   :test (lambda (x) (eq x from))))

;; すべてのシンボルを関数fnの呼び出し結果で置き換える
(defannotation a:replace-symbol (fn form) (:arity 2)
  (replace-symbol fn form))

;; ドット区切りのシンボルをスロットアクセスに変換する
(defun symbol-separated? (str sym)
  (let ((name (symbol-name sym)))
    (when (>= (length name) (+ 2 (length str)))
      (and (search str (subseq name 1 (1- (length name))) )
	   t))))
(defun separate-symbol (str sym)
  (let* ((name (symbol-name sym))
	 (trimmed-name (subseq name 1 (1- (length name))))
	 (first-char (char name 0))
	 (last-char (char name (1- (length name))))
	 (str-len (length str)))
    (labels
	((recur (tgt acc)
	   (let ((pos (search str tgt)))
	     (if pos
		 (recur (subseq tgt (+ pos str-len))
			(cons
			 (subseq tgt 0 pos)
			 acc))
		 (nreverse
		  (cons
		   (format nil "~A~C" tgt last-char)
		   acc))))))
      (let ((result (recur trimmed-name nil)))
	(mapcar #'intern
		(cons
		 (format nil "~C~A" first-char (car result))
		 (cdr result)))))))

(defun list->slot-value-access-form (lst)
  (if (null (cdr lst))
      (car lst)
      (list->slot-value-access-form
       (cons `(slot-value ,(car lst) ',(cadr lst))
	     (cddr lst)))))

(defannotation a:with-dot-slot-value-syntax (form) (:arity 1)
  (replace-symbol
   (lambda (sym)
     (list->slot-value-access-form
	  (separate-symbol "." sym)))
   form
   :test (lambda (x) (symbol-separated? "." x))))


;;;; カリー化(引数の部分的用)を行える関数クラスを作成する

(asdf:load-system :closer-mop)

(defclass curry-function-class ()
  ((arity :reader arity-of :initarg :arity)
   (function :reader function-of :initarg :function)
   (args :reader args-of :initarg :args))
  (:default-initargs
   :arity (error "require :arity keyword value")
    :function (error "require :function keyword value")
    :args nil)
  (:metaclass closer-mop:funcallable-standard-class))

(defmethod initialize-instance :after ((this curry-function-class) &rest args)
  (declare (ignore args))
  (closer-mop:set-funcallable-instance-function
   this
   #'(lambda (&rest curry-args)
       (with-accessors
	     ((arity arity-of)
	      (fn function-of)
	      (args args-of))
	   this
	 (let ((curry-args-num (length curry-args))
	       (args-num (length args)))
	   (cond
	     ((= (+ curry-args-num args-num) arity)
	      (apply fn (append args curry-args)))
	     ((< (+ curry-args-num args-num))
	      (make-instance 'curry-function-class
			     :arity arity
			     :function fn
			     :args (append args curry-args)))
	     (t (error "too many arguments. arity ~D, but ~D."
		       arity
		       (+ curry-args-num args-num)))))))))

(defmacro define-curry-function (name arity (&rest lambda-list) &body body)
  `(progn
     (setf (symbol-function ',name)
	   (make-instance 'curry-function-class
			  :arity ,arity
			  :function (lambda ,lambda-list ,@body)))))

;; defun を define-curry-function に置き換える
(defannotation a:curry (arity defun-form) (:arity 2)
  (unless (and (listp defun-form)
	       (eq (car defun-form) 'cl:defun))
    (error "annotation `curry' require `defun' form"))
  `(define-curry-function
       ,(nth 1 defun-form) ; name
       ,arity
       ,@ (nthcdr 2 defun-form)))


;;;; example

(enable-annot-syntax)

;;; @subst-symbol
;;; シンボルを置き換える
@a:subst-symbol mvb multiple-value-bind
(defun test-1 (lst)
  (mvb (a b) (values (car lst) (cadr lst))
       (list a b)))
(test-1 (list 2 3))
;; => (2 3)

;;; @replace-symbol
;;; 関数を利用してシンボルを置き換える
(defun a->1 (a) (if (eq a 'a) 1 a))
@a:replace-symbol a->1
(defun test-2 (x)
  (+ x a))
(test-2 3)
;; => 4

;;; @with-dot-slot-value-syntax
;;; ドット区切りのシンボルをslot-valueに展開する
(defclass hoge ()
  ((a :initarg :a)
   (b :initarg :b)))

@a:with-dot-slot-value-syntax
(let ((obj (make-instance 'hoge :a 2 :b 3)))
  (list obj.a obj.b))
;; => (2 3)

;;; @curry
;;; defunをカリー化できる関数を定義するマクロに置き換える
@a:curry 2
(defun hoge (a b)
  (list a b))

(funcall (hoge 2) 3)
;; => (2 3)

funcallable-objectをまともに使えている気がします。たぶん気のせいですが。