GaucheFest:cut-sea

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

そうかぁ。(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)))

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


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

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


籠入娘。0.1.1のリリース

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

(p/ (no-escape/ "&copy;") "Kahua Project")

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

More ...