備忘録とチラシの裏を兼ねる
考えてみると当たり前なんだけど、軽く感動した再帰の使い方について。
ストリームか文字列を同じ引数として受け取る関数を書こうとして、ストリームの場合と文字列の場合の処理の振り分けについて考えていた。最初は単純に、typecaseや、cl-matchなどのパターンマッチャで、型ごとに分岐させるか、総称関数を使って、型ごとに関数を分けてしまおうと考えた。ただ、処理が、分岐や別の関数に散らばってしまうので、何となくしっくり来なかった。
そこで、他の人がどうやってるのかが気になって、使ってる処理系のコードを読んでみたところ、
(defun f (string-or-stream)
(if (stringp string-or-stream)
(with-input-from-string (s string-or-stream)
(f s))
(main-process)))のようなアプローチを採っていた。賢い。
今後、こういうパターンでは使わせてもらおう。
Scheme:マクロの効用のリストの構築で、cond-consというマクロが紹介されてるけど、Common Lispで欲しくなったので書いてみた。
(defmacro cond-cons (&rest clauses)
(labels ((rec (clauses)
(if clauses
(let ((clause (car clauses))
(r (rec (cdr clauses))))
`(if ,(car clause) (cons (progn ,@(cdr clause)) ,r) ,r))
nil)))
(rec clauses)))一瞬、rが複数回評価されて、副作用があるとまずいんじゃ、とか思ったけど、考えたらifで分岐するから問題なかった。
マクロなのに末尾再帰版。すみません。大好きです末尾再帰。
(defmacro cond-cons (&rest clauses)
(labels ((rec (clauses fn)
(if clauses
(let ((clause (car clauses)))
(rec (cdr clauses)
(lambda (x)
`(if ,(car clause)
(cons (progn ,@(cdr clause)) ,(funcall fn x))
,(funcall fn x)))))
`(nreverse ,(funcall fn nil)))))
(rec clauses (lambda (x) x))))コンパイル時にしか評価されないので、ほとんど意味がない。末尾再帰じゃないバージョンだとスタックが溢れるくらい、clausesが長いリストだったりするなら多少は意味があるだろうけど、それってどんなだよ。
Paul Grahamも同じ趣旨のことをOn Lispかどこかに書いてたように思うけど、マクロ定義のコードで頑張る意味なんてない。
ちなみに、Gaucheでは、util.listにcond-listという名前で、より高機能なものが収録されている。何でそんなことを書くかというと、以前探したときに、しばらく見付けられなかったからではない。そんなわけはない。
手探りでやるしかないから、えらく苦労した。
(eval-when (:compile-toplevel :load-toplevel :execute)
(asdf:load-system :teepeedee2))
(defpackage :tpd2-favicon (:use :cl :tpd2 :tpd2.ml.html))
(in-package :tpd2-favicon)
(defconstant +icon-content-type+
(byte-vector-cat "Content-Type: image/x-icon" tpd2.io:+newline+))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun favicon ()
(with-open-file (in "work/tpd2/favicon.ico" :element-type '(unsigned-byte 8))
(let ((buf (make-array (file-length in) :element-type '(unsigned-byte 8))))
(read-sequence buf in)
buf))))
(dispatcher-register-path
(find-or-make-dispatcher "localhost:8080")
"/favicon.ico"
#'(lambda (dispatcher con done)
(declare (ignore dispatcher))
(start-http-response :content-type +icon-content-type+)
(send-http-response con done (with-sendbuf () #.(favicon)))))
(defsite *favicon-site* :dispatcher (find-or-make-dispatcher "localhost:8080"))
(with-site (*favicon-site*)
(defpage "/" ()
(<p "favicon test")))
(http-start-server 8080)
(ccl:process-run-function "tpd2" #'event-loop)オプション引数の処理がad hocなのは仕様です。
(use gauche.charconv)
(use srfi-1)
(use srfi-13)
(use srfi-19)
(use rfc.822)
(use rfc.http)
(use rfc.uri)
(use sxml.ssax)
(use sxml.sxpath)
(use sxml.tools)
(use util.list)
(define-reader-macro (feed url . args)
(define *item-max* 10)
(define *date-format* "~Y/~m/~d")
(define *item-format* "(~a) ~a")
(define *ns*
'((atom . "http://www.w3.org/2005/Atom")
(openSearch . "http://a9.com/-/spec/opensearchrss/1.0/")
(georss . "http://www.georss.org/georss")
(thr . "http://purl.org/syndication/thread/1.0")
(rss1 . "http://purl.org/rss/1.0/")
(rdf . "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
(content . "http://purl.org/rss/1.0/modules/content/")
(dc . "http://purl.org/dc/elements/1.1/")
(foo . "bar")))
(define (w3cdtf->date str)
(define (df->nano df)
(string->number (string-pad-right (number->string df) 9 #\0)))
(and-let*
((match (#/^(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:T(\d\d):(\d\d)(?::(\d\d)(?:\.(\d+))?)?(?:Z|([+-]\d\d):(\d\d)))?)?)?$/ str)))
(receive (year month day hour minute second df zh zm)
(apply values (map (lambda (i) (x->integer (match i))) (iota 9 1)))
(make-date (df->nano df)
second minute hour day month year
(* (if (negative? zh) -1 1)
(+ (* (abs zh) 3600) (* zm 60)))))))
(define *feed-attributes*
`((atom
(converter
,(sxpath '(// atom:entry atom:title *text*))
,(sxpath '(// atom:entry
(atom:link (@ (equal? (rel "alternate"))))
@ href *text*))
,(sxpath '(// atom:entry atom:published *text*)))
(date-parser . ,w3cdtf->date))
(rss1
(converter
,(sxpath '(// rss1:item rss1:title *text*))
,(sxpath '(// rss1:item rss1:link *text*))
,(sxpath '(// rss1:item dc:date *text*)))
(date-parser . ,w3cdtf->date))
(rss2
(converter
,(sxpath '(// item title *text*))
,(sxpath '(// item link *text*))
,(sxpath '(// item pubDate *text*)))
(date-parser . ,rfc822-date->date))))
(define (feed-attr type field)
(cdr (assoc field (cdr (assoc type *feed-attributes*)))))
(define (decompose-uri url)
(receive (_ specific) (uri-scheme&specific url)
(uri-decompose-hierarchical specific)))
(define (authority&path?query url)
(define (path?query path query)
(with-output-to-string
(lambda ()
(display path)
(when query (format #t "?~a" query)))))
(receive (authority path query _) (decompose-uri url)
(values authority (path?query path query))))
(define (feed-get url)
(receive (authority path?query) (authority&path?query url)
(receive (status header body) (http-get authority path?query)
(unless (equal? status "200")
(error "フィードの読み込みに失敗しました。ステータスコードは~aです。"
status))
(if (or (null? args) (null? (cdr args)))
body
(ces-convert body (cadr args))))))
(define (feed->sxml feed)
(with-input-from-string feed
(cut ssax:xml->sxml (current-input-port) *ns*)))
(define (feed-type-of sxml)
(define root-node ((car-sxpath '(*)) sxml))
(define (rss1?)
(eq? (sxml:name root-node) 'rdf:RDF))
(define (rss2?)
(and (eq? (sxml:name root-node) 'rss)
(equal? (sxml:attr root-node 'version) "2.0")))
(define (atom?)
(eq? (sxml:name root-node) 'atom:feed))
(cond ((rss1?) 'rss1)
((rss2?) 'rss2)
((atom?) 'atom)
(else (error "対応していない種類のフィードです。"))))
(define converter-title car)
(define converter-link cadr)
(define converter-date caddr)
(define (take-item-max nodes)
(let1 n (if (null? args) *item-max* (car args))
(take* nodes n)))
(let* ((feed (feed->sxml (feed-get url)))
(type (feed-type-of feed))
(conv (feed-attr type 'converter))
(proc (feed-attr type 'date-parser))
(title (converter-title conv))
(link (converter-link conv))
(date (converter-date conv)))
`((ul ,@(map (lambda (title link date)
`(li (a (@ (href ,link))
,(format #f *item-format*
(date->string (proc date) *date-format*)
title))))
(take-item-max (title feed))
(take-item-max (link feed))
(take-item-max (date feed)))))))WiLiKiのrssmix.scmを参考に、W3C-DTFの文字列をSRFI 19の日付オブジェクトに変換する関数を書いた。
(use srfi-1)
(use srfi-13)
(use srfi-19)
(define (w3cdtf->date str)
(define (df->nano df)
(string->number (string-pad-right (number->string df) 9 #\0)))
(and-let*
((match (#/^(\d\d\d\d)(?:-(\d\d)(?:-(\d\d)(?:T(\d\d):(\d\d)(?::(\d\d)(?:\.(\d+))?)?(?:Z|([+-]\d\d):(\d\d)))?)?)?$/ str)))
(receive (year month day hour minute second df zh zm)
(apply values (map (lambda (i) (x->integer (match i))) (iota 9 1)))
(make-date (df->nano df)
second minute hour day month year
(* (if (negative? zh) -1 1)
(+ (* (abs zh) 3600) (* zm 60)))))))