R5RSの数値リテラルっぽいものをGaucheのparser.pegでパーズした

R5RSの数値リテラルのサブセットを拡張したもののパーザをparser.pegで書いた．具体的には小文字しか使えないのと 123### を削って小数を10進以外でも書けるようにした感じ．あと36進数と指数マーカに^を追加．
parser.pegはundocumentedでよく分からないので手探り．
参考にしたのはこの記事: http://practical-scheme.net/wiliki/wiliki.cgi?Rui%3AParsingExpressionGrammarと parser.peg のソース(…はあんまり読んでないけど)．
Gauche 0.9.3.3 を使用．
6/8 14:47 細かいバグ修正

(use parser.peg)
(use util.match)

(define-syntax $seq0
  (syntax-rules ()
    ((_ p ps ...)
     ($do (temp p) (ps) ... ($return temp)))))

(define ($>> p value)
  ($<< (^_ value) p))

(define parse-number
  (let* ((sharp ($c #\#))
         (dot ($c #\.))
         (exactness-prefix ($optional
                            ($seq sharp
                                  ($or ($>> ($c #\e) exact)
                                       ($>> ($c #\i) inexact)))))
         (default-exactly ($ .$ ($ cons #f $) $))
         (sign ($or ($>> ($c #\+) +)
                    ($>> ($c #\-) -)))
         (sign~ ($optional sign +))
         (digit-list '(#[01] #[0-7] #[0-9] #[0-9a-f] #[0-9a-z]))
         (radix-char-list '(#\b #\o #\d #\x #\z))
         (radix-list '(2 8 10 16 36))
         (exp-marker ($do (marker ($one-of #[esfdl^]))
                          ($return
                           (if (char=? #\^ marker)
                               #f
                               inexact))))
         (i ($c #\i))
         (number
          (apply $or
                 (map (^ (digit-char-set radix-char radix)
                        (let* ((->number (^s (string->number (list->string s) radix)))
                               (digit ($one-of digit-char-set))
                               (digit* ($<< ->number ($many digit)))
                               (digit+ ($<< ->number ($many1 digit)))
                               (dot-digits->number (^l (let1 s (list->string l)
                                                         (/ (string->number s radix)
                                                            (expt radix (string-size s))))))
                               (dot-digit* ($<< dot-digits->number ($seq dot ($many digit))))
                               (dot-digit+ ($<< dot-digits->number ($seq dot ($many1 digit))))
                               (exp-suffix ($optional
                                            ($<< cons exp-marker ($<< (cut <> <>) sign~ digit+))))
                               (radix-prefix ($seq sharp ($c radix-char)))
                               (prefix ($or ($try
                                             ($do (r radix-prefix)
                                                  (e exactness-prefix)
                                                  ($return e)))
                                            ($do (e exactness-prefix)
                                                 (r (if (char=? #\d radix-char)
                                                        ($optional radix-prefix)
                                                        radix-prefix))
                                                 ($return e))))
                               (decimal ($or ($do (dec dot-digit+)
                                                  (e exp-suffix)
                                                  ($return
                                                   (cons inexact
                                                         (* dec
                                                            (expt radix (or (and e (cdr e))
                                                                            0))))))
                                             ($do (int digit+)
                                                  (dec ($optional dot-digit*))
                                                  (e exp-suffix)
                                                  ($return
                                                   (cons (and (or dec (and e (car e))) inexact)
                                                         (* (+ int (or dec 0))
                                                            (expt radix (or (and e (cdr e))
                                                                            0))))))))
                               (urational ($<< (default-exactly /) digit+ ($seq ($c #\/) digit+)))
                               (ureal ($or ($try urational)
                                           decimal))
                               (real ($do (signed sign~)
                                          (p ureal)
                                          ($return (cons (car p) (signed (cdr p))))))
                               (image-part-36
                                ($do (rest ($many anychar))
                                     (if (null? rest)
                                         ($fail #`"expecting ,digit-char-set")
                                          (if (char=? #\i (last rest))
                                              ($return
                                               (peg-run-parser ($optional ureal '(#f . 1))
                                                               (drop-right rest 1)))
                                              ($fail "expecting #\i")))))
                               (complex ($or ($try
                                              ($do (r real)
                                                   (($c #\@))
                                                   (t real)
                                                   ($return
                                                    (cons (or (car r) (car t))
                                                          (make-polar (cdr r)
                                                                      (cdr t))))))
                                             ($try
                                              ($do (x ($optional real '(#f . 0)))
                                                   (signed sign)
                                                   (y (if (char=? #\z radix-char)
                                                          image-part-36
                                                          ($seq0 ($optional ureal '(#f . 1)) i)))
                                                   ($return
                                                    (cons (or (car x) (car y))
                                                          (make-rectangular (cdr x)
                                                                            (signed (cdr y)))))))
                                             real)))
                          ($try
                           ($do (exactness prefix)
                                (body complex)
                                eof
                                ($return
                                 (match body
                                   ((default-exactness . n)
                                    ((or exactness default-exactness identity) n))))))))
                      digit-list
                      radix-char-list
                      radix-list))))
    (cut peg-parse-string number <>)))

どこまで正しいのかどうかはかなり怪しい．インデントの膨らみ方がやばい．
例:

(parse-number "42")        ; => 42
(parse-number "1/2")       ; => 1/2
(parse-number "1.2-3.4i")  ; => 1.2-3.4i
(parse-number "1/2+3/4i")  ; => 0.5+0.75i
(parse-number "1/2@3/4")   ; => 0.36584443443691045+0.3408193800116671i
(parse-number "#xff.ff")   ; => 255.99609375
(parse-number "#e#xff.ff") ; => 65535/256
(parse-number "1e3")       ; => 1000.0
(parse-number "1^3")       ; => 1000
(parse-number "#xa^b")     ; => 175921860444160
(parse-number "#zzz")      ; => 1295
(parse-number "#z0+ii")    ; => 0.0+18.0i

$do の括弧が少なくて気持ち悪いのと，($do ... ($return ...)) が頻出なのでその辺りのマクロも書きたかったけど，今回 parser.peg 自体がよく分からないということでなるべくあるものを使って書いた．$<< をもっと使えばいいのかな．あとなんか $do とか $return とか言われるとモナドを連想するけど，$<< は fmap なのかな？fmap なら $map って名前の方が分かりやすくないかなぁ．最初 $<< の名前が意味不明すぎて敬遠してしまっていた．
そもそも頭に$を付ける命名規則もどうなんだろうという気がしないでもない(但し代替案はない)．

今回これ書いててかなりデバッグし辛かった．$return 忘れとかのしょぼいエラーでもスタックトレースがちゃんと出てくれないととてもデバッグできない．こういうコンビネータ(と言うのかな？)をがちゃがちゃ組み合わせるプログラミングだとprintデバッグもやりにくいし．どこをどうパーズしていってどうなりましたというのがエラーと共にぱっと出ればいいなぁ．パーザの動きをトレースしたいよね．

正規表現でいう所の /.*a/ のパターンのパーザをどうやって書けばいいかよく分からなくて，36進数の複素数の直交座標表示のパーザ(image-part-36)が酷い．再帰でベタ書きすればできそうな気もするけどそれは面倒臭すぎる…．