GaucheFest:cut-sea

debug-printをいじってみる。

2006/11/4 時点のcurrentに対するpatch。

Index: lib/gauche/vm/debugger.scm
===================================================================
RCS file: /cvsroot/gauche/Gauche/lib/gauche/vm/debugger.scm,v
retrieving revision 1.19
diff -u -r1.19 debugger.scm
--- lib/gauche/vm/debugger.scm  28 Jan 2006 09:17:42 -0000      1.19
+++ lib/gauche/vm/debugger.scm  4 Nov 2006 11:16:58 -0000
@@ -37,7 +37,9 @@
   (use srfi-1)
   (use srfi-13)
   (use gauche.parameter)
-  (export debug-print debug-print-width debug-source-info)
+  (export debug-print debug-print-width debug-source-info
+         debug-print-output-port debug-print-before debug-print-after
+         debug-print-reset)
   )
 (select-module gauche.vm.debugger)
 
@@ -50,6 +52,7 @@
     info))
 
 (define debug-print-width (make-parameter 65))
+(define debug-print-output-port (make-parameter (current-error-port)))
 
 ;; Debug print stub ------------------------------------------
 ;; (this is temporary implementation)
@@ -57,33 +60,42 @@
   (syntax-rules ()
     ((_ ?form)
      (begin
-       (debug-print-pre '?form)
+       ((debug-print-before) '?form)
        (receive vals ?form
-         (debug-print-post vals))))))
+         ((debug-print-after) vals)
+        (apply values vals))))))
 
 ;; Non-exported routines
 
 (define (debug-print-pre form)
   (cond ((debug-source-info form)
          => (lambda (info)
-              (format/ss (current-error-port) "#?=~s:~a:~,,,,v:s\n"
+              (format/ss (debug-print-output-port) "#?=~s:~a:~,,,,v:s\n"
                          (car info) (cadr info) (debug-print-width) form)))
         (else
-         (format/ss (current-error-port) "#?=~,,,,v:s\n"
+         (format/ss (debug-print-output-port) "#?=~,,,,v:s\n"
                     (debug-print-width) form))))
 
 (define (debug-print-post vals)
   (if (null? vals)
-    (format (current-error-port) "#?-<void>\n")
-    (begin
-      (format/ss (current-error-port) "#?-    ~,,,,v:s\n"
-                 (debug-print-width) (car vals))
-      (for-each (lambda (elt)
-                  (format/ss (current-error-port)
-                             "#?+    ~,,,,v:s\n"
-                             (debug-print-width) elt))
-                (cdr vals))))
-  (apply values vals))
+      (format (debug-print-output-port) "#?-<void>\n")
+      (begin
+       (format/ss (debug-print-output-port) "#?-    ~,,,,v:s\n"
+                  (debug-print-width) (car vals))
+       (for-each (lambda (elt)
+                   (format/ss (debug-print-output-port)
+                              "#?+    ~,,,,v:s\n"
+                              (debug-print-width) elt))
+                 (cdr vals)))))
+
+(define debug-print-before (make-parameter debug-print-pre))
+(define debug-print-after (make-parameter debug-print-post))
+
+(define (debug-print-reset)
+  (debug-print-width 65)
+  (debug-print-output-port (current-error-port))
+  (debug-print-before debug-print-pre)
+  (debug-print-after debug-print-post))
 
 (provide "gauche/vm/debugger")
 
Index: src/autoloads.scm
===================================================================
RCS file: /cvsroot/gauche/Gauche/src/autoloads.scm,v
retrieving revision 1.36
diff -u -r1.36 autoloads.scm
--- src/autoloads.scm   5 Jun 2006 05:11:25 -0000       1.36
+++ src/autoloads.scm   4 Nov 2006 11:16:59 -0000
@@ -133,7 +133,10 @@
 (autoload gauche.time (:macro time))
 
 (autoload gauche.vm.debugger (:macro debug-print)
-                             debug-print-width debug-source-info)
+                             debug-print-width debug-source-info
+                            debug-print-output-port
+                            debug-print-before debug-print-after
+                            debug-print-reset)
 
 (autoload gauche.vm.profiler profiler-show profiler-show-load-stats)

これで、(すんげーやっつけ感モリモリだけど)以下の様にすると。

(define %%depth -1)

(debug-print-before (lambda (form)
                      (inc! %%depth)
                      (format #t "~a~a~%" (make-string %%depth #\sp) form)))

(debug-print-after
 (lambda (vals)
   (format #t #`"~a ==> ~a~%"
           (make-string %%depth #\sp) (string-join (map x->string vals) ","))
   (dec! %%depth)))

gosh> (define (fact n)
        (if (= n 1) 1 (* n #?=(fact (- n 1)))))

gosh> (fact 10)
gosh> (fact 10)
(fact (- n 1))
 (fact (- n 1))
  (fact (- n 1))
   (fact (- n 1))
    (fact (- n 1))
     (fact (- n 1))
      (fact (- n 1))
       (fact (- n 1))
        (fact (- n 1))
         ==> 1
        ==> 2
       ==> 6
      ==> 24
     ==> 120
    ==> 720
   ==> 5040
  ==> 40320
 ==> 362880
3628800
gosh> 

あるいは。

(define next #f)
(define *br* (call/cc identity))

(debug-print-after (lambda (vals)
                     (let1 v (car vals)
                       (call/cc (lambda (c)
                                  (if (<= v 2)
                                      (begin (print v)
                                             (set! next c)
                                             (*br* *br*))
                                      (print v)))))))

こういうトリッキーなことをすれば。

gosh> (define (fact n)
       (if (= #?=n 1) 1 (* n (fact (- n 1)))))

gosh> (fact 10)
#?=n
10
#?=n
9
#?=n
8
#?=n
7
#?=n
6
#?=n
5
#?=n
4
#?=n
3
#?=n
2
*br*
gosh> (next 2)
#?=n
1
*br*
gosh> (next 1)
3628800
gosh>

breakまがいのことが出来る。継続ってすばらすぃ。cut-sea:2006/11/03 23:29:55 PST

あ、あとデバッグプリントの出力先の変更。

(debug-print-output-port (standard-output-port))

これで標準出力に。cut-sea:2006/11/04 00:21:50 PST

• 2006/11/05 00:27:32 PST: standard-output-port はともかく、current-error-port はそのときになってから呼んだ方がいいのではないでしょうか？

そうかぁ。(apply values vals)は動作に必須だから debug-print-afterに渡すclosureに書かなくてもいいようにしないといけなかったんだ。

kahua-call-with-current-contextを使った何かを完成

とりあえず、ざっくりとはできた。 バリデーションの実装を書き直そうってことで、以下のようなマクロを実装。

;; define-validator's child function
(define (make-binds vars-list)
  (map (lambda (v) `(,v (kahua-context-ref ,v))) vars-list))
(define (default-predicate vars-list)
  (cons 'and (map (lambda (v) `(not ,v)) vars-list)))
;; validator generator
(define-macro (define-validator expr . body)
  `(define ,expr
     (let ,(make-binds (cdr expr))
       (cond (,(default-predicate (cdr expr)) identity)
             (else ,@body)))))

動作確認はとれたので、書き換えるってのが今のタスク。

書き換え始めたらまた問題がでた。 で、再度マクロを書き直し。

;
; syntax for validator
;
;; define-validator's child function
(define (get-variables vars-list)
  (let lp ((vars vars-list)
           (ret '()))
    (cond ((null? vars) ret)
          ((eq? :keyword (car vars)) ret)
          (else
           (lp (cdr vars) (append ret (list (car vars))))))))
(define (get-keyword vars-list)
  (let1 keys (memq :keyword vars-list)
    (if keys (cdr keys) '())))
(define (make-binds vars-list)
  (map (lambda (v) `(,v (kahua-context-ref ,v))) vars-list))
(define (default-predicate vars-list)
  (cons 'and (map (lambda (v) `(not ,v)) vars-list)))
;; validator generator
(define-macro (define-validator expr . body)
  `(define ,expr
     (let ,(make-binds (get-keyword (cdr expr)))
       (cond (,(default-predicate (get-keyword (cdr expr))) identity)
             (else ,@body)))))

こんなんなった。

(define-validator (v:not-null :keyword value)
  (cond ((string-null? value) "入力してください")
        (else identity)))
(define-validator (v:number :keyword value)
  (cond ((string-null? value) "入力してください")
        ((#/^[^0-9]+$/ value) "半角数字のみ入力してください")
        (else identity)))
  :
  :
  ;
(define-validator (v:code item :keyword value)
  (cond ((string-null? value) "入力してください")
        ((same-code-exist? item value) #`"商品コード[,|value|]はすでにあります")
        (else identity)))

最後のケースがあったのでした。 その場所で見える他のオブジェクトの値と比較して ロジックレベルのバリデートを加える。

• Shiro(2006/06/04 13:23:03 PDT): ざっと見ただけなんで勘違いしてるかもしれませんが、 こんな感じはいかが。

  (define (get-variables vars-list) 
    (take-while (lambda (v) (not (eq? v :keyword))) vars-list))
  
  (define (get-keyword vars-list)
    (cond ((memq :keyword :vars-list) => cdr) (else '())))
  

  あと、このくらいの手続きなら、他で使う必要がないならinternal defineに してしまった方がいいかもしれません。名前空間を消費しませんし(get-keywordは 同名の組み込み関数と衝突してますね)、後で見たときに使われる範囲が 限定されているのでリファクタリングとかがやりやすいです。

• ありがとうございます。Shiroさん。

  (define-macro (define-validator expr . body)
    (define (%get-variables vars-list)
      (take-while (lambda (v) (not (eq? v :keyword))) vars-list))
    (define (%get-keyword vars-list)
      (cond ((memq :keyword vars-list) => cdr)
            (else '())))
    (define (make-binds vars-list)
      (map (lambda (v) `(,v (kahua-context-ref ,v))) vars-list))
    (define (default-predicate vars-list)
      (cons 'and (map (lambda (v) `(not ,v)) vars-list)))
    `(define ,expr
       (let ,(make-binds (%get-keyword (cdr expr)))
         (cond (,(default-predicate (%get-keyword (cdr expr))) identity)
               (else ,@body)))))
  

  こんな感じになりました。 %get-variablesは使ってないことに気づいたけど、 まだ少し弄りそうなのでもうししばらく残留です。

kahua-call-with-current-contextを使った何か

何やるか悩んでたけど、前回要望を出して、皆で一緒にハックして実装したcall-with-current-contextを使ってコンテキストに沿った画面移動をするようなものを作ろうか。 せっかくだからAPIも含めて実際に使えるかを確認しないといけないし。

籠入娘。0.1.1のリリース

Kahuaにno-escapeなelementを実装。参照実装を書けるようにした。

(p/ (no-escape/ "©") "Kahua Project")

みたいな感じ。 no-escapeには複数の文字列を渡せる。

• [注意]Kahuaのテストで使っているsxmlライブラリの方では"©"とかは使えない。 "&#169"などとせざるをえないがしょうがないっす。 これを受けてkagoiri-musumeのmelody-formatはpタグに完全移行。わーい。

• Shiro(2006/03/05 09:18:39 PST): no-escapeは「何でもあり」すぎるので、 実体参照はそれ専用のエレメントを作った方が良くありませんかね。 一度無制限にしてあとから制限をつけてくのは難しいので、 なるべく制限を緩める範囲を限定しといた方が。

• 専用ってことは文字列は何でもOKじゃなくて#/^&.+;$/形式のものに対してのみ 有効に絞るという意味と解釈していいですか? それともno-escapeを使った仕掛自体よくない?cut-sea:2006/03/05 09:37:22 PST

• Shiro(2006/03/05 09:51:07 PST): たとえば (entity-ref/ "copy") => "©"、 (entity-ref/ 100) => "@" とか。(&/ "copy") でもいいかな。 no-escapeというのがなんでもありすぎて良くないと思います。

• なーるほど！&/いいですね。再度いじり直してみることにします。 ただno-escapeの時にも挑戦してうまく出来なかったので数字を取れるかどうか自信がないです。 (取れるようにしたかったんですが)cut-sea:2006/03/05 10:02:28 PST

• やってみました。

  (&/ #x169) => "©"
  (&/ "nbsp") => " "
  (&/ 'nbsp) => " "
  

  って感じになります。cut-sea:2006/03/05 11:29:51 PST