[CommonLisp]Internal Server Errorをフックする

Web系がさっぱりわからないので、勉強がてらなにか書いてみようと思いました。
 Webアプリケーションを書く前に、プログラム中で発生した例外をフックして、Internal Server Errorとしてブラウザに表示させるようにしてみます。

(asdf:load-system :clack)
;; swank:backtraceのほうがみやすい?
(asdf:load-system :trivial-backtrace)

(defpackage :mw-debug
  (:use :cl :clack))

(in-package :mw-debug)

(defun mw-debug-debugger-hook (c hook)
  (declare (ignore hook))
  (let ((restart (find-restart 'mw-debug-restart)))
    (when (not restart)
      (error "mw-debug-restart not found"))
    (invoke-restart restart c (trivial-backtrace:print-backtrace c :output nil))))

(defclass <mw-debug> (<middleware>)
  ())

(defmethod call ((this <mw-debug>) env)
  (let ((*debugger-hook* #'mw-debug-debugger-hook))
    (restart-case (call-next this env)
      (mw-debug-restart (c bt)
 `(500
   (:content-type "text/plain")
   (,(format nil "Internal Server Error~%~%")
     ,(format nil "-- Error -------------------------------~%")
     ,(with-output-to-string (*standard-output*)
       (describe c))
     ,(format nil "-- Backtrace ---------------------------~%")
     ,bt))))))

(defun b (tmp)
  ;; 未定義の関数を呼び出す。
  (c))
(defun a ()
  (b 2))
(defun run (port)
  (clackup
   (wrap (make-instance '<mw-debug>)
  (lambda (env)
    (a)))
   :port port))

;; (run 9999)

[Gauche]CiSEでFizzBuzz

CiSE(C in S-Expression)でFizzBuzzってみます。

;; cise-compile.scm
(use gauche.cgen)
(use gauche.cgen.cise)
(use gauche.parseopt)

(define (main args)
  (let-args (cdr args)
    ((infile "i=s" #f)
     (outfile "o=s" #f))

    (unless (and infile outfile)
      (display #`"usage: gosh ,(car args) -i 'input-file' -o 'output-file'\n")
      (exit -1))
    
    (call-with-input-file infile
      (^ (in)
  (call-with-output-file outfile
    (^ (out)
       (cise-translate in out)))))))

;; cise-test.cise
(.include <stdio.h>)

(define-cfn main (argc::int argv::char**) ::int
  (dotimes (i 30)
    (case (% (+ i 1) 15)
      ((0) (printf "FizzBuzz\n"))
      ((3 6 9 12) (printf "Fizz\n"))
      ((5 10) (printf "Buzz\n"))
      (else (printf "%d\n" (+ i 1)))))
  (return 0))

 > gosh cise-compile.scm -i cise-test.cise -o cise-test.c
 > gcc -o cise-test cise-test.c

[CommonLisp]MOPを使って型指定子によりメソッドを特定する

Wikipedia日本語版の「列挙型」の項目に、CommonLispの型指定子はメソッドの引数特定には使えませんよ、と書いてあったので、無理やり実現する方法を考えてみました。
マクロを使うと負けな気がするので、MOPを利用してみます。

(asdf:load-system :closer-mop)

(defpackage type-spec-class
  (:use :cl)
  (:export
    <type-spec-meta>
    <type-spec-gf>
    define-type-spec))

(in-package :type-spec-class)

(defclass <type-spec-meta> (c2mop:standard-class)
  ((spec :initarg :spec :reader type-spec-of)))

(defmethod c2mop:validate-superclass ((cls <type-spec-meta>)
          (super c2mop:standard-class))
  t)

(defclass <type-spec-gf> (c2mop:standard-generic-function)
  ()
  (:metaclass c2mop:funcallable-standard-class))

(defmethod c2mop:validate-superclass ((cls <type-spec-gf>)
          (super c2mop:standard-generic-function))
  t)

(defmacro define-type-spec (name spec)
  `(progn
     (deftype ,name () ,spec)
     (c2mop:ensure-class-using-class
      (make-instance '<type-spec-meta> :spec ,spec)
      ',name)))

(defmethod c2mop:compute-discriminating-function :around
    ((gf <type-spec-gf>))
  (let ((org-fn (call-next-method)))
    (lambda (&rest args)
      (let* ((methods (c2mop:generic-function-methods gf))
             (m (find-type-spec-method methods args)))
       (if m
         (apply (c2mop:method-function m) args)
         (apply org-fn args))))))

(defun find-type-spec-method (methods args)
  (loop
     :for m in methods
     :for s = (c2mop:method-specializers m)
     :do (when (applicable-type-spec-method-p s args)
           (return-from find-type-spec-method m))))

(defun applicable-type-spec-method-p (specifier args)
  (flet ((type-spec-class-p (cls)
    (subtypep (class-of cls) '<type-spec-meta>)))
    (when (some #'type-spec-class-p specifier)
      (loop
        :for cls in specifier
        :for a in args
        :do (unless (or (and (type-spec-class-p cls)
                             (typep a (type-spec-of cls)))
                        (typep a cls))
              (return-from applicable-type-spec-method-p nil)))
      t)))

以下のようにして使います。

(in-package :cl-user)

(type-spec-class:define-type-spec color '(member :red :blue :green))

(defgeneric what-is (obj)
  (:generic-function-class type-spec-class:<type-spec-gf>))

(defmethod what-is ((obj t))
  "unknown")
  
(defmethod what-is ((obj symbol))
  "symbol")

(defmethod what-is ((obj color))
  (format nil "color ~A" obj))

(what-is :red)
;; => "color RED"
(what-is :hoge)
;; => "symbol"
(what-is 2)
;; => "unknown"
 

<type-spec-meta>のインスタンス(であるクラスのインスタンス)を引数にとるメソッドは通常のメソッドよりも優先度が高くなっていますが、 最初に見つかったものを呼び出しているだけなので、<type-spec-meta>のインスタンス間での優先度は扱っていません。

[graphviz]consセルを描く

graphviz(DOT言語)についてのメモ。
(a (b . c) d) という内容のコンスセルを描画してみます。

// (a . ((b . c) . (d . nil)))
// (a (b . c) d)
digraph {
  graph [rankdir = LR]; // 横向き

  // ノードの定義。
  // record型にするとlabelをバー(|)で区分けできる。
  // {}で囲うと並べる向きを変えられる。
  // 先頭を<xxx>とすると要素への接続ポート名を定義できる。
  cons1 [shape = record, label = "{a|*}"];
  cons2 [shape = record, label = "{*|*}"];
  cons3 [shape = record, label = "{b|c}"];
  cons4 [shape = record, label = "{d|nil}"];

  // コロン区切りで接続ポートを指定することで、
  // エッジの指す先が要素の位置になる。
  cons1:cdr -> cons2:car;
  cons2:car -> cons3:car;
  cons2:cdr -> cons4:car;

  // ノードcons2とcons3を同じランク(並ぶ位置)にする
  {rank = same; cons2; cons3}; 
}

ファイル"cell.dot"に保存して、以下のコマンドで画像ファイルを作成できます。

 > dot -Tpng cell.dot > cell.png

作成される画像は以下。

[Racket]スタンドアローンな実行ファイルを作成する

Racketで作成したプログラムをパッケージ化したり実行ファイルにしたりするには、Racketのインストール時についてくるracoというツールを使います。
たとえば、画面に"はろーわーるど"と表示するだけのGUIプログラムを書いてみます。

#lang racket

(require racket/gui/base)

(define top-level
  (new frame%
       [label "GUI Test"]
       [min-width 200]))

(define hello
  (new message%
       [parent top-level]
       [label "はろーわーるど"]
       [min-height 20]))

(send top-level show #t)

このソースコードのファイル名を"guitest.rkt"すると、コマンドラインから

> racket guitest.rkt

と入力すれば実行できます。

このソースコードを実行ファイルにする場合は、racoコマンドを実行します。

> raco exe --gui guitest.rkt

raco exeコマンドの実行結果として、"guitest.exe"という実行ファイルが作成されます。(Windowsの場合)
さらに、実行ファイルを他のマシンでも実行できるようにするために再度racoコマンドを実行します。

> raco distribute dirname guitest.exe

raco distributeコマンドの実行結果として、"dirname"ディレクトリが作成され、ディレクトリ以下には"guitest.exe"と必要なライブラリ類がまとめられます。
これで、"dirname"ディレクトリの内容を他のマシンにコピーして実行可能となります。(たぶん)

参考：

• raco exe :  http://docs.racket-lang.org/raco/exe.html
• raco distribute : http://docs.racket-lang.org/raco/exe-dist.html