KLab若手エンジニアの これなぁに?

KLab株式会社の若手エンジニアによる技術ブログです。phpやRubyなどの汎用LLやJavaScript/actionScript等のクライアントサイドの内容、MySQL等のデータベース、その他フレームワークまで幅広く面白い情報を発信します。

Scheme

メッセージパッシングを簡単にするSchemeマクロ

takada-atです。 前回の記事では、TwitterAPIを取得するライブラリを作成してみました。 その際にメッセージパッシングによる関数呼び出しを利用しましたが、どうも関数のディスパッチの部分が冗長に感じられます。 やりたいことは下のような感じです。 要するに、dispatch関数に、適切なシンボルをわたしたときに、それに応じて関数を呼び出してほしい。

(define (make-twitter-client username password)
  (define (some-function) ...)
  (define (some-function2) ...)
  ...
  (define (dispatch symbol . args)
      (cond ((eq? symbol 'some-function) (some-function))
            ((eq? symbol 'some-function2) (some-function2))))
dispatch)

PHPで書くと以下のようになります。要するに、引数にメッセージをわたして外からは呼べない関数を呼んでほしいわけです。

class SomeClass{
    public function dispatch($symbol){
        switch($symbol){
            case "some_function":
                some_function(); break;
            case "some_function2":
                some_function2(); break;
        }
    }
    private function some_function(){}
    private function some_function2(){}
}

しかし条件分岐を使った呼び出しはどうも冗長です。どうせ関数名をシンボルにわたしてそれを呼び出すだけなのだから、もっと簡単に書けないものでしょうか。 そこでSchemeのマクロに挑戦してみます。 マクロを使ったコード書き換えを利用すれば簡単な表記を実現できるはずです。 まず目標地点。以下のような書き方をめざします。 make-dispatcherマクロに、dispatcherから呼び出したい関数の名前をわたすだけ。

 (make-dispatcher func1 func2 func3)

そこで書いてみたのが以下のマクロです。

(define-syntax make-dispatcher
  (syntax-rules ()
    ;;引数が1つの場合
    ((_ f1)
     ;;以下のコードに置き換え
     (lambda (sym . args)
       (if (eq? sym 'f1)
           ;;シンボルとf1が等しいならf1を呼ぶ
           (apply f1 args)
           ;;等しくなければエラー
           (error "no such procedure"))))
    ;;引数が2つ以上の場合
    ((_ f1 f2 ...)
      ;;以下のコードに置き換え
       (lambda (sym . args)
         (if (eq? sym 'f1)
             ;;シンボルとf1が等しいならf1を呼ぶ
             (apply f1 args)
             ;;引数をへらして再帰
             (apply (make-dispatcher f2 ...) (cons sym args)))))
    ))

引数が1つの場合は簡単です。シンボルと関数名を比較し、同じなら呼び出す、違うならエラー。 引数が1つ以上の場合は、先頭の引数についてのみ比較を行ない、シンボルと関数名が違っている場合は、引数を1つへらして、もう1度make-dispatcherマクロを再帰的に呼び出しています。 これを使えばずっとシンプルに書くことができます。 今まで下のように書いていたのが、

  (define (dispatch symbol . args)
      (cond ((eq? symbol 'replies) (replies))
            ((eq? symbol 'friends-timeline) (friends-timeline))
            ((eq? symbol 'post) (apply post args))
            (else (error "no such procedure"))
            ))

こんなに短かくなるんです。

(make-dispatcher replies friends-timeline post)

SchemeでTwittet APIを取得

takada-atです。SchemeでTwitterのbotを作成しようと思い、TwitterAPIを取得するスクリプトを作成しました。 と言ってもAPIの種類も多いので、返信の取得やメッセージのポストなど、ごく簡単な部分だけ作ってみます。 Schemeの処理系としては、Gaucheを選びました。 http://practical-scheme.net/gauche/index-j.html HTTPリクエストを発行する部分は以下のようになっています。 認証のためにユーザー名とパスワード情報を Authorizationヘッダにセットします。

  (define (make-auth)
    (string-append "Basic "
                   (base64-encode-string
                    (string-append username ":" password))))
  (define (post message)
  ;;メッセージをポスト
    (http-post
     base-host
     (string-concatenate (list post-path
                         (uri-encode-string message)))
     ""
     :authorization (make-auth)))
ユーザー名とパスワードを指定して接続するために、「クロージャ」を利用した「メッセージパッシング」という技術を利用しています。 参考リンク: http://ja.wikipedia.org/wiki/クロージャ 関数「make-twitter-client」は、ユーザー名とパスワードを引数に与えて呼び出されると、新しい関数「twitter-client」をつくって返します。

(define (make-twitter-client username password)
  ...
  (define (twitter-client order . arg)
    (cond
     ((eq? order 'friends-timeline) (apply friends-timeline arg))
     ((eq? order 'post) (apply post arg))
     ((eq? order 'replies) (apply replies arg))))
twitter-client)
返された関数を、「'post」「'replies」などのメッセージを引数にわたして呼び出すと、twitterにリクエストを投げます。 使い方は以下のようになります。

(define cl (make-twitter-client "hogehoge" "hogepassword")) ;新しく作成した関数を変数 clに代入。
(cl 'replies) ;clにメッセージを渡して、repliesを取得。
「make-twitter-client」呼び出し時に作成された関数「twitter-client」は、定義された時点の環境を記憶しているため、「make-twitter-client」に渡された引数(ユーザー名, パスワード)を覚えています。 この変数スコープの性質を利用することで、ユーザー名やパスワードのような変数を、外からアクセスできないように隠蔽したまま利用することができます。 いわばオブジェクト指向プログラミングでいうプライベート変数のような機能を実現しています。 Gaucheのオブジェクトシステムはプライベートな変数をサポートしていませんが、クロージャを利用することで似た機能を実現できます。

(define-module twitter-client
  (use rfc.http)
  (use rfc.base64)
  (use rfc.uri)
  (use sxml.ssax)
  (use sxml.sxpath)
  (use srfi-13)
  (use srfi-19)
  (export make-status)
  (export make-status-from-result)
  (export make-twitter-client))
(select-module twitter-client)

(define (parse str)
  ;;xmlをsxmlに変換
  (call-with-input-string str
                          (lambda (io) (ssax:xml->sxml io '()))))
(define (make-status sxml)
  ;;statusのsxmlを扱いやすい形式にする
  (define (created_at)
    (string->date (cadr ((car-sxpath '(created_at)) sxml)) "~a ~b ~d ~H:~M:~S ~z ~Y"))
  (define (text)
    (cadr ((car-sxpath '(// text)) sxml)))
  (define (name)
    (cadr ((car-sxpath '(// name)) sxml)))
  (define (id)
    (cadr ((car-sxpath '(// id)) sxml)))
  (define (screen_name)
    (cadr ((car-sxpath '(// screen_name)) sxml)))
  (define (dispatch m . arg)
    ;; 'id, 'text, 'name, 'screen_name, 'created_atでそれぞれの情報を返す
    (cond ((eq? m 'id) (id))
          ((eq? m 'text) (text))
          ((eq? m 'name) (name))
          ((eq? m 'screen_name) (screen_name))
          ((eq? m 'created_at) (created_at))))
dispatch)

(define (make-status-from-result sxml)
  (map make-status ((sxpath '(// status)) sxml))
)

(define (make-twitter-client username password)
  (define base-host "twitter.com")
  (define friends-timeline-path "/statuses/friends_timeline.xml")
  (define post-path "/statuses/update.xml?status=")
  (define replies-path "/statuses/replies.xml")
  (define (make-auth)
    (string-append "Basic "
                   (base64-encode-string
                    (string-append username ":" password))))
  (define (friends-timeline)
    ;;friendのタイムラインを取得
    (parse (values-ref (http-get
     base-host
     friends-timeline
    :authorization (make-auth)) 2))
    )
  (define (replies)
    ;;自分宛ての返信を取得
    (parse (values-ref (http-get
     base-host
     replies-path
    :authorization (make-auth)) 2))
    )
  (define (post message)
    ;;メッセージをポスト
    (http-post
     base-host
     (string-concatenate (list post-path
                         (uri-encode-string message)))
     ""
     :authorization (make-auth)))
  (define (twitter-client order . arg)
    (cond
     ((eq? order 'friends-timeline) (apply friends-timeline arg))
     ((eq? order 'post) (apply post arg))
     ((eq? order 'replies) (apply replies arg))))
twitter-client)


(provide "twitter-client")
 KLab若手エンジニアブログのフッター