Emacs 24から標準でついてくるとどこかで耳にしたpackage.elを眺めました。
簡単そうだったので、ためしにgithubにレポジトリを作ってみました。
2011年12月23日金曜日
2011年11月16日水曜日
MochiWebで学ぶErlang(mochiweb_http)
はじめに
MochiWebはErlangで書かれた軽量HTTPサーバーです。
Erlang使いを志すならMochiWebのコードを読むと良いらしいので読んでみます。
MochiWebはMITライセンスのようです。
HTTPサーバーの起動はmochiweb_httpモジュールのstart関数により行います。
なので、mochiweb_httpから順に流れを追ってみます。
mochiweb_http.erlは単体テストを入れて250行程度。
ファイルの先頭部分
参考
- http://www.erlang.org/doc/reference_manual/modules.html
- http://www.erlang.org/doc/reference_manual/macros.html
- http://d.hatena.ne.jp/m-hiyama/20070922/1190432025
%% @author Bob Ippolito <bob@mochimedia.com>
%% @copyright 2007 Mochi Media, Inc.
%% @doc HTTP server.
Erlangの一行コメントは「%」です。
「@xxx」はErlang/OTP付属のドキュメントジェネレータであるEDocのタグです。
-module(mochiweb_http).
-author('bob@mochimedia.com').
-export([start/1, start_link/1, stop/0, stop/1]).
-export([loop/2]).
-export([after_response/2, reentry/1]).
-export([parse_range_request/1, range_skip_length/2]).
-define(REQUEST_RECV_TIMEOUT, 300000). %% timeout waiting for request line
-define(HEADERS_RECV_TIMEOUT, 30000). %% timeout waiting for headers
-define(MAX_HEADERS, 1000).
-define(DEFAULTS, [{name, ?MODULE},
{port, 8888}]).
シングルクオートで囲まれた値は文字列ではなくアトムです。
「-」から始まるものにはModule Attribute、Preprocessor、レコード定義、
定義済みマクロ(?FILEおよび?LINE)の変更、型や関数の仕様記述があります。
Module Attributeはユーザが自由に定義でき、以下の関数でそのモジュールに定義された
値の一覧を取得できます。
Module:module_info(attributes)
定義済みのModule Attributeその他は以下のとおり。
- module : モジュール名定義
- export : 関数のエクスポート
- import : 関数のインポート
- compile : コンパイラオプション
- vsn : モジュールのバージョン
- behaviour : ビヘイビアのコールバックモジュールであると宣言
- record : レコード定義
- include : ファイルインクルード。主にヘッダに対して使う
- include_lib : includeとほぼ同じ。探索パスが異なる
- define : マクロ定義
- undef : マクロを未定義状態にする
- ifdef : マクロが定義されている場合のマクロ制御フロー
- ifndef : マクロが未定義である場合のマクロ制御フロー
- else : ifdef/ifndefとあわせて利用する。ifdef/ifndefでない場合
- endif : ifdef/ifndef/elseの終端
- file : 定義済みマクロ?FILEおよび?LINEの値を変更する
- spec : 関数の仕様。EDocなど以外に影響はない(たぶん)
- type : 型の仕様。EDocなど以外に影響はない(たぶん)
マクロの定義と使用法は以下のとおり。
%% 定義
-define(Const, Replacement).
%%% 引数を文字列に展開するには「??Arg」を使う
-define(TEST(Exp), io:format("~s : ~p~n", [??Exp, Exp])).
%% 使用
?Const.
?TEST(1 + 2).
%% => "1 + 2 : 3"と表示される
定義済みマクロは以下。
- ?MODULE : モジュール名(アトム)
- ?MODULE_STRING : モジュール名(文字列)
- ?FILE : ファイル名
- ?LINE : 行番号
- ?MACHINE : 'BEAM'
include対象のパスに環境変数を利用することができます。
%% $PROJECT_ROOTはos:getenv("PROJ_ROOT")の戻り値に展開される
-include("$PROJ_ROOT/path/lib.hrl").
mochiweb_httpの関数
関数の処理や初めて知ったor気になった点など。
- parse_options
- start関数に渡されたオプションをパースして返す
- オプションは属性リスト(proplists)
- mochilists:set_defaults関数で未定義オプションにデフォルト値を設定(ポート番号)
- 戻り値のloopオプション = {?MODULE, loop, [もともと指定されていたloop用関数]}
- stop
- mochiweb_socket_server:stopを呼び出す
- start
- mochiweb_socket_server:startを呼び出す
- サーバーの処理はmochiweb_socket_serverに記述されている
- loop
- mochiweb_socket:setoptsでソケットに{packet, http}をセットしてrequestを呼ぶ
- {packet, http}とするとパケット受信時にHTTPヘッダをパースしたものを取得できる
- mochiweb_socketモジュールはSSL対応か否かによりgen_tcpとsslを使い分けるラッパー
- request
- HTTPリクエストの先頭行を読み込む
- ソケットのオプション{active, once}を指定すると1度だけパケットをメッセージとして受信する
- headers
- HTTPリクエストのヘッダを受信する
- {packet, httph}としているとヘッダの終端まで読み込んだ場合、http_eohを受信する
- call_body
- 引数として渡された関数を呼び出す
- handle_invalid_request
- 400 Bad Requestを返す
- Req:respond(...)は、parameterized moduleを利用した表記
- new_request
- リクエスト(parameterized module)を作成する
- after_response
- mochiweb_requestのshould_closeを呼び出し、ソケットをクローズするかどうかを決定する
- HTTPのバージョンやKeep-Aliveによって判別するっぽい
- erlang:garbage_collect()によりガーベージコレクションを明示的に実行できる
- parse_range_request
- Rangeヘッダの値をパースする
- 文字列はリストなので ++ で連結できる
- 文字列を区切ってリストにするにはstring:tokensを使う
- 文字列->整数の変換はBIFのlist_to_integerで行える
- range_skip_length
- 部分レスポンスの範囲を返す
- Sizeは対象とするレスポンス(ファイル)のサイズだと思う
Misc
モジュール定義時に、以下のように宣言するとParameterized Moduleになるらしいです。
-module(module_name, [Vars]).
オブジェクト指向チックな書き方ができるようになるようですが、当然変数への代入は1度きりのまま。
mochiwebではプロセス辞書(erlang:put,erlang:getなど)を利用してリクエストの状態を保存しているようです。
mochiweb_requestを読む際にもう少し調べます。
テスト
ifdefにより、TESTマクロが定義されている場合のみ、EUnitを利用したテスト関数が
定義されます。
EUnitでは関数名末尾が「_test」で終わるものは試験ケースとして扱われるようです。
eunit.hrlをインクルードすると、アサーション用マクロが読み込まれます。
TODO
- EDocについて調べる
- EUnitについて調べる
- mochiweb_requestおよびmochiweb_responseを読む
- mochiweb_socket_serverを読む
2011年11月10日木曜日
Erlang+TCP
Erlangã§TCPサーãƒã‚’書ã„ã¦ã¿ã¾ã™ã€‚
ãƒãƒ¼ã‚«ãƒ«ãƒ—ãƒã‚シを作ã£ã¦ã¿ãŸã„ã§ã™ã€‚
-module(serv).
-compile(export_all).
-compile([start/1]).
-define(TCP_OPTIONS, [binary, {packet, raw}, {active, false}, {reuseaddr, true}]).
start (Port) ->
spawn(?MODULE, init, [Port, self()]).
init(Port, Pid) ->
{ok, Listen} = gen_tcp:listen(Port, ?TCP_OPTIONS),
accept_loop(Listen, Pid).
accept_loop(Listen, Pid) ->
case gen_tcp:accept(Listen) of
{ok, Accept} ->
spawn(?MODULE, accept_handler, [Accept, Pid]),
accept_loop(Listen, Pid)
end.
accept_handler(Accept, Pid) ->
inet:setopts(Accept, [{packet, http}]),
{ok, {http_request, Method, URL, {Major, Minor}}} = gen_tcp:recv(Accept, 0),
Headers = recv_request_headers(Accept),
inet:setopts(Accept, [{packet, raw}]),
Body =
case lists:keyfind('Content-Length', 1, Headers) of
{'Content-Length', Len} when is_integer(Len) ->
gen_tcp:recv(Accept, Len);
_ -> <<>>
end,
io:format("~p, ~p, ~p/~p~n~p~n~p~n",
[Method, URL, Major, Minor, Headers, Body]),
case URL of
{abs_path, Path} ->
Txt = "<html><body><a>not found</a></body></html>",
gen_tcp:send(Accept, "HTTP/1.1 404 not-found\r\nContent-Length: "),
gen_tcp:send(Accept, integer_to_list(length(Txt))),
gen_tcp:send(Accept, "\r\n\r\n"),
gen_tcp:send(Accept, Txt);
{absoluteUrl, Protocol, Host, Port, Path} ->
Txt = "<html><body><a>not found</a></body></html>",
gen_tcp:send(Accept, "HTTP/1.1 404 not-found\r\nContent-Length: "),
gen_tcp:send(Accept, integer_to_list(length(Txt))),
gen_tcp:send(Accept, "\r\n\r\n"),
gen_tcp:send(Accept, Txt)
end,
case lists:keyfind('Connection', 1, Headers) of
{'Connection', "keep-alive"} ->
accept_handler(Accept, Pid);
_ ->
gen_tcp:close(Accept)
end.
recv_request_headers(Accept) ->
recv_request_headers(Accept, []).
recv_request_headers(Accept, Hs) ->
case gen_tcp:recv(Accept, 0) of
{ok, http_eoh} -> % end of header
Hs;
{ok, {http_header, _, Key, _, Val}} ->
recv_request_headers(Accept, [{Key,Val} | Hs])
end.
2011年10月27日木曜日
自力で末尾再帰をループにしてみた ver C
コールスタックについて理解するためにスタックをいじって遊んでみました。
C言語で末尾再帰関数を呼び出す際にスタックを使い果たさないようにしてみます。もっとも、gccだと-O2を付けてコンパイルすると最適化がかかって勝手にループになるみたいではありますが。
関数呼び出し後のスタックに積まれている値とesp,ebpの値は以下のようになるらしいです。
...
ebp + 8 : 第1引数
ebp + 4 : リターンアドレス
ebp + 0 : 呼び出し元でのebpの値
ebp - 4 : ローカル変数
...
ebp - x : ローカル変数
このへん <- ESP
バッファオーバーフローやoff-by-oneエラーではreturn時に復帰するリターンアドレス(returnする際に移るアドレスを変える)や呼び出し元のebp(呼び出し元関数がreturnする際に移るアドレスを変える)を書き換えることでexploitしたりするようです。
#include <stdio.h>
void recur(void (*fn)(unsigned int n), unsigned int n){
unsigned int ebp = 0;
unsigned int old_ebp = 0;
__asm__("movl %%ebp, %0" : "=r" (ebp) :);
// 現在のebpが指す値が、呼び出し元関数のebpである
old_ebp = *((unsigned int *)ebp);
// fn の引き数
*((unsigned int *)(old_ebp + 8)) = n;
// fnからESPの退避などの分をずらしたアドレス
*((unsigned int *)(ebp + 4)) = (unsigned int)fn + 9;
}
void dec(unsigned int n){
char buf[256];
if(n == 0){
printf("done\n");
}else{
printf("n = %d\n", n);
recur(dec, n - 1);
}
return;
}
void dec2(unsigned int n){
char buf[256];
if(n == 0){
printf("done\n");
}else{
printf("n = %d\n", n);
dec2(n - 1);
}
return;
}
int main(void){
// decは正常終了する
dec(100000);
p// dec2はスタックを使い果たしてSEGVる
// dec2(100000);
return 0;
}
recur関数はリターンアドレスを書き換えることでreturnするときに第一引数に渡した関数へ制御を移します。
fn + 9としているのはebpのpushとespの減算分の処理を飛ばすためです。
// objdump の結果(一部)この定数はローカル変数の領域のサイズによって変わると思われるので、汎用性は無いです。
08048480 <dec>:
8048480: 55 push %ebp
8048481: 89 e5 mov %esp,%ebp
8048483: 81 ec 28 01 00 00 sub $0x128,%esp
2011年10月20日木曜日
Emacsのヘルプ
Emacsに助けを求めるためのコマンド。
apropos,find-functionあたりはよく使ってます。
情報を表示する
describe-ほげほげコマンド。色々な情報を表示してくれます。
たくさんありそうなのでEmacsLispを書くときに使いそうなものを列挙。
- describe-bindings キーシーケンスのコマンド(Anythingが入ってると一覧表示してくれる) - describe-function 指定した関数の情報 - describe-variable 指定した変数の情報 - describe-char カーソル位置にある文字の情報(文字コードなど)
定義場所を探す
Emacs Lispの関数や変数が定義された場所を探すコマンド。
- find-function 指定した関数の定義された場所に飛ぶ - find-function-at-point カーソル位置にある関数の定義された場所に飛ぶ - find-function-other-frame find-functionの結果を別フレームに表示 - find-funciton-on-key 入力したキーシーケンスが表すコマンドの定義された場所に飛ぶ - find-variable 指定した変数の定義された場所に飛ぶ - find-variable-at-point カーソル位置にある変数の定義された場所に飛ぶ - find-variable-other-frame find-variableの結果を別フレームに表示
質問する
apropos系コマンド。
前置引数を指定すると動作を変えられるらしい。変数apropos-do-allをnil以外にセットしていると前置引数を指定したのと同じ動作になるそうです。
- apropos - apropos-command - apropos-documentation - apropos-library - apropos-variable - apropos-value
apropos-valueの検索対象は評価"後"の変数の値。
キーシーケンス
コマンドがどのキーシーケンスに割り当てられているかを探すコマンド。
- where-is
2011年10月19日水曜日
同じ単語(シンボル)をハイライト表示する(マイナーモード版)
最近LispといえばEmacsLispしか触っていません。
この間書いたカーソル位置の単語と同じ単語をハイライト表示する機能をマイナーモードにしてみました。
コードはgithubに置きました。
(require 'hl-same-symbol-mode)
;; emacs-lisp-modeで有効にしたい場合
(add-hook 'emacs-lisp-mode-hook 'hl-same-symbol-mode)
;; ハイライトするまでのアイドル時間を変更する
(setf hl-same-symbol-delay 0.10)
;; ハイライトの表示を変更する
(setf hl-same-symbol-face '何か)
2011年10月13日木曜日
同じ単語(シンボル)をハイライト表示する
EmacsのOverlayを使ってみるテスト。カーソル位置にある単語(symbol-at-pointで取得できるもの)と同じ単語をハイライト表示させます。
show-paren-modeみたいにタイマーを使ったほうが良いかも。
(eval-when-compile (require 'cl))
(defvar *hl-same-symbol::text* "")
(defvar *hl-same-symbol::list* nil)
(defvar hl-same-symbol-face 'highlight)
(defun hl-same-symbol::highlight (text)
(setf *hl-same-symbol::text* text)
;; (highlight-regexp (regexp-quote text) hl-same-symbol-face)
(let ((len (length text)))
(save-excursion
(dolist (win (window-list))
(with-current-buffer (window-buffer win)
(goto-char (window-start win))
(while (let ((pos (search-forward text nil t)))
(and pos (< (- pos len) (window-end win))))
(hl-same-symbol::highlight-internal text len)))))))
(defun hl-same-symbol::highlight-internal (text len)
(let ((sym (symbol-at-point)))
(when (and sym (equal (symbol-name sym) text))
(let ((overlay (make-overlay (- (point) len) (point))))
(overlay-put overlay 'face hl-same-symbol-face)
(push overlay *hl-same-symbol::list*)
overlay))))
(defun hl-same-symbol::unhighlight ()
;; (unhighlight-regexp (regexp-quote *hl-same-symbol::text*))
(mapcar 'delete-overlay *hl-same-symbol::list*)
(setf *hl-same-symbol::list* nil))
(defun hl-same-symbol::post-command-hook ()
(let ((sym (symbol-at-point)))
(cond
((and sym (equal (symbol-name sym) *hl-same-symbol::text*))
'nothing-to-do)
(sym
(hl-same-symbol::unhighlight)
(hl-same-symbol::highlight (symbol-name sym)))
(t
(hl-same-symbol::unhighlight)))
t))
(defun hl-same-symbol ()
(interactive)
(if (find 'hl-samey-symbol::post-command-hook post-command-hook)
(remove-hook 'post-command-hook 'hl-same-symbol::post-command-hook)
(add-hook 'post-command-hook 'hl-same-symbol::post-command-hook)))
2011年10月5日水曜日
popup.elで右クリックのようななにか
popup.elでコマンドメニューを表示させてみます。
(require 'popup)
(defvar *rclick-command-tree*)
(setf *rclick-command-tree*
`(
[org-capture "org-capture" (lambda () (featurep 'org))]
("Erlang"
[:major-mode erlang-mode]
[run-erlang "run-erlang-shell"])
("Org"
[:feature org]
[org-sparse-tree "org-sparse-tree"]
[org-schedule "org-schedule"]
[org-deadline "org-deadline"]
[org-time-stamp "org-time-stamp"])
("VC"
;; vc-annotate (C-x v g) 注釈を表示
[vc-annotate "vc-annotate"]
;; vc-diff (C-x v =) 差分を表示
[vc-diff "vc-diff"]
;; vc-dir (C-x v d) 状態を表示
[vc-dir "vc-dir"]
;; vc-print-log (C-x v l) 履歴を表示
[vc-print-log "vc-print-log"]
;; vc-register (C-x v i) ファイルを追加
[vc-register "vc-register"]
;; vc-revert (C-x v u) 修正を破棄
[vc-revert "vc-revert"]
;; vc-update (C-x v +) 後進
[vc-update "vc-update"]
;; vc-next-action (C-x v v) コミット
[vc-next-action "vc-next-action(commit)"]
;; vc-revision-other-window (C-x v ~) 過去のバージョンを表示
[vc-revision-other-window "vc-revision-other-window"])))
(defun rclick-tree-normalize (tree)
(mapcar
(lambda (s)
(typecase s
(cons (rclick-tree-normalize s))
(symbol [s (format "%s" s)])
(string s)
(vector (if (>= (length s) 2) s
[(aref s 0) (format "%s" (aref s 1))]))
(t (error "invalid tree"))))
tree))
(defun rclick-collect-test (tree)
(remove-if-not
(lambda (c)
(and (typep c 'vector)
(keywordp (aref c 0))))
tree))
(defun rclick-tree-collect (tree)
(let ((tests (rclick-collect-test tree)))
(when (every 'rclick-test tests)
(let ((result nil))
(dolist (c tree)
(cond
((and (typep c 'vector)
(not (keywordp (aref c 0))))
(when (or (<= (length c) 2)
(funcall (aref c 2)))
(push c result)))
((listp c)
(let ((children (rclick-tree-collect c)))
(when children
(push children result))))
((stringp c)
(push c result))
(t 'nothing-to-do)))
(nreverse result)))))
(defun rclick-tree->cascade-menu (tree)
(mapcar
(lambda (c)
(typecase c
(vector (format "%s" (aref c 1)))
(cons (rclick-tree->cascade-menu c))
(t c)))
tree))
(defun rclick-find (desc tree)
(dolist (c tree)
(when (and (typep c 'vector)
(string-equal desc (aref c 1)))
(return c))
(when (listp c)
(let ((tmp (rclick-find desc c)))
(when tmp
(return tmp))))))
(defun rclick-test (vec)
(apply (get (aref vec 0) 'rclick-test-function)
(cdr (coerce vec 'list))))
(defmacro define-rclick-test (key args &rest body)
`(setf (get ',key 'rclick-test-function) (lambda ,args ,@body)))
(define-rclick-test :major-mode (mode)
(eq mode major-mode))
(define-rclick-test :feature (feature)
(featurep feature))
(defun rclick-menu ()
(interactive)
(let ((tree (rclick-tree-collect
(rclick-tree-normalize *rclick-command-tree*))))
(let ((result (popup-cascade-menu (rclick-tree->cascade-menu tree))))
(when result
(let ((c (rclick-find result tree)))
(when c
(call-interactively (aref c 0))))))))
おまけ。コマンドのキーバインドを文字列で取得する方法。
(defun one-of-bindings (command)
(key-description (car (where-is-internal command))))
2011年9月18日日曜日
popup.elで遊んでみる
overlayを使ってポップアップメニューを表示するpopup.elを使ってみました。
rclk:rclkコマンドを実行すると、*rckl:clauses*に設定されている条件に
したがってメニューを表示します。
右クリックをイメージしています。
;; (require 'popup)
(defvar *rclk:clauses* nil)
(defvar *rclk:format-function* nil)
(defun rclk:rclk ()
(interactive)
(rclk:popup-menu*
(rclk:select *rclk:clauses*)))
(defun rclk:clause-name (clause)
(if (<= (length clause) 2)
(second clause)
(third clause)))
(defun rclk:select (clauses)
(let ((result nil))
(dolist (c clauses)
(let ((strs (funcall (first c))))
(unless (listp strs)
(setf strs (list strs)))
(dolist (s strs)
(push (list s (second c) (third c)) result))))
(nreverse result)))
(defun rclk:popup-menu* (clauses)
(when clauses
(let ((popup-clauses (mapcar 'rclk:clause->popup clauses)))
(let ((result (popup-menu* (mapcar 'first popup-clauses))))
(when result
(let ((selected (find result popup-clauses
:key 'first
:test 'string-equal)))
(funcall (third selected) (second selected))
t))))))
(defun rclk:clause->popup (clause)
(let ((str (substring-no-properties
(funcall *rclk:format-function* clause))))
(cons str clause)))
;;; test
(defun symbol-at-point-as-str ()
(when (symbol-at-point)
(symbol-name (symbol-at-point))))
(defun find-function-from-str (str)
(find-function (intern str)))
;; clause = (文字列のリストを返す関数 選択時に呼び出される関数 表示項目名)
(setf *rclk:clauses*
`((word-at-point apropos "apropos")
(symbol-at-point-as-str find-function-from-str "find-function")))
(setf *rclk:format-function*
(lambda (clause)
(format "<%s> %s"
(rclk:clause-name clause)
(first clause))))
2011年8月29日月曜日
Windows Power Shell で Word の表に書き込む
大量のWordやExcelファイルを一括で処理する方法が知りたいです。
とりあえず、Power Shell で頑張るための第一歩。
既存のファイルを開いて、Word中の表の(1,1)に文字列を挿入します。
$w = New-Object -ComObject "Word.Application"
$d = $w.Documents.open("filename")
$d.Tables.Item(1).Cell(1,1).Range.Text = "hoge"
1日の間に更新されたファイルをカレントディレクトリ以下から探します。
$d = (date).AddDays(-1)
Get-ChildItem -Recurse | Where-Object { $_.LastWriteTime -gt $d }
2011年8月14日日曜日
F#でキーボードフック
C#でできるらしいので、F#でもできるだろうということでやってみました。
.Net上の言語でキーボードフックしてるプログラムを載せてる色々なWebページを参考にしました。
F#のコンソールにコピペしてhook_start関数を実行すると,PrintScreenをフックするようになります。
open System
open System.Diagnostics
open System.Runtime.InteropServices
[<Literal>]
let WH_KEYBOARD_LL = 13
[<Literal>]
let HC_ACTION = 0
[<Literal>]
let WM_KEYDOWN = 0x0100
[<Literal>]
let WM_KEYUP = 0x0101
[<Literal>]
let WM_SYSKEYDOWN = 0x0104
[<Literal>]
let WM_SYSKEYUP = 0x0105
[<Literal>]
let VK_SNAPSHOT = 0x2Cu
[<StructLayout(LayoutKind.Sequential)>]
type KBDLLHOOKSTRUCT =
val vkCode : uint32
val scanCode : uint32
val flags : uint32
val time : uint32
val dwExtraInfo : uint32
type LowLevelKeyboardProc = delegate of int * nativeint * KBDLLHOOKSTRUCT ->\
nativeint
[<DllImport("kernel32.dll")>]
extern uint32 GetCurrentThreadId()
[<DllImport("kernel32.dll", SetLastError = true)>]
extern nativeint GetModuleHandle(string lpModuleName)
[<DllImport("user32.dll", SetLastError = true)>]
extern bool UnhookWindowsHookEx(nativeint hhk)
[<DllImport("user32.dll", SetLastError = true)>]
extern nativeint SetWindowsHookEx(int idhook, LowLevelKeyboardProc proc, native\
int hMod, uint32 threadId)
[<DllImport("user32.dll", SetLastError = true)>]
extern nativeint CallNextHookEx(nativeint hHook, int nCode, nativeint wParam, K\
BDLLHOOKSTRUCT lParam)
let mutable s_hook = 0n
let SetHook (proc : LowLevelKeyboardProc) =
use curProc = Process.GetCurrentProcess()
use curMod = curProc.MainModule
s_hook <- SetWindowsHookEx(WH_KEYBOARD_LL, proc, GetModuleHandle(curMod.\
ModuleName), 0u)
if s_hook = 0n then false else true
let UnSetHook () =
if s_hook <> 0n then
if UnhookWindowsHookEx(s_hook) then
s_hook <- 0n
true
else
false
else
false
let MyHookProc (nCode : int) (wParam : nativeint) (lParam : KBDLLHOOKSTRUCT) =
if nCode = HC_ACTION then
match (int wParam, lParam.vkCode) with
| (WM_KEYDOWN, VK_SNAPSHOT) -> printf "Print Screen\n"; 1\
n
| (_, _) -> CallNextHookEx(s_hook, nCode, wParam, lParam)
else
CallNextHookEx(s_hook, nCode, wParam, lParam)
let hook_start() = SetHook(new LowLevelKeyboardProc(MyHookProc))
2011年7月3日日曜日
Emacsのコマンド2
1つのキーストロークに複数コマンドを割り当ててみる試みその2。
変数の真偽に応じて2種類のうちどちらかの動作をするコマンドを作成しました。
(require 'cl)
(defvar *toggle-command-flag* nil)
(defun toggle-command-flag ()
(interactive)
(setf *toggle-command-flag*
(not *toggle-command-flag*)))
(defun parse-body (body)
(let (fst scd rest)
(setf fst (car body)
scd (cadr body)
rest (cddr body))
(unless (stringp fst)
(when scd (push scd rest))
(setf scd fst)
(setf fst nil))
(unless (and (listp scd)
(eq (car scd) 'interactive))
(when scd (push scd rest))
(setf scd nil))
(list fst scd rest)))
(defun parse-toggle-command-form (form)
(when (or (<= (length form) 0)
(<= 3 (length form)))
(error "invalid toggle-command form"))
(list (first form) (second form)))
(defmacro define-toggle-command (name args &rest body)
(destructuring-bind (doc interactive form)
(parse-body body)
(destructuring-bind (then else)
(parse-toggle-command-form form)
`(defun ,name ,args
,@(when doc (list doc))
,@(when interactive (list interactive))
(if *toggle-command-flag*
,then
,else)))))
;; コマンド定義
(define-toggle-command toggle-ctrl-l-cmd ()
(interactive)
(call-interactively 'goto-line)
(call-interactively 'recenter-top-bottom))
(global-set-key (kbd "C-l") 'toggle-ctrl-l-cmd)
toggle-ctrl-l-cmdは、変数が偽の時はrecenter-top-bottomコマンドを、真の時は goto-lineコマンドを呼び出します。
2011年6月30日木曜日
Emacsのコマンド
貴重なC-a,C-eといったキーが行頭/行末移動しかしないのはもったいない、ということで、 sequential-command.elなどのように、多少空気を読んで動作を変えるようなコマンドを定義します。
(defmacro as-this-command (cmd &rest args)
`(progn
(setq this-command ',cmd)
(call-interactively ',cmd ,@args)))
(defun buffer-empty? ()
(= (point-min) (point-max)))
(defun initialize-buffer ()
(interactive)
(call-interactively 'auto-insert))
(defun at-line-start? ()
(= (point) (line-beginning-position)))
(defun at-line-end? ()
(= (point) (line-end-position)))
(defun at-word? ()
(case (char-after (point))
((9 10 13 32 59
?( ?) ?[ ?] ?{ ?}) nil)
((nil) nil)
(t t)))
(defun at-paren-start? ()
(find (char-after (point))
"([{"))
(defun at-paren-end? ()
(when (> (point) 1)
(find (char-after (point))
")]}")))
(defun at-end-of-symbol? ()
(when (> (point) 1)
(save-excursion
(unless (at-word?)
(backward-char)
(at-word?)))))
(defun forward-at-paren-end ()
(interactive)
(let ((pos (point)))
(cond
((= pos (point-max)) (call-interactively 'newline-and-indent))
((= pos (line-end-position))
(call-interactively 'forward-char)
(call-interactively 'indent-for-tab-command))
(t (call-interactively 'forward-char)))))
(defun forward-at-line-end ()
(interactive)
(let ((pos (point)))
(cond
((= pos (point-max)) (call-interactively 'newline-and-indent))
(t
(call-interactively 'forward-char)
(call-interactively 'indent-for-tab-command)))))
(defun my-ctrl-o ()
(interactive)
(cond
;; markが有効な場合、インデントする
(mark-active (as-this-command indent-region))
;; バッファが空の場合、初期化する(auto-insert)
((buffer-empty?) (as-this-command initialize-buffer))
;; ポイントが単語上にある場合、次の単語に移動する
((at-word?) (as-this-command forward-word))
;; ポイントが開き括弧上にある場合、対応する括弧の終わりに移動する
((at-paren-start?) (as-this-command forward-sexp))
;; ポイントが単語の終わりにある場合、hippie-expandを呼び出す
((at-end-of-symbol?) (as-this-command hippie-expand))
;; ポイントが閉じ括弧の次にある場合、次の文字に進む
((at-paren-end?) (as-this-command forward-at-paren-end))
;; ポイントが行頭にある場合、インデントする
((at-line-start?) (as-this-command indent-for-tab-command))
;; ポイントが行末にある場合、次の行に移動する。
;; バッファの終端でもある場合、改行する。
((at-line-end?) (as-this-command forward-at-line-end))
(t t)))
(defun my-ctrl-a ()
(interactive)
(when (and (eq last-command 'my-ctrl-a)
(= (point) (line-beginning-position)))
(call-interactively 'scroll-down))
(call-interactively 'move-beginning-of-line))
(defun my-ctrl-e ()
(interactive)
(when (and (eq last-command 'my-ctrl-e)
(= (point) (line-end-position)))
(call-interactively 'scroll-up))
(call-interactively 'move-end-of-line))
(global-set-key (kbd "C-o") 'my-ctrl-o)
(global-set-key (kbd "C-a") 'my-ctrl-a)
(global-set-key (kbd "C-e") 'my-ctrl-e)
my-ctrl-aコマンドはC-aに割り当てるつもりで定義したものです。普段は通常のC-aの動作をしますが、すでにポイントが行頭にあり、 1つ前に実行されたコマンドもmy-ctrl-aの場合には、M-v(scroll-down)の動作を行います。
my-ctrl-eコマンドはmy-ctrl-aのC-eバージョンです。 1つ前のコマンドがmy-ctrl-eの場合にはC-v(scroll-up)の動作を行います。
これでscroll-downが押しやすくなった上、C-vを他のコマンドに割り当てる余裕ができました。
また、普段はC-oをhippie-expandコマンドにしているので、展開が必要なさそうな箇所では別の動作をするmy-ctrl-oも定義しました。こちらはC-a/C-eに比べて残念な感じがします。
2011年6月15日水曜日
cl-gtk2 + Glade
cl-gtk2はgladeで作成したファイルを利用できるようなので遊んで見ました。
ソースコード
(asdf:load-system :cl-gtk2-glib)
(asdf:load-system :cl-gtk2-gdk)
(asdf:load-system :cl-gtk2-cairo)
(asdf:load-system :closure-html)
(asdf:load-system :cxml-stp)
(asdf:load-system :drakma)
(asdf:load-system :cl-ppcre)
(asdf:load-system :cl-interpol)
(defpackage :gtk-user
(:use :cl)
(:export run))
(in-package :gtk-user)
(cl-interpol:enable-interpol-syntax)
(setf drakma:*drakma-default-external-format* :utf-8)
(defun reference-of (node)
(let ((tag (stp:local-name node)))
(cond
((string= tag "a")
(or (stp:attribute-value node "href") ""))
((string= tag "img")
(or (stp:attribute-value node "src") ""))
((string= tag "link")
(or (stp:attribute-value node "href") ""))
((string= tag "script")
(or (stp:attribute-value node "src") ""))
(T ""))))
(defun text-of (node)
(let ((text (stp:string-value node)))
(if (> (length text) 30)
(concatenate 'string (subseq text 0 27 ) "...")
text)))
;; ありそうな文字コードを総当たりで試す。富豪的富豪的。
(defun octets-to-string-by-error-handler (octets)
(let ((formats (list :shift_jis :utf-8 :euc-jp :eucjp
:sjis
:utf-16 :utf-16BE :utf-16le
:utf-32 :utf-32be :utf-32le
:utf-8b )))
(tagbody
:retry
(print formats)
(handler-case
(return-from octets-to-string-by-error-handler
(sb-ext:octets-to-string octets :external-format (pop formats)))
(error (e)
(declare (ignore e))
(if formats
(go :retry)
(error "can't convert octets to string")))))))
(defun get-http-body-string (url)
(multiple-value-bind
(arr code headers url stream)
(drakma:http-request url :external-format-in :binary)
(let ((content-type (cdr (find :content-type headers :test #'string= :key #'car))))
(if content-type
(cl-ppcre:register-groups-bind (charset)
((cl-ppcre:create-scanner #?/charset=(\w+)/ :case-insensitive-mode t)
content-type)
;; todo
(octets-to-string-by-error-handler arr))))))
(defun run ()
(let ((out *standard-output*))
(gtk:within-main-loop
(let* ((builder
(make-instance 'gtk:builder
:from-file "/path/to/GladeTest.glade"))
(window (gtk:builder-get-object builder "ToplevelWindow"))
(entry (gtk:builder-get-object builder "entry1"))
(button (gtk:builder-get-object builder "button1"))
(tree (gtk:builder-get-object builder "treeview1"))
;; treeview1のmodelは後で上書きする
(dummy (gtk:builder-get-object builder "liststore1"))
(liststore (make-instance 'gtk:array-list-store)))
;; treeview1のmodelを上書き
(setf (gtk:tree-view-model tree) liststore)
;; tree-viewの列(model)
(gtk:store-add-column liststore "gchararray" #'stp:local-name)
(gtk:store-add-column liststore "gchararray" #'text-of)
(gtk:store-add-column liststore "gchararray" #'reference-of)
;; tree-viewの列(view)
(let ((col-tag (make-instance 'gtk:tree-view-column :title "タグ"))
(col-text (make-instance 'gtk:tree-view-column :title "text"))
(col-ref (make-instance 'gtk:tree-view-column :title "参照先"))
(cr (make-instance 'gtk:cell-renderer-text)))
(gtk:tree-view-column-pack-start col-tag cr)
(gtk:tree-view-column-add-attribute col-tag cr "text" 0)
(gtk:tree-view-column-pack-start col-text cr)
(gtk:tree-view-column-add-attribute col-text cr "text" 1)
(gtk:tree-view-column-pack-start col-ref cr)
(gtk:tree-view-column-add-attribute col-ref cr "text" 2)
(gtk:tree-view-append-column tree col-tag)
(gtk:tree-view-append-column tree col-text)
(gtk:tree-view-append-column tree col-ref))
;; ボタンクリック時の動作
(gobject:g-signal-connect
button "clicked"
(lambda (b)
(handler-case
(let* ((str (get-http-body-string (gtk:entry-text entry)))
(doc (chtml:parse str (cxml-stp:make-builder))))
(stp:do-recursively (node doc)
(when
(and
(typep node 'stp:element)
(some
(lambda (s) (string-equal s (stp:local-name node)))
'("a" "link" "script" "img")))
(gtk:store-add-item liststore node))))
(error (e)
(let ((diag (make-instance 'gtk:message-dialog
:text (format nil
"error:(~A) ~A"
(gtk:entry-text entry)
e)
:message-type :error)))
(unwind-protect (gtk:dialog-run diag)
(gtk:object-destroy diag)))))))
(gtk:widget-show window)))))
gladeファイル
<?xml version="1.0" encoding="UTF-8"?>
<interface>
<requires lib="gtk+" version="2.16"/>
<!-- interface-naming-policy toplevel-contextual -->
<object class="GtkWindow" id="ToplevelWindow">
<property name="title" translatable="yes">ToplevelWindow</property>
<child>
<object class="GtkVBox" id="vbox3">
<property name="visible">True</property>
<child>
<object class="GtkHBox" id="hbox1">
<property name="height_request">30</property>
<property name="visible">True</property>
<child>
<object class="GtkLabel" id="label5">
<property name="visible">True</property>
<property name="label" translatable="yes">URL:</property>
</object>
<packing>
<property name="expand">False</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkEntry" id="entry1">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="invisible_char">•</property>
</object>
<packing>
<property name="position">1</property>
</packing>
</child>
<child>
<object class="GtkButton" id="button1">
<property name="label" translatable="yes">読み込み</property>
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="receives_default">True</property>
</object>
<packing>
<property name="expand">False</property>
<property name="position">2</property>
</packing>
</child>
</object>
<packing>
<property name="expand">False</property>
<property name="position">0</property>
</packing>
</child>
<child>
<object class="GtkTreeView" id="treeview1">
<property name="visible">True</property>
<property name="can_focus">True</property>
<property name="model">liststore1</property>
</object>
<packing>
<property name="position">1</property>
</packing>
</child>
</object>
</child>
</object>
<object class="GtkListStore" id="liststore1"/>
</interface>
利用しているライブラリはすべてquicklispでインストールできます。
ライブラリのおおまかな内容は以下のとおり。
- cl-gtk2-*** : GTKバインディング
- closure-html : HTMLパーサー
- cxml-stp : DOMに似たもの
- cl-ppcre : 正規表現
- drakma : HTTPクライアント
- cl-interpol : リーダーの拡張。正規表現リテラルに利用。
sb-ext:octets-to-stringを利用しているのでSBCLでのみ動作します。他の処理系で動作ささせる場合、バイト列を文字列に変換する箇所を変更する必要があります。
(gtk-user::run) を評価するとテキストボックス(entry)を持ったウィンドウが表示されます。このテキストボックスにURLを入力して隣のボタンをクリックすると、URLの内容(HTML)を取得し、他のURLへを参照していそうなa/link/img/scriptタグを抜き出してtree-viewに表示します。
わかりづらかった点として、gtk:array-list-storeがCommonLisp側で定義されたクラスだということがありました。 array-list-storeは便利そうだと思いましたが、GTK側に組み込まれているクラスではないので、 Gladeでモデルに指定できない(ような気がします)。
2011年6月11日土曜日
ネタ言語 primefu*k
ネタ言語を実装しました。
;; 素数リストの作成
(defun make-prime-list (n)
(let ((arr (make-array n :initial-element 0 :element-type '(integer 0 1))))
(setf (aref arr 0) 1)
(setf (aref arr 1) 1)
(loop
:for i from 2 below n
:when (zerop (aref arr i))
:do (loop
:for j from (* i 2) below n by i
:do (setf (aref arr j) 1)))
(loop
:for i from 0 below n
:when (zerop (aref arr i))
:collect i)))
(defparameter
*primes*
(coerce (make-prime-list 100000) 'vector))
;; 素因数分解
(defun integer-factorization (n prime-vector)
(let ((result nil))
(loop
:for x across prime-vector
:until (= n 1)
:do
(loop
:while (zerop (mod n x))
:do (setf n (/ n x))
:sum 1 into acc
:finally (push (cons x acc) result)))
(nreverse result)))
;; 数値を引き数として受け取り、Common Lispプログラムを返す
(defun n->cl (n primes)
(let ((operators
(mapcar #'cdr (integer-factorization n primes))))
(let ((tags nil)
(result nil))
(dolist (op operators)
(case op
((0) ;; >: ptr++
(push `(incf ptr) result))
((1) ;; <: ptr--
(push `(decf ptr) result))
((2) ;; +: (*ptr)++
(push `(incf (aref memory ptr)) result))
((3) ;; -: (*ptr)--
(push `(decf (aref memory ptr)) result))
((4) ;; .: putchar(*ptr)
(push `(write-char (code-char (aref memory ptr)))
result))
((5) ;; ,: *ptr=getchar()
(push `(setf (aref memory ptr) (char-code (read-char)))
result))
((6) ;; [: while(*ptr){
(let ((from (gensym))
(to (gensym)))
(push (cons from to) tags)
(push
`(when (zerop (aref memory ptr))
(go ,to))
result)
(push from result)))
((7) ;; ]: }
(destructuring-bind (from . to) (pop tags)
(push
`(unless (zerop (aref memory ptr))
(go ,from))
result)
(push to result)))
(T (error "unexpected operator"))))
`(let ((memory (make-array 30000
:initial-element 0
:element-type '(unsigned-byte 8)))
(ptr 0))
(tagbody
,@(nreverse result))))))
(defvar *bf-char->op*
"><+-.<[]")
;; Brainfu*kプログラムを数値に変換
(defun bf->n (bf-string primes)
(let ((result 1))
(loop
:for ch across bf-string
:for p across primes
:do (setf result
(* result
(expt p (position ch *bf-char->op*)))))
result))
(defvar *helloworld-bf*
"+++++++++[>++++++++>+++++++++++>+++++<<<-]>.>++.+++++++..+++.>-.------------.<++++++++.--------.+++.------.--------.>+.")
(defun execute (n &optional (primes *primes*))
(eval (n->cl n primes)))
;; test
(execute (bf->n *helloworld-bf* *primes*))
名前のとおり、中身はBrainfu*kです。
入力となるソースコードは数値で、素因数分解によって命令列が作成されます。
例えば"Hello, world!"と出力するプログラムは以下の値です。 (10進数、25桁ごとに改行)
4502303465384972596608528
2944087262557401643378529
8625080698782925063959121
7719172880530482008491550
8597084354818091584552183
1319098036757291006692817
9301283601343001317452270
0376267461517920956544956
5153324663016284459064839
1911228540917237768596719
1754627268505767395202314
3109320783377732443055786
7415159648646742451459077
8603291732011810376948079
2004773113078228397846041
4399383865663430345291483
4231649128778405945758270
3488234290362476776792281
3785655092937989870582015
2313906809006976695583076
4202816254753054328113083
3788768481801880471791973
8660596785756596281519027
4112020595197735280186913
1838747769408930883235538
9738739557566706588749933
2671373192590205308149393
8139362300
2011年6月10日金曜日
いまさら Arc Challenge を考える
時代は継続らしいので、cl-contを利用してこんな感じで書いてみます。
(defvar top-page (load-html #p"top.html"))
(defvar link-page (load-html #p"link.html"))
(defvar result-page (load-html #p"result.html"))
(defapp arc (state)
(show top-page state)
(let ((text state.reply$text))
(show link-page state)
(show result-page state `(:text ,text))))
(start #'arc)
2011年6月9日木曜日
defclassとdefmethodをいじくる
特定のシンボルを特別扱いして、省略表記として利用できるような defclassとdefmethodを定義してみました。
似たようなネタばかりやっている気がします。
(asdf:load-system :alexandria)
;; セッターとゲッター
(defgeneric get-slot (obj slot))
(defgeneric set-slot (obj slot new))
(defmethod get-slot (obj slot)
(slot-value obj slot))
(defmethod set-slot (obj slot new)
(setf (slot-value obj slot) new))
(defmethod (setf get-slot) (new obj slot)
(set-slot obj slot new))
(defgeneric get-parameter (obj param))
(defgeneric set-parameter (obj param new))
(defmethod (setf get-parameter) (new obj param)
(set-parameter obj param new))
(defmethod get-parameter ((this hash-table) param)
(gethash param this))
(defmethod set-parameter ((this hash-table) param new)
(setf (gethash param this) new))
;; ドット区切り、ドル記号区切りのシンボルを変換するマクロ
(defmacro with-accessor-translation (&body body)
(let ((symbol-list
(remove-duplicates (collect-accessor-symbols body))))
`(symbol-macrolet ,(mapcar #'accessor-symbol->symbol-macrolet-form symbol-list)
,@body)))
(defun accessor-symbol? (sym)
(when (symbolp sym)
(let* ((name (symbol-name sym))
(len (length name)))
(when (> len 2)
(let ((subname (subseq name 1 (1- len))))
(or (find #\. subname)
(find #\$ subname)))))))
(defun collect-accessor-symbols (exp)
(let ((symbols (alexandria:flatten exp)))
(remove-if-not #'accessor-symbol? symbols)))
(defun separate-symbol (sym)
(let ((name (symbol-name sym))
(result nil)
(pos 0))
(loop
:with len = (length name)
:for dot-pos = (position #\. name :start pos)
:for dollar-pos =(position #\$ name :start pos)
:while (< pos len)
:do
(cond
((and (null dot-pos) (null dollar-pos))
(push (subseq name pos) result)
(setf pos len))
((or (null dollar-pos)
(and dot-pos (< dot-pos dollar-pos)))
(push (subseq name pos dot-pos) result)
(push :dot result)
(setf pos (1+ dot-pos)))
(t ; (or (null dot-pos) (< dollar-pos dot-pos))
(push (subseq name pos dollar-pos) result)
(push :dollar result)
(setf pos (1+ dollar-pos)))))
(labels ((recur (rest acc)
(if rest
(destructuring-bind (key sel &rest r) rest
(case key
((:dot) (recur r `(get-slot ,acc ',(intern sel))))
((:dollar) (recur r `(get-parameter ,acc ',(intern sel))))
(t (error "invalid keyword"))))
acc)))
(let ((lst (nreverse result)))
(recur (cdr lst) (intern (car lst)))))))
(defun accessor-symbol->symbol-macrolet-form (sym)
`(,sym ,(separate-symbol sym)))
;;; defclass/defmethod マクロの定義
(defmacro defclass* (name (&rest supers) (&rest clauses) &rest options)
`(progn
(defclass ,name ,supers
,(mapcar
#'expand-clause
clauses)
,@options)
,@(mapcar
#'(lambda (clause) (expand-form-in-clause name clause))
clauses)))
(defmacro defmethod* (name (&rest args) &body body)
`(defmethod ,name (,@args)
(with-accessor-translation
,@body)))
(defun couple (lst)
(loop
:for head on lst by #'cddr
:collect (subseq head 0 2)))
(defun expand-clause (clause)
(let ((name (car clause))
(options (couple (cdr clause))))
(let ((result nil))
(dolist (option options)
(case (first option)
((:initform) (push option result))
((:initarg) (push option result))
(T 'nothing-to-do)))
(unless (find :initarg result :key #'first)
(push
`(:initarg ,(alexandria:make-keyword name))
result))
`(,name
,@(apply #'append (nreverse result))))))
(defun expand-form-in-clause (classname clause)
(let ((name (car clause))
(options (couple (cdr clause))))
(let ((result nil))
(dolist (option options)
(cond
((and (eq (first option) :readonly)
(eq (second option) T))
(push `(defmethod set-slot ((this ,classname) (slot (eql ',name)) new)
(error "readonly slot"))
result))
(T 'nothing-to-do)))
`(progn ,@result))))
;; test
(defclass* <person> ()
((id :initform (error "required") :initarg :id :readonly t)
(name)
(age :initarg :age)))
(defmethod* show ((this <person>))
(format t "~A: ~A (~A)~%"
this.id
this.name
this.age))
(defmethod* correct ((this <person>))
(incf this.age))
(defmethod* invalid ((this <person>))
(setf this.id 3))
(defvar p (make-instance '<person> :id 1 :name "kurohuku" :age 23))
(describe p)
(show p)
(correct p)
(describe p)
(invalid p)
2011年6月7日火曜日
Common Lispは自由過ぎてわかりづらいという思い
ブログがソースコード貼り付け場所と化しているので、文章を書く努力。推測とか感覚とかなんとなくがミックスされてるので文章としてどうなんだろう。
本文
Common Lispは数多くあるプログラミング言語の中でも、自由度という点では(大量の括弧を気にしなければ)トップクラスの言語ではないかと思います。
例えば、Common Lispには、プログラマが手を加えることのできる処理のタイミングが3つあります。 1つ目は普通に処理が実行される時、2つ目はコンパイル時(マクロ(※1)/コンパイラマクロ)、3つ目は読み込み時です。多くの言語では、2つ目と3つ目の処理に手を加える機能は存在しないか、限定的なものです。
また、Common Lispでは、プログラマが望むならば、大抵のものは自分で作成できます。組み込みのオブジェクトシステム(CLOS)が気にくわなければ、新しいオブジェクトシステムを作成して組み込めます。あるいは、数値演算を中置記法で書く構文を導入することもできますし、正規表現リテラルの記法を定義することもできます。そうして新しい構文や記法を追加しても、Objective-CLになったり、CL++になったりせずに、依然としてCommon Lispのままです。
自由であることは良いことだと、多くの人が思っているでしょう。けれど、Common Lispがこれだけ自由なのは果たして良いことなのでしょうか。
もちろん、良いことです。
良いことですが、世の中にはリスク無しのリターンも、欠点のない利点もほとんど存在しないだろうと思います。なので、このフリーダムっぷりにも相応の欠点がある、と感じています。
なにが問題かというと、それは「わかりにくい」ということです。少ないと言われるCommon Lispのライブラリですが、それでもLispハッカーな方々がいろいろなライブラリを作成し、公開してくれています。そうしたライブラリを使おうとすると、私のような木っ端Lisp使いは思うわけです。「使い方がわからん」と。
というのも、ライブラリごとにインタフェースがまちまち(※2)で、「他のライブラリではこうだったし、たぶんこうだろうな」という考えが通用しにくいからです。もちろん、ドキュメントや、最悪ソースコードをしっかり読めば理解はできるでしょう。しかし、例えばJavaだったらAPI仕様を斜め読みする程度で使い方はわかります。どの機能(クラス)もだいたい同じような使い方だからです。 .NetやPython、Rubyのライブラリも、Common Lispほどわかりづらいことはないだろうと思います。
JavaもC#もPythonもRubyも、おそらくCommon Lispほど自由ではないです。これらの言語を設計した人たちは、プログラマの自由を制限して、思想や作法を強制しています。けれど、そのおかげでわかりやすいです。
上記の言語には、Common Lispよりもたくさんのユーザーと開発者がいます。制限された自由の中で、同じような作法で作られたライブラリ群を使う方が良い、と考える人が大勢いるということだと思います。ならば、そういった考えを貰ってきても良いはずです。うまくいかなかそうでも、Common Lispが消え去るわけではありませんし。
今後しばらく、短い・わかりやすい・再利用しやすい、けれどそのかわりに思想や作法を強制される、という考えでも良いということを念頭にプログラミングしてみようと思います。
自作マクロの山になって本末転倒な予感がしますが。
注
※１: 仕様上、マクロがコンパイル時に展開される、という表現は正しくないかと思います。詳しくはHyperSpecあたりを参照してください。 ※２： Common Lispのライブラリのインタフェースがまちまちだ、というのは個人的な印象に過ぎないかもしれません。
2011年6月4日土曜日
リクエストパラメータを引数として扱う
HTTPの説明の際に、URLを関数、リクエストパラメータを引数と例えることがあるようなので、実際に引数=リクエストパラメータとなるようにしてみました。
(asdf:load-system :cl-annot)
(asdf:load-system :alexandria)
(asdf:load-system :clack)
(defpackage annotation
(:nicknames a)
(:export httpfn/clack))
(defpackage http-as-function
(:use :cl)
(:nicknames httpfn)
(:export
:with-http-parameters
:*env*
:*request*))
(in-package :http-as-function)
(defparameter *request* nil)
(defparameter *env* nil)
;; clack.request:body-parameterはパラメータ名の大文字/小文字を区別するため、
;; 区別せずに値を取得できる関数を定義する。
(defun body-parameter-ci (request name)
(let ((plist (slot-value request 'clack.request::body-parameters)))
(loop
:for (k v) on plist by #'cddr
:when (string-equal k name)
:do (return-from body-parameter-ci v))
nil))
(defun query-parameter-ci (request name)
(let ((plist (slot-value request 'clack.request::query-parameters)))
(loop
:for (k v) on plist by #'cddr
:when (string-equal k name)
:do (return-from query-parameter-ci v))
nil))
(defmacro with-http-parameters ((&rest params) request &body body)
(let ((gparamfn (gensym))
(greq (gensym)))
`(let* ((,greq ,request)
(,gparamfn
(case (clack.request:request-method ,greq)
(:post #'body-parameter-ci)
(:get #'query-parameter-ci)
(T #'query-parameter-ci))))
(let
,(mapcar
#'(lambda (param)
(if (listp param)
`(,(car param) (funcall ,gparamfn ,greq ,(cdr param)))
`(,param (funcall ,gparamfn ,greq ,(symbol-name param)))))
params)
,@body))))
(defun defun->httpfn (defun-form)
(destructuring-bind (def name lambda-list &rest body) defun-form
(multiple-value-bind
(forms declarations doc-string)
(alexandria:parse-body body :documentation t)
(multiple-value-bind
(required optional rest key allow-other-keys? aux)
(alexandria:parse-ordinary-lambda-list lambda-list)
(when (or optional rest key allow-other-keys? aux)
(error "lambda-list error"))
`(,def ,name (httpfn:*ENV*)
,doc-string
,@declarations
(let ((httpfn:*REQUEST* (clack.request:make-request httpfn:*ENV*)))
(with-http-parameters ,required httpfn:*REQUEST*
,@forms)))))))
(cl-annot:defannotation a:httpfn/clack (defun-form) (:arity 1)
(defun->httpfn defun-form))
;; test
(cl-annot:enable-annot-syntax)
;; アノテーションを付けた関数
@a:httpfn/clack
(defun show-article (id)
"show the article specified by `id'"
(cond
((string= id "1")
`(200 (:content-type "text/html")
("<html><body>page 1</body></html>")))
(T
`(200 (:content-type "text/html")
("<html><body>unexpected id</body></html>")))))
;; アノテーションを付けない関数
(defun show-article-2 (id)
"show the article specified by `id'"
(cond
((string= id "1")
`(200 (:content-type "text/html")
("<html><body>page 1</body></html>")))
(T
`(200 (:content-type "text/html")
("<html><body>unexpected id</body></html>")))))
;; Clackでは属性リスト形式(key1 value1 key2 valu2 ...)でリクエストの内容が渡される
;;(show-article `(:request-method :get :query-string "id=1"))
;; -> (200 (:CONTENT-TYPE "text/html") ("<html><body>page 1</body></html>"))
;;(show-article-2 "1")
;;-> (200 (:CONTENT-TYPE "text/html") ("<html><body>page 1</body></html>"))
(clack.app.route:defroutes app
(GET "/" #'show-article))
(defparameter *app* (clack:clackup #'app :port 5555))
;;(clack:stop *app*)
Webページとして表示させるために、Clackを利用しました。
Hunchentoot、Clack、cl-annot、Alexandriaをインストール(すべてquicklispでインストール可能)後、上記のコードを実行すると、5555ポートでWebサーバが立ち上がります。
http://localhost:5555/ にアクセスすると、show-articleの呼び出し結果が Webページとして表示されます。クエリストリングを追加して、 http://localhost:5555/?id=1 にアクセスすると、前回とは異なる内容が表示されるかと思います。
show-articleは引数idに応じて戻り値を返す普通の関数ですが、 httpfn/clackをアノテーションとして付加すると、引数名と同名のリクエストパラメータの値を受け取るClack用の関数に変化します。
同等の処理を毎回記述するよりも、アノテーションを付加するだけのほうが楽で良いかなぁ、と思いました。 Webアプリケーション開発の経験値がないので、有用であるかはわかりませんが。
2011年5月31日火曜日
バイト列を画像に変換する
目grepはできませんが、画像を作るくらいならできそうなのでやってみました。
入力を1バイトずつ、値に応じた色のピクセルに変換して画像を作成します。値と表示色の関係はbin2colorをいじると変更できます。
ひさびさにPythonを使ってみました。
#!/usr/bin/python
import sys
import os.path
import Image
argvs = sys.argv
argc = len(argvs)
if (argc != 3) :
print 'Usage : %s [input-file] [output-file]' % argvs[0]
quit()
in_file = argvs[1]
out_file = argvs[2]
filesize = os.path.getsize(in_file)
x = 160
y = filesize/x + 1
print 'filesize %d , x = %d, y = %d' % (filesize, x, y)
def bin2color(bin):
bin = ord(bin)
if bin == 0 :
return (255, 255, 255)
elif bin <= 0x80 :
return (255, 0, 0)
else :
return (0, 0, 0)
img = Image.new("RGB", (x, y), (255, 255, 255))
try:
f = open(in_file, "rb")
n = 0
while n < y-1:
line = f.read(x)
for i in range(x):
img.putpixel((i,n), bin2color(line[i]))
n = n + 1
line = f.read(filesize - (x * n))
for i in range(filesize - (x * n)):
img.putpixel((i,n), bin2color(line[i]))
finally:
f.close()
img.save(out_file, "BMP")
2011年5月28日土曜日
リストの作成
F#のyieldやyield!っぽいなにかを書いてみました。値を集めることしかしませんが、 loopマクロよりもリストを作りやすいのではないか、という気はします。
(defmacro yielding (&body body)
(let ((gtail (gensym))
(ghead (gensym))
(garg (gensym))
(gtmp (gensym)))
`(let* ((,ghead (cons nil nil))
(,gtail ,ghead))
(macrolet
((yield (,garg) `(setf (cdr ,',gtail) (cons ,,garg nil)
,',gtail (cdr ,',gtail)))
(yield! (,garg) `(loop :for ,',gtmp :in ,,garg :do (yield ,',gtmp))))
,@body
(cdr ,ghead)))))
> (yielding (yield 2))
(2)
> (yielding (dotimes (i 3) (yield i)) (yield! (sort (list 1 2) #'>)))
(0 1 2 2 1)
2011年5月18日水曜日
F#入門
F#はじめました。とりあえずFizzBuzz。
let fizzbuzz1 (tgt : int) =
[1..tgt]
|> List.map
(fun n -> if n % 15 = 0
then printf "FizzBuzz\n"
else if n % 5 = 0
then printf "Buzz\n"
else if n % 3 = 0
then printf "Fizz\n"
else printf "%d\n" n)
|> ignore
let fizzbuzz2 (tgt : int) =
[1..tgt]
|> List.iter
(fun n ->
match n with
| _ when n % 15 = 0 -> printf "FizzBuzz\n"
| _ when n % 5 = 0 -> printf "Buzz\n"
| _ when n % 3 = 0 -> printf "Fizz\n"
|_ -> printf "%d\n" n)
|> ignore
いちおうプログラミングF#は流し読みしたけれど、 9割がた抜け落ちてるのでコードを書きつつ読み直してみる。
2011年5月12日木曜日
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))))
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をまともに使えている気がします。たぶん気のせいですが。
2011年5月5日木曜日
矢印でメソッドチェイン風に記述する
なんどか似たようなネタでコードを書いている気がします。
矢印シンボルを用いて括弧の数を減らしてみます。矢印の`>'の個数で式を挿入する位置を決定するようにしてみました。
(defun arrow-symbol? (sym)
(when (symbolp sym)
(let ((name (symbol-name sym)))
(and (<= 2 (length name))
(= (+ (count #\- name)
(count #\> name))
(length name))
(string= (sort (copy-seq name) #'char<)
name)))))
(defun arrow-count (sym)
(count #\> (symbol-name sym)))
(defun collect-arrow-clauses (body)
(do ((rest (reverse body))
(result nil))
((null rest) result)
(let ((pos (position-if #'arrow-symbol? rest)))
(when (null pos)
(error "arrow symbol not found"))
(push (reverse (subseq rest 0 (1+ pos))) result)
(setf rest (subseq rest (1+ pos))))))
(defmacro arrow (obj &body body)
(labels
((expand (rest prev)
(if rest
(let ((insert-pos (arrow-count (caar rest))))
(expand
(cdr rest)
(append
(subseq (cdar rest) 0 insert-pos)
(list prev)
(subseq (cdar rest) insert-pos))))
prev)))
(expand (collect-arrow-clauses body) obj)))
;;; 実効
(arrow "afscd"
-> copy-seq
-> sort #'char<
->>> format t "sorted:~A~%")
;;; マクロ展開後のコード
(FORMAT T "sorted:~A~%" (SORT (COPY-SEQ "afscd") #'CHAR<))
;;; 出力
sorted:acdfs
deftypeとtypecaseを使ってfizzbuzz
Common Lispのdeftypeを利用してみます。
fizz,buzz,fizzbuzzをdeftypeで型として定義して、 typecaseを使って値を判別します。
(defun fizz? (n)
(zerop (mod n 3)))
(defun buzz? (n)
(zerop (mod n 5)))
;;; 型定義
;; fizz型は0以上の整数かつ関数fizz?に引数として渡すと真を返す値であると定義
(deftype fizz ()
'(and (integer 0 *) (satisfies fizz?)))
(deftype buzz ()
'(and (integer 0 *) (satisfies buzz?)))
(deftype fizzbuzz ()
'(and
(integer 0 *)
(satisfies fizz?)
(satisfies buzz?)))
;;; 実効
(loop for i from 1 to 30
do (print
(typecase i
(fizzbuzz 'fizzbuzz)
(fizz 'fizz)
(buzz 'buzz)
(t i))))
;;; 出力
1
2
FIZZ
4
BUZZ
FIZZ
7
8
FIZZ
BUZZ
11
FIZZ
13
14
FIZZBUZZ
16
17
FIZZ
19
BUZZ
FIZZ
22
23
FIZZ
BUZZ
26
FIZZ
28
29
FIZZBUZZ
2011年4月13日水曜日
ユニットテストの記法を考える
しばらくテストばかりしていたせいか、 Common Lispを触っているときもテストネタについて考えています。
Common Lispには既にかなりの数のユニットテストツールがありますが、車輪の再開発上等というか、自分で考えるのも良いだろうということで、括弧の数を減らすような書き方を考えてみました。
(defpackage net.phorni.unittest
(:use :cl)
(:nicknames :ut)
(:export
test
run-test))
(in-package :net.phorni.unittest)
(defparameter *test-table* (make-hash-table))
;;;; condition
(define-condition <assertion-result> (simple-condition)
((form :accessor form-of :initarg :form)
(assert-form :accessor assert-form-of :initarg :assert-form)
(actual :accessor actual-of :initarg :actual)
(test-case-name :accessor test-case-name-of :initarg :test-case-name)
(test-name :accessor test-name-of :initarg :test-name)
(result-type :accessor result-type-of :initarg :result-type)))
(define-condition <setup-error> (simple-condition)
((test-case-name :accessor test-case-name-of :initarg :test-case-name)
(test-name :accessor test-name-of :initarg :test-name)
(setup-type :accessor setup-type-of :initarg :setup-type)))
;;;; utility
(defmacro while (test &body body)
`(loop
:while ,test
:do ,@body))
(defun symb (&rest xs)
(values (intern (format nil "~{~A~}" xs))))
(defun collect-clauses (name lists)
(mapcar
#'cdr
(remove-if-not
#'(lambda (x)
(and (listp x)
(symbolp (car x))
(eq (car x) name)))
lists)))
(defun merge-clauses (name lists)
(apply 'append
(collect-clauses name lists)))
(defun flatten (tree)
(labels ((flatten% (x acc)
(if (atom x)
(cons x acc)
(if (null (cdr x))
(flatten% (car x) acc)
(flatten% (cdr x) (flatten% (car x) acc))))))
(nreverse (flatten% tree nil))))
(defun at-symbol? (x)
(and (symbolp x)
(let ((name (symbol-name x)))
(and (< 1 (length name))
(char= #\@ (char name 0))))))
;;;; report
(defparameter *count* 0)
(defparameter *ng* 0)
(defun report (a)
(let ((result-type (result-type-of a))
(test-name (test-name-of a))
(test-case-name (test-case-name-of a)))
(incf *count*)
(unless (eq :success result-type) (incf *ng*))
(format t "~A : ~A => ~A~%"
test-name
test-case-name
result-type)))
(defun report-done ()
(format t
"test: ~a, success: ~a, failure: ~a~%"
*count*
(- *count* *ng*)
*ng*))
(defvar *report-function-success* 'report)
(defvar *report-function-failure* 'report)
(defvar *report-function-error* 'report)
(defvar *report-function-done* 'report-done)
;;;; run test
(defun run-test (name)
(let ((fn (gethash name *test-table*)))
(when (functionp fn)
(handler-bind
((<assertion-result>
#'(lambda (a)
(funcall
(case (result-type-of a)
(:success *report-function-success*)
(:failure *report-function-failure*)
(:error *report-function-error*)
(t #'identity))
a))))
(funcall fn)))
(funcall *report-function-done*)))
;;;; test macro
(defmacro test (test-name &body body)
(let ((body (convert-syntax body)))
(let ((before (merge-clauses :before body))
(before-all (merge-clauses :before-all body))
(after (merge-clauses :after body))
(after-all (merge-clauses :after-all body))
(test-case-list (collect-clauses :case body))
(vars
(remove-duplicates (remove-if-not 'at-symbol? (flatten body))))
(after-sym (gensym))
(before-sym (gensym)))
`(progn
(setf (gethash ',test-name *test-table*)
(lambda ()
(let ,vars
,@before-all
(labels ((,after-sym () ,@(if after after (list nil)))
(,before-sym () ,@(if before before (list nil))))
,@(mapcar
#'(lambda (test-case)
`(test-case
,test-name
,(car test-case)
,before-sym ,after-sym
,@(cdr test-case)))
test-case-list))
,@after-all)))))))
(defun convert-syntax (body)
(let ((rest (copy-tree body))
(result nil))
(while rest
(let ((form (pop rest)))
(push
(case form
(#1=(:before :before-all :after :after-all :case)
`(,form
,@(let ((pos
(position-if
(lambda (x)
(find x '#1#))
rest)))
(unless pos
(setf pos (length rest)))
(prog1
(subseq rest 0 pos)
(setf rest (nthcdr pos rest))))))
(t
(error "syntax error")))
result)))
(nreverse result)))
(defmacro test-case (test-name test-case-name before-fn after-fn &body body)
(let ((sym (gensym)))
(labels ((setup-form (fn type)
`(handler-case (,fn)
(t (,sym) (declare (ignore ,sym))
(error 'net.phorni.unittest::<setup-error>
:setup-type ,type
:test-name ',test-name
:test-case-name ',test-case-name)
(go :end-of-test-case)))))
`(tagbody
,(setup-form before-fn :before)
,(parse-test-case-body test-name test-case-name body)
,(setup-form after-fn :after)
:end-of-test-case))))
(defun parse-test-case-body (test-name test-case-name body)
(let ((form (car body))
(assertion-type nil)
(rest (copy-list (cdr body)))
(result-sym (gensym))
(arg-sym (gensym)))
(setf assertion-type (intern (symbol-name (pop rest))))
(if (eq assertion-type (intern "THROW"))
(let ((condition (pop rest)))
`(handler-case
(let ((,arg-sym ,form))
(signal
'net.phorni.unittest::<assertion-result>
:form ',form
:assert-form '(:catch ,condition)
:test-name ',test-name
:test-case-name ',test-case-name
:actual ,arg-sym
:result-type :failure))
(,condition (,arg-sym)
(signal
'net.phorni.unittest::<assertion-result>
:form ',form
:assert-form '(:catch ,condition)
:test-name ',test-name
:test-case-name ',test-case-name
:actual ,arg-sym
:result-type :success))
(t (,arg-sym)
(signal
'net.phorni.unittest::<assertion-result>
:form ',form
:assert-form '(:catch ,condition)
:test-name ',test-name
:test-case-name ',test-case-name
:actual ,arg-sym
:result-type :error))))
(let ((assertion-form
(case assertion-type
((= /= < <= > >= eq eql equal string= string/= char= char/=)
`(,assertion-type ,result-sym ,(pop rest)))
((should)
`(equal ,result-sym ,(pop rest)))
((should-not)
`(not (equal ,result-sym ,(pop rest)))))))
`(handler-case (let ((,result-sym ,form))
(signal
'net.phorni.unittest::<assertion-result>
:form ',form
:assert-form ',assertion-form
:test-name ',test-name
:test-case-name ',test-case-name
:actual ,result-sym
:result-type (if ,assertion-form :success :failure)))
(net.phorni.unittest::<assertion-result> (a)
(signal a))
(t (,arg-sym)
(signal
'net.phorni.unittest::<assertion-result>
:form ',form
:assert-form ',assertion-form
:test-name ',test-name
:test-case-name ',test-case-name
:actual ,arg-sym
:result-type :error)))))))
;;;; example
#|
(test list
:before
(setf @a (list 10 20))
:case "length"
(length @a) = 2
:case "nth-0"
(nth 0 @a) = 10
:case "nth-2"
(nth 2 @a) eq nil
:case "elt-2"
(elt @a 2) throw error
)
(run-test 'list)
|#
2011年4月10日日曜日
hippie-expandでSLIMEの補完を利用する
モードごとに補完関数を切り替えるelispを書いたので、 Common Lisp編集中にはelisp用のtry-complete-lisp-symbolではなく SLIMEの補完を行えるようなelispも書いてみました。
補完候補を探す箇所以外はほとんどtry-complete-lisp-symbolと違いはありません。
(defun try-complete-slime-symbol (old)
(unless old
(he-init-string (he-lisp-symbol-beg) (point))
(unless (he-string-member he-search-string he-tried-table)
(setq he-tried-table (cons he-search-string he-tried-table)))
(setq he-expand-list
(and (not (equal he-search-string ""))
(sort
(case slime-complete-symbol-function
((slime-simple-complete-symbol)
(get-completions/slime-simple-complete he-search-string))
((slime-fuzzy-completions)
(get-completions/slime-fuzzy-complete-symbol he-search-string))
((slime-complete-symbol*)
(get-completions/slime-complete-symbol*))
(t (error "unexpected slime-complete-symbol-function")))
'string-lessp))))
(while (and he-expand-list
(he-string-member (car he-expand-list) he-tried-table))
(setq he-expand-list (cdr he-expand-list)))
(if (null he-expand-list)
(progn
(when old (he-reset-string))
nil)
(progn
(he-substitute-string (car he-expand-list))
(setq he-expand-list (cdr he-expand-list))
t)))
(defun get-completions/slime-simple-complete-symbol (prefix)
(car (slime-simple-completions prefix)))
(defun get-completions/slime-fuzzy-complete-symbol (prefix)
(car (slime-fuzzy-completions prefix)))
(defun get-completions/slime-complete-symbol* ()
" -> slime-maybe-complete-as-filename , slime-expand-abbreviations-and-complete"
(let ((end (move-marker (make-marker) (slime-symbol-end-pos)))
(beg (move-marker (make-marker) (slime-symbol-start-pos))))
(let ((completions (slime-contextual-completions beg end)))
(car completions))))
2011年4月1日金曜日
hippie-expandの略語展開関数をmodeごとに指定する
Emacsの補完機能の一つにhippie-expandというものがあります。
hippie-expandは補完用関数のリストを設定すると、そのリストの先頭から順番に補完を試してくれます。
私は主にlisp系言語で遊んでいるので、補完用関数のリストに lispのシンボル補完用関数を設定していたのですが、lispプログラミング以外を行っている時にもlispのシンボルが候補にあがってしまいます。
Emacsのことなのですでに解決策はあるのでしょうが、とりあえず自作でmojor-mode/minor-modeごとに補完用関数を切り替えられるようなelispを書いてみました。
(require 'cl)
(defvar mode-specified-try-functions-table (make-hash-table))
(defun set-mode-specified-try-functions (mode functions)
(setf (gethash mode mode-specified-try-functions-table)
functions))
(defun set-default-try-functions (functions)
(setf (gethash :default mode-specified-try-functions-table)
functions))
(defun expand-try-functions-of (mode)
(let ((result
(gethash mode mode-specified-try-functions-table)))
(if (listp result) result
(list result))))
(defun current-hippie-expand-try-function-list ()
(remove-duplicates
(remove nil
(append
(apply
'append
(mapcar 'expand-try-functions-of minor-mode-list))
(expand-try-functions-of major-mode)
(expand-try-functions-of :default)))
:from-end t))
(defadvice hippie-expand (around mode-specified-hippie-expand)
(let ((hippie-expand-try-functions-list
(current-hippie-expand-try-function-list)))
ad-do-it))
(defun enable-mode-specified-hippie-expand ()
(interactive)
(ad-enable-advice 'hippie-expand
'around
'mode-specified-hippie-expand)
(ad-activate 'hippie-expand))
(defun disable-mode-specified-hippie-expand ()
(interactive)
(ad-disable-advice 'hippie-expand
'around
'mode-specified-hippie-expand)
(ad-deactivate 'hippie-expand))
;;(provide 'mode-specified-hippie-expand)
;;;; examples
(set-default-try-functions
'(try-complete-file-name-partially
try-complete-file-name
try-expand-all-abbrevs
try-expand-dabbrev
try-expand-dabbrev-all-buffers
try-expand-dabbrev-from-kill))
(dolist (mode
'(emacs-lisp-mode
slimre-repl-mode
lisp-mode
common-lisp-mode
lisp-interaction-mode))
(set-mode-specified-try-functions
mode
'(try-complete-lisp-symbol-partially
try-complete-lisp-symbol)))
;;;; enable
(enable-mode-specified-hippie-expand)
2011年2月23日水曜日
エターナル・フォース・コントロール
Emacsのキーマップについて調べていたら、入力イベントを変換する機能というのを見つけたので無駄機能を使って遊んでみます。
(defun enable-force-ctrl ()
(interactive)
(aset keyboard-translate-table ?a ?\^a)
(aset keyboard-translate-table ?b ?\^b)
(aset keyboard-translate-table ?c ?\^c)
(aset keyboard-translate-table ?d ?\^d)
(aset keyboard-translate-table ?e ?\^e)
(aset keyboard-translate-table ?f ?\^f)
(aset keyboard-translate-table ?g ?\^g)
(aset keyboard-translate-table ?h ?\^h)
(aset keyboard-translate-table ?i ?\^i)
(aset keyboard-translate-table ?j ?\^j)
(aset keyboard-translate-table ?k ?\^k)
(aset keyboard-translate-table ?l ?\^l)
(aset keyboard-translate-table ?m ?\^m)
(aset keyboard-translate-table ?n ?\^n)
(aset keyboard-translate-table ?o ?\^o)
(aset keyboard-translate-table ?p ?\^p)
(aset keyboard-translate-table ?q ?\^q)
(aset keyboard-translate-table ?r ?\^r)
(aset keyboard-translate-table ?s ?\^s)
(aset keyboard-translate-table ?t ?\^t)
(aset keyboard-translate-table ?u ?\^u)
(aset keyboard-translate-table ?v ?\^v)
(aset keyboard-translate-table ?w ?\^w)
(aset keyboard-translate-table ?x ?\^x)
(aset keyboard-translate-table ?y ?\^y)
(aset keyboard-translate-table ?z ?\^z))
このコマンドを実行すると、アルファベット小文字のキー入力は問答無用でCtrl付きキーシーケンスに変換されます。一度実行されると解除するのが極めて困難な状況に陥ることでしょう。
以下、キーマップについてのメモ。
Emacsで入力イベントがどのようにキー列となり、どのキーマップのコマンドが実行されるか、ということを学ぶには、「37.8.2 入力イベント」や「21 キーマップ」あたりを見ると良さそう。
キーマップの探索順序は、このようになるようです。
- key-translation-map
- テキスト属性local-mapによる代替ローカルキーマップ
- マイナーモードキーマップ(リストの先頭から順番)
- ローカルキーマップ(メジャーモード毎のマップ)
- グローバルキーマップ
テキスト属性によるキーマップの位置がちょっとあやしい。
(訂正:マイナーモードキーマップとテキスト属性のキーマップが案の定逆っぽいので修正. 2011/02/23)
キー探索を行うためにlookup-key、key-binding、local-key-binding、global-key-binding、minor-mode-key-bindingといった関数が存在するので、自力で探索することもそこまで大変ではなさそうです。
この他に、一部のキーマップの定義を無効化して、代替となるキーマップを利用するために overriding-*-mapというような名前の変数が用意されています。
キーマップは他のキーマップを敬称する(親とする)こともできるようです。 set-keymap-parent関数でキーマップに親マップを設定します。
2011年2月9日水曜日
CommonQtでコンテキストメニュー
CommonQtでコンテキストメニュー(右クリック時に出てくるメニュー)を出してみます。
(asdf:load-system :qt)
(defpackage :test
(:use :cl :qt)
(:export main))
(in-package :test)
(enable-syntax)
(defvar *qapp*)
(defclass test-window ()
((quit-action :accessor quit-action-of :initform nil)
(file-menu :accessor file-menu-of :initform nil))
(:metaclass qt-class)
(:qt-superclass "QMainWindow")
(:override
("contextMenuEvent" context-menu-event)))
(defmethod initialize-instance :after ((instance test-window) &key parent)
(if parent
(new instance parent)
(new instance))
(setf (quit-action-of instance)
(#_new QAction "&Quit" instance))
(#_setShortcut (quit-action-of instance)
(#_new QKeySequence (#_CTRL "Qt") (#_Key_Q "Qt")))
(#_connect "QObject"
(quit-action-of instance) (QSIGNAL "triggered()")
instance (QSLOT "close()"))
(let ((menu-bar (#_menuBar instance)))
(setf (file-menu-of instance)
(#_addMenu menu-bar "&File"))
(#_addAction (file-menu-of instance)
(quit-action-of instance))))
(defmethod context-menu-event ((instance test-window) event)
(let ((menu (#_new QMenu instance)))
(#_addAction menu (quit-action-of instance))
(#_exec menu (#_globalPos event))))
(defun main ()
(setf *qapp* (make-qapplication))
(let ((window (make-instance 'test-window)))
(#_setGeometry window 300 100 300 200)
(#_show window)
(unwind-protect
(#_exec *qapp*)
(#_hide window))))
メニューバーも出してみましたが、自分の環境だとショートカットがうまく動かなくいです。
2011年1月19日水曜日
CommonQtでHello world!
Common LispのQtバインディングであるCommonQtを触ってみました。 QtならマルチプラットフォームなのでどこでもGUIが使えます(たぶん)
Qtのチュートリアルにある以下のようなC++のコードは
// C++
#include <QApplication>
#include <QPushButton>
int main(int argc, char *argv[])
{
QApplication app(argc, argv);
QPushButton hello("Hello world!");
hello.resize(100, 30);
hello.show();
return app.exec();
}
このように書けるようです。
;; Common Lisp (CommonQt)
(asdf:load-system "qt")
(defpackage :qt-user
(:use :qt :cl)
(:export main))
(in-package :qt-user)
(named-readtables:in-readtable :qt)
(defun main ()
(let ((app (qt:make-qapplication)))
;; QPushButton は 大文字小文字を区別する
(let ((hello (#_new QPushButton "Hello world!")))
(#_resize hello 100 30)
(#_show hello)
(#_exec app))))
(main)
ほとんどC++のコードをそのまま直しても動かせそうで良い感じです。
登録:
投稿 (Atom)