howmsplit:引き数処理に継続を使ってみる

gaucheによるディレクトリ、テキストファイル処理。

関数の引き数で、定義域から外れるものが渡されたら、すぐさま例外を投げて終わる、みたいなこと。

今回は、エラーメッセージの表示と組み合わせてみることに。

これを継続を使って書いてみる。

変わったのはmain関数のところ。

#!/usr/local/bin/gosh

;howmの1日１メモファイルを、１メモ１ファイルに分割する。
;ファイル名はY-~m-~d-~H~M~S.howmの形式
;ただし、~Sの部分は実質的には単に順序を表す
;入力ファイルと同じディレクトリに作成する
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(use srfi-13)
(use srfi-19)
(use file.util)

;エラーメッセージ
(define status-alist '( (NORMAL . "exit normally.~%")
			(NO_ARG . "set howm directory.~%")
			(TOO_MANY_ARGS . "set only one directory.~%")
			(NOT_EXIST_DIR . "directory,not found.~%")))

;;１日１ファイルのファイル名パターン
(define rx-howm-file #/^\d\d\d\d-\d\d-\d\d\.howm$/)

;１メモ１ファイル形式のファイル名のbaseを作るジェネレーターを作る。
;filename : base名のみ
(define (make-basename-generator filename)
  (let ((time-cur
	 (date->time-monotonic (string->date (substring filename 0 10) "~Y-~m-~d") )))
    (lambda (time-h)
      (let ((time-tmp (make-time time-monotonic 0 0)))
	(when (and (string? time-h) (= 16 (string-length time-h)))
	  (set! time-tmp (date->time-monotonic (string->date time-h "~Y-~m-~d ~H:~M"))))
	(when (time<? time-tmp time-cur)
	  (set-time-second! time-tmp (time-second time-cur)))
	(set-time-second! time-cur (+ (time-second time-tmp) 1))
	(date->string (time-monotonic->date time-tmp (date-zone-offset (current-date))) "~Y-~m-~d-~H~M~S")))))


;１メモ１ファイル名を作って返す。
;;使えるファイル名か(既存のファイル名ではないか)チェックしてから
;; in
;;   dir : 対象ディレクトリ
;;   base-gen : base-name generator
;;   buf-h : time header line
;; out
;;  filename : filename (dir + base + ext)
(define (make-filename dir base-gen buf-h)
  (let ((head (rxmatch #/(\d\d\d\d-\d\d-\d\d\s\d\d:\d\d)/ buf-h)))
    (let loop ((filename (build-path dir (string-append (base-gen (and head (head 0))) ".howm"))))
      (if (file-exists? filename )
	  (loop (string-append (base-gen (and head (head 0))) ".howm"))
	  filename))))


;in
;;filename : 処理対象の１日１メモファイルのフルパス名
(define (howmsplit file)
  (let1 base-gen (make-basename-generator (sys-basename file))
    (with-input-from-file file
      (lambda ()
	(let loop ((port #f)
		   (count 0))
	  (let1 line (read-line)
	    (cond [(eof-object? line) (when port (close-output-port port))]
		  [(string-prefix? "=" line)
		   (let1 buf-h (read-line)
		     (when port (close-output-port port))
		     (let1 port (open-output-file (make-filename (sys-dirname file) base-gen buf-h))
		       (display line port)
		       (newline port)
		       (display buf-h port)
		       (newline port)
		       (loop port (+ count 1))))]
		  [else
		   (when port (display line port) (newline port))
		   (loop port count)])))) :encoding "*jp")))


;;継続を使って、エラー制御をしてみる。
;;args : ディレクトリ名のみ 絶対でも相対でも構わない。
(define (main args)
(format #t (cdr (assq
  (call/cc
   (lambda (end)
     (when (null? (cdr args))
       (end 'NO_ARG))
     (when (>= (length args) 3)
       (end 'TOO_MANY_ARGS))
     (let1 dir (sys-normalize-pathname (car (cdr args)) :absolute #t :expand #t  :canonicalize #t)
       (cond ((not (file-is-directory? dir))
	      (end 'NOT_EXIST_DIR))
	     (else
	      (format #t "howm directory: ~A~%" dir)
	      (directory-fold dir                    ;本処理はここから。
			 (lambda (file seed)
			   (when (and (string-incomplete->complete file)
				      (rxmatch rx-howm-file (sys-basename file)))
			     (howmsplit file)))
			 '()))))
   'NORMAL))
  status-alist))))

一応動く。
継続にエラー内容に応じたシンボルを渡す。
そして連想配列から対応するメッセージを引いて表示。
けど、全体をformat関数で囲むという、なんだかおさまりの悪いことに。
こういうのは素直に、全部condで場合分けして、ステータス用の変数を用意したほうがいいんだろうか。

その他、細かい修正は、絶対パスに展開して処理して、ファイルを書き込むところも、元のファイルがあるところにしたこと。