[Common Lisp] SQL

こんなふうに SQL を書くのはどうだろう？

(defun |#q-quote-reader| (stream char)
  (declare (ignore char))
  (with-output-to-string (out)
    (loop for c = (read-char stream t nil t)
          until (and (char= #\' c)
                     (char/= #\' (peek-char nil stream nil #\a t)))
          do (progn
               (write-char c out)
               (when (char= c #\')
                 (read-char stream))))))

(defun |#q-reader| (stream sub-char numarg)
  (declare (ignore sub-char numarg))
  (let ((*readtable* (copy-readtable nil)))
    (set-macro-character #\, {(declare (ignore _x _y)) '|,|})
    (set-macro-character #\' #'|#q-quote-reader|)
    `(quote ,(read stream t nil t))))

(set-dispatch-macro-character #\# #\q #'|#q-reader|)


#q(select item, price, 'Hello ''World''' as hello from order-header)
;; => (SELECT ITEM YOU::|,| PRICE YOU::|,| "Hello 'World'" AS HELLO FROM ORDER-HEADER)

[Emacs] 使い捨てファイルだけど捨てるのがもったいない

いままで /tmp/a.lisp など tmp ディレクトリに使い捨てファイルを作ってたけど、再起動時にきれいさっぱり消えてしまうのはなんだかもったいない気がしてきた。

それで howm を参考に elisp で現在日時ファイルを作成する関数をつくった。

(defun open-lisp-junk-file ()
  (interactive)
  (let* ((file (expand-file-name
                (format-time-string
                 "%Y/%m/%Y-%m-%d-%H%M%S.lisp" (current-time))
                "~/letter/lisp/junk/"))
         (dir (file-name-directory file)))
    (make-directory dir t)
    (find-file file)))
(global-set-key [(control ?c) (control ?\()] 'open-lisp-junk-file)

[Common Lisp] 開発環境

第17回慢性的CL勉強会@Lingr 8時だョ!全員集合 に参加。お題は 開発環境 で各人に開発環境の発表。他の人が具体的にどんなふうに環境を構築しているかわかって有意義かつ楽しかった。

で、せっかくなので自分のをここにまとめておく。

OS

OS は Debian sid(unstable) x86_64

処理系

処理系は SBCL で Debian パッケージ。Debian の場合は common-lisp-controller も一緒にインストールされ SBCL のコアに組み込まれる。common-lisp-contoller は "/var/cache/common-lisp-controller/[uid]/[処理系]/[ソースのパス]/" ディレクトリにコンパイル済ファイル(fasl)を配置してくれる。複数ユーザ、複数処理系でも大丈夫。

あと hyperspec, sbcl-src パッケージもインストールしている。

ライブラリ

ライブラリの取得は clbuild を使用。./clbuild update --all-projects のコマンド一発で130以上のライブラリが常に最新にできるところが便利。ちなみに clbuild は ./clbuild run climacs とかすると Climacs を起動してくれたりもする。clbuild にあらかじめないライブラリも設定ファイルに記述することで取得対象に含めることができる。

自作ライブラリは ~/letter/lisp/lib の下に配置して ~/.sbclrc から asdf:*central-registry* に登録している。ソース管理は darcs を使用。

~/.sbclrc は↓

;;;;; -*-lisp-*-

;;デバッグ用セッティング
(declaim (optimize (debug 3)))
;;(declaim (optimize (debug 0) (safety 0) (speed 3) (space 0)
;;                   (compilation-speed 0)))

(setf (logical-pathname-translations "ancient")
      `(("**;*.*" "/home/ancient/letter/lisp/**/*.*")))

;; ~/letter/lib 以下の asd を登録する。
(loop for path in (directory (translate-logical-pathname
                                       "ancient:lib;**;*.asd"))
      do (let ((pd (pathname-directory path)))
           (unless (member "_darcs" pd :test #'equal)
             (pushnew (make-pathname :directory pd)
                      asdf:*central-registry*
                      :test #'equal))))

;; clbuild
(pushnew (translate-logical-pathname "ancient:clbuild;systems;")
         asdf:*central-registry*)

(defun climacs ()
  "Climacs を起動する。"
  (load (merge-pathnames ".climacs.lisp" (user-homedir-pathname))))

(defun maxima ()
  "Maxima を起動する。"
  (let ((*default-pathname-defaults*
         (translate-logical-pathname "ancient:clbuild;source;maxima;src;")))
    (load "maxima-build.lisp")
    (maxima-load)
    (cl-user::run)))

;;; If the first user-processable command-line argument is a filename,
;;; disable the debugger, load the file handling shebang-line and quit.
(let ((script (and (second *posix-argv*)
                   (probe-file (second *posix-argv*)))))
  (when script
    ;; Handle shebang-line
    (set-dispatch-macro-character #\# #\!
                                  (lambda (stream char arg)
                                    (declare (ignore char arg))
                                    (read-line stream)))
    ;; Disable debugger
    (setf *invoke-debugger-hook*
          (lambda (condition hook)
            (declare (ignore hook))
            ;; Uncomment to get backtraces on errors
            ;; (sb-debug:backtrace 20)
            (format *error-output* "Error: ~A~%" condition)
            (quit)))
    (load script)
    (quit)))

エディタ

Emacs から SLIME を使用。SBCL のコアファイルはいじらず Emacs から M-x slime として開発。

~/.emacs の SLIME まわりの設定は↓

;;;;;SLIME
(setq common-lisp-hyperspec-root "file:/usr/share/doc/hyperspec/")
(add-path "~/letter/lisp/clbuild/source/slime")
(add-path "~/letter/lisp/clbuild/source/slime/contrib")
(setq slime-backend (expand-file-name
                     "~/letter/lisp/clbuild/source/slime/swank-loader.lisp"))
(setq slime-communication-style :fd-handler)
(setq slime-lisp-implementations
      `((sbcl ("sbcl") :coding-system utf-8-unix)
        (clisp ("clisp") :coding-system utf-8-unix)
        (acl ("/home/ancient/local/opt/acl81_express/alisp")
             :coding-system utf-8-unix)
        (cmucl ("lisp"))))
(require 'slime-autoloads)
(add-hook 'lisp-mode-hook
          (lambda ()
            (cond ((not (featurep 'slime))
                   (require 'slime)
                   (normal-mode)))))
(setq slime-truncate-lines nil)
(setq slime-enable-evaluate-in-emacs t)
(add-hook
 'slime-mode-hook
 (lambda ()
   (global-set-key [(control ?\;)] 'slime-selector)
   (slime-define-key [(control ?c) ?\;] 'slime-insert-balanced-comments)
   (slime-define-key [(control ?u) (control ?c) ?\;]
                     'slime-remove-balanced-comments)
   (slime-define-key [(control ?c) ?\;] 'slime-insert-balanced-comments)
   (slime-define-key "\C-m" 'newline-and-indent)
   (slime-define-key "\C-i" 'slime-indent-and-complete-symbol)))
(add-to-list 'auto-mode-alist '("\\.asd$" . common-lisp-mode))
(eval-after-load "slime"
  '(progn
    (slime-setup '(slime-asdf
                   slime-fancy
                   slime-indentation
                   slime-references
                   slime-tramp
                   slime-banner))
    (setq slime-complete-symbol*-fancy t)
    (setq slime-complete-symbol-function 'slime-fuzzy-complete-symbol)))

キーボード

Kinesis で Dvorak 配列。Qwerty での W と E のキーを ( と ) にしている。括弧を打つのにシフトキーを押さなくていいのは快適♪

で http://bc.tech.coop/blog/060131.html にあるのと同じようにタッチパッドをくっつけて、膝の上においてタイプしてる。

[Common Lisp] Web フレームワークを作る。CLSQL

CLSQL を使えるようにしよう。

S 式で SQL を書けるようにしようかと思ったけどやめた。難しかったから(w SQL 文そのまんま文字列でいいんじゃないかなと。また後で SQL のパラメータの渡し方は考える。今回は検索結果の参照を実装。

SQL 文の select から from の間を CL-PPCRE で強引にパースして CLSQL の do-query マクロに展開するマクロを書いた。

(defmacro with-db (var &body body)
  `(clsql:with-database (,var *connection-spec*
                              :database-type *database-type*
                              :if-exists :new
                              :pool t
                              :make-default nil)
     ,@body))


(let ((scanner (cl-ppcre:create-scanner #"""select\s+(.*?)\s+from\b"""
                                        :case-insensitive-mode t
                                        :single-line-mode t)))
  (defun select-columns (query)
    (let (result)
      (cl-ppcre:register-groups-bind (columns) (scanner (string+ query " from"))
        (cl-ppcre:do-register-groups (column)
            (#"""(\w+)\s*,""" (string+ columns #\,))
          (push (string-upcase column) result)))
      (nreverse result))))

(defmacro loop-query (query &body body)
  `(clsql:do-query (,(mapcar #'intern (select-columns query)) ,query)
     ,@body))

(defmacro! with-query (query &body body)
  `(block ,g!block
      (clsql:do-query (,(mapcar #'intern (select-columns query)) ,query)
        (return-from ,g!block ,@body))))

HUNCHENTOOT のディスパッチャ部分で with-db する。

(defgeneric dispatch ()
  (:method ()
    (ppcre:register-groups-bind (package symbol-name)
        ((format nil "~a([^/]+)/([^?/]+)" *url-prefix*)
         (hunchentoot:request-uri))
      (with-output-to-string (*standard-output*)
        (with-db clsql-sys:*default-database*
          (call-action-by-symbol
           (find-symbol (string-upcase symbol-name)
                        (intern (string-upcase package) :keyword))))))))

使うときはこんな感じになる。

(defaction todo ()
  (default-template (:title "TODO リスト")
    (html (:h1 "TODO リスト")
          (:table :border 1
                  (loop-query "select id as no, content, done from todo"
                    (html (:tr (:td no)
                               (:td content)
                               (:td done))))))))

うぅん、やっぱり S 式で SQL 書かないと何かと不便かなぁ。。。

[Common Lisp] Web フレームワークを作る。テンプレート

Struts の tiles みたいなイメージのテンプレートを実装しようかと思った。でも S 式で HTML 出力するから、わざわざテンプレートの仕組みを実装する必要なんかなくって、マクロを1つ定義してしまえばおしまい。

こんな感じ。

(defmacro default-template ((&key (title "Arc Challenge")) &body body)
  `(html (:head (:title ,title))
        (:body ,@body)))

(defaction arc1 ()
  (default-template ()
    (error-messages)
    (:form :action :arc2
           "foo: " (:input :type :text :name :foo)
           (:input :type :submit))))

上の arc1 を適当にマクロ展開(Slime で C-c C-m)すると次のようになる。すごくべただ。

(PROGN
  (SETF (GET 'ARC1 :ACTION) T)
  (DEFMETHOD ARC1 NIL
    (PROGN
      (PROGN
        (PRINC "<")
        (PRINC "head")
        (PRINC ">")
        (PROGN
          (PROGN
            (PRINC "<")
            (PRINC "title")
            (PRINC ">")
            (PROGN (PRINC (>HTML "Arc Challenge")) (VALUES))
            (PRINC "</")
            (PRINC "title")
            (PRINC ">"))
          (VALUES))
        (PRINC "</")
        (PRINC "head")
        (PRINC ">"))
      (PROGN
        (PRINC "<")
        (PRINC "body")
        (PRINC ">")
        (PROGN (PRINC (>HTML (ERROR-MESSAGES))) (VALUES))
        (PROGN
          (PROGN
            (PRINC "<")
            (PRINC "form")
            (FORMAT T " ~a=\"~a\"" "action" (>HTML :ARC2))
            (PRINC ">")
            (PROGN (PRINC (>HTML "foo: ")) (VALUES))
            (PROGN
              (PROGN
                (PRINC "<")
                (PRINC "input")
                (FORMAT T " ~a=\"~a\"" "type" (>HTML :TEXT))
                (FORMAT T " ~a=\"~a\"" "name" (>HTML :FOO))
                (PRINC "/>"))
              (VALUES))
            (PROGN
              (PROGN
                (PRINC "<")
                (PRINC "input")
                (FORMAT T " ~a=\"~a\"" "type" (>HTML :SUBMIT))
                (PRINC "/>"))
              (VALUES))
            (PRINC "</")
            (PRINC "form")
            (PRINC ">"))
          (VALUES))
        (PRINC "</")
        (PRINC "body")
        (PRINC ">"))
      (VALUES))))

[Common Lisp] Web フレームワークを作る。validation

validation くらいは必要かな。

まず普通の関数だった各ページ表示関数をメソッドにする。そこに :around でバリデーションをかぶせる。

(defmacro defaction (name (&rest options) &body body)
  "options は権限的な何かに使えそう。"
  (declare (ignore options))
  `(progn
     (setf (get ',name :action) t)
     (defmethod ,name ()
       ,@body)))

(defmacro defvalidation (name (&key error-action) &body body)
  `(defmethod ,name :around ()
     (let ((*error-messages*
            (remove nil
                 (list ,@(mapcar (lambda (form)
                                   `(apply ',(second form)
                                           (hunchentoot:parameter
                                            ,(>html (first form)))
                                           (list ,@(cddr form))))
                                 body)))))
       (if *error-messages*
           (,error-action)
           (call-next-method)))))

(defun required (value &key (message "入力してください。"))
  (if (emptyp value)
      message))

というかんじで

(defaction arc1 ()
  (html (:body
         (error-messages)
         (:form :action :arc2
                (:input :type :text :name :foo)
                (:input :type :submit)))))

(defaction arc2 ()
  (html (:body (:a :href (>url :arc3 :foo @foo) "ここよ"))))

(defvalidation arc2 (:error-action arc1)
  (foo required :message "foo を入力してください。"))

(defaction arc3 ()
  (html (:body #"""you said: "#,@foo""""
               (:br)
               (:a :href 'arc1 '戻る))))

うむ、どうかな。。。

[Common Lisp] リストから2つずつ取り出したいとき

zip はないけど loop for on by #'cddr がある。

zip2 はないけど cdddr がある。

もちろん cddddr もある。

(loop for (a b) on '(1 2 3 4 5 6 7) by #'cddr
      collect (list a b))
;; ((1 2) (3 4) (5 6) (7 NIL))

(loop for (a b c) on '(1 2 3 4 5 6 7) by #'cdddr
      collect (list a b c))
;; ((1 2 3) (4 5 6) (7 NIL NIL))

(loop for (a b c d) on '(1 2 3 4 5 6 7) by #'cddddr
      collect (list a b c d))
;; ((1 2 3 4) (5 6 7 NIL))

Common Lisp の loop と C++ の STL どっちが。。。

[Common Lisp] Web フレームワークを作る

Common Lisp で Web フレームワークを作る、ってのに挫折すること幾年月。このごろはシンプルな方向でいってみようと思っている。最終的には実業務で使いたい。そうなると Weblocks も UCW も難しすぎる。ということでシンプルに。

まずは S 式を HTML にするマクロを作った。キーワードシンボルから始まるリストはタグに、@ で始まるシンボルはリクエストパラメータの参照にする。で Arc Challenge を書くと次のようになる。

(defun arc1 ()
  (html (:body
         (:form :action :arc2
                (:input :type :text :name :foo)
                (:input :type :submit)))))

(defun arc2 ()
  (html (:body (:a :href (format nil "arc3?foo=~a" @foo) "ここよ"))))

(defun arc3 ()
  (html (:body "you said: \"" @foo #\")))

まあ、シンプルじゃないかな。href のとこは何とかする必要があるけど。ソースは現状はパッケージ名と関数名を URL とする仕様で、Hunchentoot を使ってる。

(setf hunchentoot:*hunchentoot-default-external-format*
      (flexi-streams:make-external-format :utf-8)
      hunchentoot:*default-content-type* "text/html; charset=utf-8"
      hunchentoot:*show-lisp-errors-p* t
      hunchentoot:*show-lisp-backtraces-p* t)

(defvar *url-prefix* "/you/")
(defvar *port* 8888)

(defgeneric dispatch ()
  (:method ()
    (ppcre:register-groups-bind (package symbol-name)
        ((format nil "~a([^/]+)/([^?/]+)" *url-prefix*)
         (hunchentoot:request-uri))
      (with-output-to-string (*standard-output*)
        (funcall (symbol-function
                  (find-symbol (string-upcase symbol-name)
                               (intern (string-upcase package) :keyword))))))))

(defvar *dispatch*
  (hunchentoot:create-prefix-dispatcher *url-prefix* 'dispatch))

(pushnew *dispatch* hunchentoot:*dispatch-table*)

(defvar *server* (hunchentoot:start-server :port *port*))

;;;; ここからが html マクロ
(defmacro html (&body body)
  (let ((body (replace-html body)))
    `(progn
       ,@(mapcar #'to-html body))))

(defun replace-html (x)
  (cond ((and (symbolp x)
              (char= #\@ (char (symbol-name x) 0)))
         `(hunchentoot:parameter ,(string-downcase (subseq (symbol-name x) 1))))
        ((atom x)
         x)
        (t (cons (replace-html (car x))
                 (replace-html (cdr x))))))

(defun to-html (x)
  (if (or (atom x)
          (not (keywordp (car x))))
      `(princ (>html ,x))
      (to-keyword-html x)))

(defun to-keyword-html (x)
  (let ((tag (>html (car x))))
    (multiple-value-bind (attrs body) (split-attrs-body (cdr x))
      `(progn
         (princ "<")
         (princ ,tag)
         ,@(mapcar
            {`(format t " ~a=\"~a\"" ,(>html (car _)) (>html ,(cdr _)))}
            attrs)
         ,@(if body
               `((princ ">")
                 ,@(mapcar {`(html ,_)} body)
                 (princ "</")
                 (princ ,tag)
                 (princ ">"))
               `((princ "/>")))))))

(defun >html (x)
  (cond ((null x) "")
        ((symbolp x) (string-downcase (symbol-name x)))
        (t (princ-to-string x))))

(defun split-attrs-body (arg)
  (let (attrs body)
    (labels ((f (x)
               (cond ((null x)
                      nil)
                     ((atom x)
                      (setf body (list x)))
                     ((keywordp (car x))
                      (push (cons (car x) (cadr x)) attrs)
                      (f (cddr x)))
                     (t
                      (setf body x)))))
      (f arg)
      (values (reverse attrs) body))))

この html マクロを書くのにずいぶん時間がかかってしまった。もっと美しく書けるような気がする。Common Lisp を使ってるときって、他のどの言語を使っているときよりも、自分の頭の悪さを実感するんだよね。それだからこそ、ささいなコードでも Common Lisp で書くのは楽しい。

[Common Lisp] (directory "**/*.asd")

(directory "**/*.asd") のようにすると zsh みたいにサブディレクトリも検索してくれる。

いままで ~/.sbclrc の中で cl-fad を使って asd ファイルのあるディレクトリをasdf:*central-registry* に登録してたけど directory 関数で十分じゃないかと気づいた。

asdf-install を使わずに各リポジトリから最新を持ってきてたり、Windows でシンボリックリンクが使えなかったりという理由でディレクトリを走査して asdf:*central-registry* に登録している。

で、~/.sbclrc を修正

(setf (logical-pathname-translations "ancient")
      `(("**;*.*" "/home/ancient/letter/lisp/**/*.*")))

;; ~/letter/lib 以下の asd を登録する。
(loop for path in (directory (translate-logical-pathname
                                       "ancient:lib;**;*.asd"))
      do (let ((pd (pathname-directory path)))
           (unless (member "_darcs" pd :test #'equal)
             (pushnew (make-pathname :directory pd)
                      asdf:*central-registry*
                      :test #'equal))))
;;(require :cl-fad)
;;(cl-fad:walk-directory
;; (translate-logical-pathname "ancient:lib;")
;; #'(lambda (path)
;;     (let ((pd (pathname-directory path)))
;;       (unless (member "_darcs" pd :test #'equal)
;;         (pushnew
;;          (make-pathname :directory pd)
;;          asdf:*central-registry*
;;          :test #'equal))))
;; :test #'(lambda (path)
;;           (string-equal "asd" (pathname-type path))))

うん、よりシンプルになった。

Shibuya.lisp

結成おめでとうございます。

Lisp 生誕から50周年。すばらしいですね。