xyzzy から sqlite を使う

一応できたわけですが。

(setq test-home "\path\to\test")
=>"\path\to\test"
(setq test-db (merge-pathnames "test.db" test-home))
=>"\path\to\test\test.db"
(sqlite3 test-db "select date('now')")
date('now') = 2009-04-26
=>0
(sqlite3 test-db "create table tbl1(one varchar(10), two smallint);")
=>0
(sqlite3 test-db "insert into tbl1 values('hello!',10);")
=>0
(sqlite3 test-db "insert into tbl1 values('goodbye', 20);")
=>0
(sqlite3 test-db "select * from tbl1;")
one = hello!
two = 10
one = goodbye
two = 20
=>0

色々と危険なコードになってしまいました。良い子はまねしちゃいけませんね。

やっぱり、 C 言語でヘルパーを作るべきか。

(require "foreign")

(c:*define-c-type c:u_int c-pointer)

(c:*define-dll-entry
  (c:void *) memcpy ((c:void *) (c:void *) c:u_int)
  "msvcrt.dll" "memcpy")

(c:*define-dll-entry
  c:int sqlite3-open ((char *) ((c:void *) *))
  "sqlite3.dll" "sqlite3_open")

(c:*define-dll-entry
  (char *) sqlite3-errmsg ((c:void *))
  "sqlite3.dll" "sqlite3_errmsg")

(c:*define-dll-entry
  c:int sqlite3-close ((c:void *))
  "sqlite3.dll" "sqlite3_close")

;; int sqlite3_exec(
;;   sqlite3*,                                  /* An open database */
;;   const char *sql,                           /* SQL to be evaluated */
;;   int (*callback)(void*,int,char**,char**),  /* Callback function */
;;   void *,                                    /* 1st argument to callback */
;;   char **errmsg                              /* Error msg written here */
;; );
(c:*define-dll-entry
  c:int sqlite3-exec
  ((c:void *) (char *) (c:void *) (c:void *) ((c:void *) *))
  "sqlite3.dll" "sqlite3_exec")

(c:*define-dll-entry
  c:void sqlite3-free ((c:void *))
  "sqlite3.dll" "sqlite3_free")

(defconstant c-pointer-size 4)
(defconstant msg-size 256)

(defun make-c-pointer ()
  (si:make-chunk nil c-pointer-size))

(defun unpack-c-pointer (pp)
  (si:unpack-uint32 pp 0))

(defun get-c-argv (arg-pos argv)
  (let* ((v** (make-c-pointer))
         (rc (memcpy v**
                     (+ argv (* arg-pos c-pointer-size))
                     c-pointer-size)))
    (let* ((v* (si:make-chunk nil msg-size))
           (rc (memcpy v* (unpack-c-pointer v**) msg-size))
           (v (si:unpack-string v* 0 msg-size)))
      v
      )))

(c:*defun-c-callable
  c:int callback
  (((c:void *) NotUsed)
   (c:int argc)
   (((char *) *) argv)
   (((char *) *) azColName))
  (let ((rc 0))
    (handler-case
        (do ((i 0 (+ i 1)))
            ((>= i argc))
          (let ((colname (get-c-argv i azColName))
                (colv (get-c-argv i argv)))
            (format t "~A = ~A~%" colname colv)))
      (error (c)
        (format t "~A~%" (si:*condition-string c))))
    rc))

(defun sqlite3 (fname sql)
  (let* ((fname* (si:make-string-chunk fname))
         (db* (make-c-pointer))
         (rc (sqlite3-open fname* db*))
         (db (unpack-c-pointer db*)))
    (if (not (eql rc 0))
        (let* ((errmsg** (sqlite3-errmsg db))
               (errmsg* (si:make-chunk nil msg-size))
               (rc (memcpy errmsg* errmsg** msg-size))
               (errmsg (si:unpack-string errmsg* 0 msg-size)))
          (format t "Can't open database: ~A~%" errmsg)
          (let ((rc (sqlite3-close db)))
            rc))
      (let* ((sql* (si:make-string-chunk sql))
             (errmsg** (make-c-pointer))
             (rc (sqlite3-exec db sql* #'callback 0 errmsg**)))
        (if (not (eql rc 0))
            (progn
              (format t "Error: ~A~%" rc)
              (let* ((errmsg* (si:make-chunk nil msg-size))
                     (rc (memcpy errmsg* (unpack-c-pointer errmsg**) msg-size))
                     (errmsg (si:unpack-string errmsg* 0 msg-size)))
                (format t "~A~%" errmsg))
              (sqlite3-free (unpack-c-pointer errmsg**))
              (let ((rc (sqlite3-close db)))
                rc))
          (let ((rc (sqlite3-close db)))
            rc)
          )))))

RDBMS の制約の使い方

制約というのは、一意性制約、参照整合性制約、チェック制約などのことです。

個人的には、 RDBMS の制約の典型的な使い方は、 トランザクションの並行実行によって発生する、競合状態 ( race condition ) の検出に使う、というものだと考えてまして。アプリケーション側で、レコード・ロックだの、テーブル・ロックだのやるくらいなら、 RDBMS に任せてしまうが良い、と考えています。

簡単なので、一意性制約の例を挙げますと。単に、テーブルに、値が重複してはならないフィールドの集まりがあるわけですな。

そうすると、2つ以上のトランザクションが、この制約を満たすために、テーブルに既に値があるかどうかを、 SELECT で確認して、それからレコードを INSERT するなり、 UPDATE するなりする、という状況が起きる。 いわゆる、 check-then-act な競合状態が起きるわけです。

ここで、アプリケーション側で RDBMS のロック機能を使って atomic にするというのは、あまりよろしくない。 RDBMS にこんな地雷を埋め込んでいると、新しくリリースされたアプリケーションが、同じ RDBMS を使って、デッド・ロック起こしたり、パフォーマンス障害を起こすのは時間の問題と考えて良いでしょう。

ですので、素直にテーブルのフィールドに一意性制約をつけて、 RDBMS に重複を検出させるのがよろしかろうと思います。 もちろん、アプリケーションのデータ・チェックで、重複回避のために値の存在確認はさせるべきです。RDBMS の制約は、あくまで競合状態の検出にのみ使います。

当然のことながら、 制約を安易に多用しますと、RDBMS 内でロックを多発させることになって、パフォーマンス劣化を引き起こします。 RDBMS の制約は、並行処理の設計の問題であって、単なる RDBMS の便利機能ではありません。アプリケーションのデータ・チェックの代用にはなりませんので、悪しからず。

制約違反が大量発生して RDBMS がとてつもなく遅くて困るって？

アプリケーションが、データ・チェックをさぼってないか、確認してください。本当にそれらの制約が必要なのか、もう一度よく検討してください。

もしそれが、競合状態の多発を意味しているのであれば、根本的にシステムの設計がまずい可能性があります。非同期にして直列処理することを考慮しましょう。ハードウエアのキャパシティ不足であるなら、ハードウエアの増強を検討しましょう。

Git はク○？

現実問題として、 Windows でも使えないと駄目ですよね。

Gitを作った人ってバカなの？ - L'eclat des jours (2009-04-18)

とはいえ、 Subversion のマージのヘボさは、ブランチという概念を無意味にしている、というのも当たっていると思います。経験上、同一ファイルが競合したときには、ほとんどが失敗しますので。そのたび、 diff とって patch とかやってると、一体自分は何をやっているんだろう、という気分になってくる。

ということで。

DSAS開発者の部屋:Bazaarの紹介

私は、ここで紹介されている Bazaar も使っていたりします。 Windows と Linux 両方に入れてます。

Bazaar User Guide: 8.2 bzr-svn

ここにあるように、 trunk を Subversion にして、 Bazaar でローカルにブランチ作ってます。マージは、いまのところ失敗したことがない。結構快適。

Launchpad という、 GitHub のようなものもあるらしい。

Launchpad can host your project's source code using the Bazaar version control system.

Launchpad Code: Code in branches

Git のサポートもやろうとしているらしい。

BzrForeignBranches/Git - Bazaar Version Control

インストールは、まあカンタンでした。 Windows はインストーラで、 Linux は TarBall から。 Python を要求されるのを愛嬌と思えるかどうかですかね。 後、 Windows 版には TortoiseBazaar というのが付いてきますが、イマイチ使えないのでパスするのも愛嬌。

Tortoise 系は、 Windows エクスプローラにアドインされるのをメリットと考えるか、デメリットと考えるか微妙なところがありますね。使いやすいのは確かなので、 TortoiseSVN など、他の人には使うように薦めている一方、自分ではあまり使ってなかったりする。 Windows がなんか重くなるし、ファイル・ディレクトリがロックされたりするのがイヤだから。

CLAZY であるべきか

元は SICP です。

CLAZY: Lazy Calling in Common Lisp

お試しのソースコード：

(defmacro delay (expr) `(lambda () ,expr))
(defun force (thunk) (funcall thunk))
(defmacro cons-stream (head tail) `(cons ,head (delay ,tail)))
(defun head (lazy-stream) (car lazy-stream))
(defun tail (lazy-stream) (force (cdr lazy-stream)))

(defun make-plus-stream (x y)
  (cons-stream
   x
   (make-plus-stream (+ x y) y)))

(defun take-and-prn (stm b)
  (defun iter (s i)
    (if (>= i b) 'done
    (progn
      (format t "~A~%" (head s))
      (iter (tail s) (+ i 1)))))
  (iter stm 0))

こんな風に無限で遊べます：

(setq stm (make-plus-stream 1 1))
=>(1 . #<lexical-closure: (anonymous)>)
(take-and-prn stm 5)
1
2
3
4
5
=>done
(setq stm (make-plus-stream 1 2))
=>(1 . #<lexical-closure: (anonymous)>)
(take-and-prn stm 5)
1
3
5
7
9
=>done

そうか、xyzzy.ini があったか

これで色の設定がとれますね。

(require "foreign")
(require "wip/winapi")
(c:define-dll-entry
  winapi:DWORD GetPrivateProfileString
  (winapi:LPCSTR
   winapi:LPCSTR
   winapi:LPCSTR
   winapi:LPSTR
   winapi:DWORD
   winapi:LPCSTR)
  "kernel32" "GetPrivateProfileStringA")

(defun read-ini-file (ini-f sect key default)
  (let ((csize 256))
    (let ((ini-f* (si:make-string-chunk ini-f))
          (sect* (si:make-string-chunk sect))
          (key* (si:make-string-chunk key))
          (default* (si:make-string-chunk default))
          (ret-v* (si:make-chunk nil csize)))
    (let ((ret-api-v
           (GetPrivateProfileString
            sect* key* default* ret-v* csize ini-f*)))
      (si:unpack-string ret-v* 0 ret-api-v)))))

(defun get-user-config-file-path ()
  (let ((ini-f (si:getenv "XYZZYINIFILE"))
        (ini-f-def (merge-pathnames "xyzzy.ini" (user-config-path))))
    (if (not ini-f)
        ini-f-def
      (if (not (file-exist-p ini-f))
          (if (pathname-device ini-f)
              ini-f-def
            (progn
              (setq ini-f (merge-pathnames ini-f (user-config-path)))
              (if (file-exist-p ini-f)
                  ini-f
                ini-f-def)))
        ini-f)
      )))

(defun test-read-user-config ()
  (let ((ini-f (get-user-config-file-path)))
    (read-ini-file ini-f "Colors" "kwdColor1" "")))

実行結果：

(test-read-user-config)
=>"#ff0000"

ソフトウエアの「消費コスト」

というのか、何かそんな概念について。

「ソフトウェア工場はうまくいかないんですね。なぜなら部品の組み立てに相当するものが、アップロードとかDVDに焼くといった工程ぐらいしか存在せず、効率化しようないからです」。

「ソフトウェアは工業製品ではない」 Rubyのまつもと氏が講演 ＠IT

確かに、計算機プログラムの「製造」工程というのは、ソース・コードのビルドであり、サーバへのアップ・ロードであり、 CD/DVD への書き込みであったりして、製造コストは限りなくゼロに近い − 少なくとも「設計」にかかるコストに比べれば − とは思うのですが。

しかし、計算機プログラムには、「設計」以外にも大きなコストが存在すると思うのですよね。

例えば、計算機プログラムを音楽 CD のようなものと比較した場合、大きな違いがあって、それはユーザの「消費コスト」というのか、「使用コスト」のようなものの存在だと思います。つまり、計算機プログラムの入った CD を買ってきて、 PC の CD-ROM ドライブにセットして、「再生」ボタンを押せば、即座に「消費」可能 − ユーザがその製品の付加価値を得ることが出来る − かといえば、否なんですよね。

ユーザが計算機プログラムを入手してから、ユーザがそのソフトウエアの付加価値を享受するまでには、通常、長い道程があるわけです。何百ページだか何千ページだかあるマニュアルと格闘しつつ、ソフトウエアをインストールし、ソフトウエアの使い方を学び、様々な設定をほどこし、データを入力し、そして、ちょっとしたプログラムを書く必要があったりするわけです。

かくして、この大きな労力を必要とする仕事を、ユーザの代わりに行い、ユーザがソフトウエアを使えるような状態にまで持っていく（ターン・キー）、というビジネスが生まれたわけでして。いわゆる SIer と呼ばれる産業です。

こうした、ソフトウエア・ベンダー、ハードウエア・ベンダーから、ユーザまでの「ラスト・ワン・マイル」 − 現状はワン・マイルどころではなさそうに思いますが − を担当する仕事というのが、それなりに大きな産業として存在しているわけです。

そこで感じたのは、現場の科学者が「明日にでも計算したい問題を抱えている」ということは、観念として理解されることはあっても、実感としてはわかってもらえないらしいということであった。彼の答えは、逆に、私の専用機を作るという火に油を注ぐことになった。やはり、自分でやるしかないのである。

杉本大一郎, 『手作りコンピュータへの挑戦 テラ・フロップス・マシンをめざして』, 講談社 ブルーバックス B-956, 1993

上に引用したのは、かの GRAPE 計算機の開発話ですが。著者が、計算機メーカー、計算機科学者への愚痴（？）のようなものを書いています。それは、計算機メーカーや計算機科学者は、「汎用」の問題を解くことにばかり熱心で、科学者の抱えている個別の問題には関心を持ってくれない、といったことです。

これは、計算機ビジネスの構造的要因から来ていると思うのですよね。つまり、ソフトウエアにしろ、ハードウエアにしろ、ベンダーは可能な限り多くのユーザを獲得しなければならないわけでして（業界では「ユーザ・ベース」とかいってますね）。そうすると、システムは可能な限り「汎用」に作る必要が出てきます。特定の問題にフォーカスしても、それこそ、特定の少数のユーザしか得られませんからね。

しかし、「汎用」なシステムを、ユーザが自分の問題解決に使おうとすると、あれこれと自分で作業をする必要が出てくるわけです。このジレンマが解消する日が、いつかは来るのでしょうかね？

命令的な Lisp

xyzzy で htmlize.el 的なものが欲しいと思いまして。

ソースコードを漁っていたのですけど、テキストの色を lisp から取得する方法はなさそうでした。それで、トークンの種類を取ることはできるようなので、これを使って色を付ければ良いかと考えました。

トークンの種類をとるコードを、試しに書いてみたわけですが。

色々と、 xyzzy lisp のソースコード読んでいるうちに、これは命令的に書く方が良いのかな、と思い始めまして。再帰の代わりにループと破壊的代入を使って、命令的 lisp で書いてみることにしました。

書いてみて、こういうコードは、なんか見ていてホッとするなあ、と思ったり。長年の習慣というのは、すっかり染み付いてますね。

(defun test-token (b)
  (interactive "bBuffer:")
  (with-open-stream (os (get-buffer-stream-o *foobar-output-buffer-name*))
    (set-buffer b)
    (save-excursion
      (let ((token nil)
            (s "")
            (pos 0))
        (while (< pos (point-max))
          (multiple-value-setq (token s pos) (get-token pos))
          (format os "~A ~A ~A~%" token s pos)
          )
        ))))

(defun get-buffer-stream-o (bname)
  (let ((b (get-buffer-create bname)))
    (erase-buffer b)
    (make-buffer-stream b)))

(defun get-token (pos)
  (let ((c (char-after pos)))
    (cond ((syntax-string-p c)
           (let ((s (string c))
                 (syn :string))
             (setq pos (+ pos 1))
             (setq c (char-after pos))
             (while
                 (and (< pos (point-max))
                      (eq syn :string))
               (setq s (concat s (string c)))
               (setq pos (+ pos 1))
               (setq c (char-after pos))
               (setq syn (parse-point-syntax pos)))
             (values 'string s pos)))
          ((or (syntax-word-p c)
               (syntax-symbol-p c))
           (let ((s ""))
             (while
                 (and (< pos (point-max))
                      (or (syntax-word-p c)
                          (syntax-symbol-p c)))
               (setq s (concat s (string c)))
               (setq pos (+ pos 1))
               (setq c (char-after pos)))
             (values 'word s pos)))
          (t (values 'other (string c) (+ pos 1))))
    ))

Float 遊び

ソースコード：

/*
   float_play1.c

   see:
   http://msdn.microsoft.com/ja-jp/library/c9676k6h.aspx
*/

#include <stdio.h>
#include <float.h>

void print_fvalue(float v) {
  /*
    IEEE754 単精度
    ビット数： 符号 1 , 指数 8, 仮数 23
    仮数 先頭 1 ビットは省略される。
    指数 下駄(bias）は 127。
  */
  float *pfv = &v;
  unsigned int *piv = (unsigned int*)pfv;
  printf_s("[0] %x\n", *piv);
  printf_s("[1] %x\n", *piv >> 31);
  printf_s("[2] %d\n", (*piv << 1 >> 24) - 127);
  printf_s("[3] %x\n", *piv << 9 >> 8);
}

float get_test_fvalue() {
  float v;
  v = 0.1f;
  v = v * 10.0f;
  v = v / 10.0f;
  return v;
}

int test(unsigned int newControl,
         unsigned int mask) {
  unsigned int currentControl;
  errno_t err;
  float v;

  err = _controlfp_s(&currentControl, newControl, mask);
  if (err != 0) {
    printf_s("_controlfp_s failed!\n");
    return err;
  } else {
    v = get_test_fvalue();
    print_fvalue(v);
    if (v == 0.1f)
      printf_s("No problem?\n");
    else
      printf_s("Ouch!\n");
    return 0;
  }
}

int main() {
  int err;

  err = test(_RC_CHOP, _MCW_RC);
  if (err != 0) {
    return err;
  }
  err = test(_RC_UP, _MCW_RC);
  if (err != 0) {
    return err;
  }
  err = test(_RC_DOWN, _MCW_RC);
  if (err != 0) {
    return err;
  }
  err = test(_RC_NEAR, _MCW_RC);
  if (err != 0) {
    return err;
  }
  return 0;
}

ビルド：

>cl float_play1.c
Microsoft(R) 32-bit C/C++ Optimizing Compiler Version 15.00.30729.01 for 80x86
Copyright (C) Microsoft Corporation.  All rights reserved.

float_play1.c
Microsoft (R) Incremental Linker Version 9.00.30729.01
Copyright (C) Microsoft Corporation.  All rights reserved.

/out:float_play1.exe
float_play1.obj

実行：

>float_play1.exe
[0] 3dcccccc
[1] 0
[2] -4
[3] 999998
Ouch!
[0] 3dcccccf
[1] 0
[2] -4
[3] 99999e
Ouch!
[0] 3dcccccc
[1] 0
[2] -4
[3] 999998
Ouch!
[0] 3dcccccd
[1] 0
[2] -4
[3] 99999a
No problem?

アセンブリ リスト より：

 fld DWORD PTR _v$[ebp]
 fcomp QWORD PTR __real@3fb99999a0000000
 fnstsw ax
 test ah, 68     ; 00000044H
 jp SHORT $LN2@test

つまり：

/* ただそれだけのこと。 */

参考：

浮動小数点演算ではまった話 - bkブログ

Packrat Parsing を調べてみる (その2)

遅延評価だから、一部が自分自身によって構築されるデータを、関数に渡しても無問題である、ということですかね。かつ、必要なデータは、その都度、芋づる式に評価されて構築されていくと。

例でいえば、最初に評価されるもの、”トリガー”になるのは、 先頭の dvAdditive でしょう。

つまり：

calc :: String -> Int
calc s = g $ parse s where
  g d = case dvAdditive d of
    Parsed v d' -> v

などとして：

*Main> calc "2*(3+4)"
14

これで、 parse 関数の、 add = pAdditive d の評価が開始します。

parse s = d
d = Derivs add mult prim dec chr
add = pAdditive d

pAdditive の中に入って、 dvMultitive d の評価が開始します。

add = pAdditive d
dvMultitive d

dvMultitive d は、 mult = pMultitive d ですから、 pMultitive の中にはいって、 dvPrimary d の評価が開始します。

add = pAdditive d
dvMultitive d
dvPrimary d

同様に、 dvDecimal d の評価が開始します。

add = pAdditive d
dvMultitive d
dvPrimary d
dvDecimal d

ここまでで、 dvChar d が 2文字分評価されて：

dvChar d = Parsed '2' d'
dvChar d' = Parsed '*' d''
dvDecimal d = Parsed 2 d'
dvPrimary d = Parsed 2 d'

pMultitive まで戻って、 ”2 *” までが読み込まれ、 再び pPrimary へ：

pMultitive d
dvPrimary d'' = pPrimary d''

ここで、 dvChar d'' が評価されて、 pAdditive へ：

dvChar d'' = Parsed '(' d'''
dvAdditive d''' = pAdditive d'''

再び pAdditive からの評価を通って：

dvChar d''' = Parsed '3' d''''
dvChar d'''' = Parsed '+' d'''''
dvDecimal d''' = Parsed 3 d''''
dvPrimary d''' = Parsed 3 d''''
dvMultitive d''' = Parsed 3 d''''
dvChar d''''' = Parsed '4' d''''''
dvDecimal d''''' = Parsed 4 d''''''
dvPrimary d''''' = Parsed 4 d''''''
dvMultitive d''''' = Parsed 4 d''''''
dvAdditive d''' = Parsed 7 d''''''

pPrimary まで戻って：

dvChar d'''''' = Parsed ')' d'''''''
dvPrimary d'' = Parsed 7 d'''''''

pMultitive まで戻って：

dvMultitive d = Parsed 14 d'''''''

最初の pAdditive まで戻る：

dvAdditive d = Parsed 14 d'''''''

なるほど〜。巧妙ですねえ。

Packrat Parsing を調べてみる

このペーパーです。

Bryan Ford Packrat Parsing: Simple, Powerful, Lazy, Linear Time (PDF). ICFP, October 2002.

Haskell の実装例が載っているのですが、これがよくわからない。

parse :: String -> Derivs
parse s = d where
  d = Derivs add mult prim dec chr
  add = pAdditive d
  mult = pMultitive d
  prim = pPrimary d
  dec = pDecimal d
  chr = case s of
    (c:s') -> Parsed c (parse s')
    [] -> NoParse

なんじゃこりゃ？

どう評価されるんだろ？ d のところの動きが謎ですね。

ペーパーには、以下のコードが載っています：

data Derivs = Derivs {
  dvAdditive :: Result Int,
  dvMultitive :: Result Int,
  dvPrimary :: Result Int,
  dvDecimal :: Result Int,
  dvChar :: Result Char}

data Result v = Parsed v Derivs | NoParse

pAdditive :: Derivs -> Result Int
pMultitive :: Derivs -> Result Int
pPrimary :: Derivs -> Result Int
pDecimal :: Derivs -> Result Int

pAdditive d = alt1 where
  alt1 = case dvMultitive d of
    Parsed vleft d' ->
      case dvChar d' of
        Parsed '+' d'' ->
          case dvAdditive d'' of
            Parsed vright d''' ->
              Parsed (vleft + vright) d'''
            _ -> alt2
        _ -> alt2
    _ -> alt2

  alt2 = dvMultitive d

この続きを書いてみる。

pMultitive d = alt1 where
  alt1 = case dvPrimary d of
    Parsed vleft d' ->
      case dvChar d' of
        Parsed '*' d'' ->
          case dvPrimary d'' of
            Parsed vright d''' ->
              Parsed (vleft * vright) d'''
            _ -> alt2
        _ -> alt2
    _ -> alt2

  alt2 = dvPrimary d

pPrimary d = alt1 where
  alt1 = case dvChar d of
    Parsed '(' d' ->
      case dvAdditive d' of
        Parsed v d'' ->
          case dvChar d'' of
            Parsed ')' d''' ->
              Parsed v d'''
            _ -> alt2
        _ -> alt2
    _ -> alt2

  alt2 = dvDecimal d

pDecimal d = pDi where
  pDi = case pDs "" d of
    Parsed "" d' -> NoParse
    Parsed v d' -> Parsed (read v) d'
    _ -> NoParse
  pDs cs d = case dvChar d of
    Parsed c d' ->
      if isD c
      then pDs (cs ++ [c]) d'
      else Parsed cs d
    _ -> Parsed cs d
  isD c = c `elem` "0123456789"

とりあえず。

>ghci
   ___         ___ _
  / _ \ /\  /\/ __(_)
 / /_\// /_/ / /  | |      GHC Interactive, version 6.4.2, for Haskell 98.
/ /_\\/ __  / /___| |      http://www.haskell.org/ghc/
\____/\/ /_/\____/|_|      Type :? for help.

Loading package base-1.0 ... linking ... done.
Prelude> :load packrat1.hs
Compiling Main             ( packrat1.hs, interpreted )
Ok, modules loaded: Main.
*Main> parse "2*(3+4)"

Top level:
    No instance for (Show Derivs)
      arising from use of `print' at Top level
    Probable fix: add an instance declaration for (Show Derivs)
    In a 'do' expression: print it

Show の instance がないと表示できません、か。

Haskell Hierarchical Libraries > Prelude > Converting to String (haskell.org)

を参考にして、 Show の instance を書きます。

instance (Show a) => Show (Result a) where
  showsPrec prec (Parsed v d) =
    showParen (prec > app_prec) $
      showString "Parsed " .
      showsPrec (app_prec + 1) v .
      showsPrec (app_prec + 1) d
    where app_prec = 10
  showsPrec prec NoParse =
    showParen (prec > app_prec) $
      showString "NoParse"
    where app_prec = 10

instance Show Derivs where
  showsPrec prec (Derivs add mult prim dec chr) =
    showParen (prec > app_prec) $
      showString "Derivs " .
      showsPrec (app_prec + 1) add .
      showsPrec (app_prec + 1) mult .
      showsPrec (app_prec + 1) prim .
      showsPrec (app_prec + 1) dec .
      showsPrec (app_prec + 1) chr
    where app_prec = 10

こんなんで良いのでしょうか。

*Main> parse "2*(3+4)"
Derivs (Parsed 14(Derivs (NoParse)(NoParse)(NoParse)(NoParse)(NoParse)))(Parsed
14(Derivs (NoParse)(NoParse)(NoParse)(NoParse)(NoParse)))(Parsed 2(Derivs (NoPar
se)(NoParse)(NoParse)(NoParse)(Parsed '*'(Derivs (Parsed 7(Derivs (NoParse)(NoPa
rse)(NoParse)(NoParse)(NoParse)))(Parsed 7(Derivs (NoParse)(NoParse)(NoParse)(No
... まだまだいっぱい。

うへえ。括弧地獄。

でも、一応 14 って答えが出てますね。