2011年5月12日木曜日

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をまともに使えている気がします。たぶん気のせいですが。

0 件のコメント:

コメントを投稿