cl-annotを使ってインターフェースと実装を分離する

cl-annotを使ってみるテストその2。

機能を表す名前(関数名)と実際の実装を分離して、利用する際はアノテーションで実装を選択させてみます。

試しにソケットを利用するための関数(インターフェース)を定義し、 2種類のライブラリを用いた実装(バックエンド)を作成して利用するようにしてみました。

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

(defun mk-impl-annot-name (sym)
  (values
   (intern (format nil "~A-IMPL" (symbol-name sym)))))

(defun mk-use-annot-name (sym)
  (values
   (intern (format nil "USE-~A" (symbol-name sym)))))

(defun setup-interface (interface-name clauses)
  (setf (get interface-name
	     :interface-function-clauses)
	clauses))

(defun set-impl-function (interface-name
			  impl-name
			  interface-fn-name
			  impl-fn-name)
  (unless (find impl-name (get interface-name :impl-name-list))
    (push impl-name (get interface-name :impl-name-list)))
  (setf (get impl-name interface-fn-name) impl-fn-name))

(defun get-interface-function-names (interface-name)
  (mapcar
   #'second
   (remove
    nil
    (mapcar
     #'(lambda (clause)
	 (when (and (listp clause) (eq (car clause) :function))
	   clause))
     (get interface-name :interface-function-clauses)))))


(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)))))))

(defun replace-interface-symbol (interface-name impl-name form)
  (let ((names (get-interface-function-names interface-name)))
    (replace-symbol
     #'(lambda (sym)
	 (if (find sym names)
	     (get impl-name sym)
	     sym))
     form)))


(defmacro definterface (name &body clauses)
  (let ((g-form (gensym))
	(g-impl-name (gensym))
	(g-interface-fn-name (gensym))
	(g-defun-name (gensym)))

  `(progn
     (setup-interface ',name ',clauses)

     ;; @[name]-impl impl-name interface-function-name defun-form
     (defannotation ,(mk-impl-annot-name name)
	 (,g-impl-name ,g-interface-fn-name ,g-form) (:arity 3)
       (let ((,g-defun-name (nth 1 ,g-form)))
       `(progn
	  ,,g-form
	  (set-impl-function
	   ',',name ',,g-impl-name ',,g-interface-fn-name ',,g-defun-name)
	  ',,g-defun-name)))

     ;; @use-[name] impl-name form
     (defannotation ,(mk-use-annot-name name)
	 (,g-impl-name ,g-form) (:arity 2)
       (replace-interface-symbol ',name ,g-impl-name ,g-form))


     ,@(remove
	nil
	(mapcar
	 #'(lambda (clause)
	     (when (and (listp clause)
			(eq (car clause) :function))
	       (destructuring-bind
		     (_ fn-name lambda-list)
		   clause
		 `(defun ,fn-name ,lambda-list
		    ,(format nil "interface function `~A'" fn-name)
		    (error "interface function is invoked")))))
	 clauses))
     t)))



;; example


(definterface tcp-socket
  (:function tcp-socket-connect (host port))
  (:function tcp-socket-listen (host port))
  (:function tcp-socket-accept (listen-sock))
  (:function tcp-socket-read-line (sock))
  (:function tcp-socket-write-line (sock line))
  (:function tcp-socket-close (sock)))

(enable-annot-syntax)


;; usocket
(asdf:load-system :usocket)

@tcp-socket-impl usocket tcp-socket-connect
(defun usocket-socket-connect (host port)
  (usocket:socket-connect host port))

@tcp-socket-impl usocket tcp-socket-listen
(defun usocket-socket-listen (host port)
  (usocket:socket-listen host port :reuseaddress t))

@tcp-socket-impl usocket tcp-socket-accept
(defun usocket-socket-accept (listen-sock)
  (usocket:socket-accept listen-sock))

@tcp-socket-impl usocket tcp-socket-read-line
(defun usocket-socket-read-line (sock)
  (read-line (usocket:socket-stream sock)))

@tcp-socket-impl usocket tcp-socket-write-line
(defun usocket-socket-write-line (sock line)
  (write-line line (usocket:socket-stream sock)))

@tcp-socket-impl usocket tcp-socket-close
(defun usocket-socket-clsoe (sock)
  (usocket:socket-close sock))


;; acl-compat.socket
(asdf:load-system :aserve)

@tcp-socket-impl acl-compat tcp-socket-connect
(defun acl-tcp-socket-connect (host port)
  (acl-compat.socket:make-socket :remote-host host :remote-port port))

@tcp-socket-impl acl-compat tcp-socket-listen
(defun acl-tcp-socket-listen (host port)
  (acl-compat.socket:make-socket :remote-host host
				 :local-port port
				 :connect :passive))

@tcp-socket-impl acl-compat tcp-socket-accept
(defun acl-tcp-socket-accept (sock)
  (acl-compat.socket:accept-connection sock))

@tcp-socket-impl acl-compat tcp-socket-read-line
(defun acl-tcp-socket-read-line (sock)
  (read-line sock))

@tcp-socket-impl acl-compat tcp-socket-write-line
(defun acl-tcp-socket-write-line (sock line)
  (write-line line sock))

@tcp-socket-impl acl-compat tcp-socket-close
(defun acl-tcp-socket-close (sock)
  (close sock))


;; test
@use-tcp-socket usocket
(defun run-echo-server-1 (port)
  (let ((listen-sock (tcp-socket-listen "localhost" port)))
    (unwind-protect
	 (progn
	   (format t "listen-sock: port ~A~%" port)
	   (let ((sock (tcp-socket-accept listen-sock)))
	     (unwind-protect
		  (progn
		    (format t "accept-sock~%")
		    (let ((line (tcp-socket-read-line sock)))
		      (format t "recv-line:~A~%" line)
		      (tcp-socket-write-line sock line)
		      (format t "write-line:~A~%" line)))
	       (tcp-socket-close sock))))
      (tcp-socket-close listen-sock))))

@use-tcp-socket acl-compat
(defun run-echo-server-2 (port)
  (let ((listen-sock (tcp-socket-listen "localhost" port)))
    (unwind-protect
	 (progn
	   (format t "listen-sock: port ~A~%" port)
	   (let ((sock (tcp-socket-accept listen-sock)))
	     (unwind-protect
		  (progn
		    (format t "accept-sock~%")
		    (let ((line (tcp-socket-read-line sock)))
		      (format t "recv-line:~A~%" line)
		      (tcp-socket-write-line sock line)
		      (format t "write-line:~A~%" line)))
	       (tcp-socket-close sock))))
      (tcp-socket-close listen-sock))))