make list-head-nice more idiomatic; use it in movabletype
[tekuti:acf-tekuti.git] / tekuti / util.scm
1 ;; Tekuti
2 ;; Copyright (C) 2008, 2010 Andy Wingo <wingo at pobox dot com>
3
4 ;; This program is free software; you can redistribute it and/or
5 ;; modify it under the terms of the GNU General Public License as
6 ;; published by the Free Software Foundation; either version 3 of
7 ;; the License, or (at your option) any later version.
8 ;;
9 ;; This program is distributed in the hope that it will be useful,
10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 ;; GNU General Public License for more details.
13 ;;
14 ;; You should have received a copy of the GNU General Public License
15 ;; along with this program; if not, contact:
16 ;;
17 ;; Free Software Foundation           Voice:  +1-617-542-5942
18 ;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
19 ;; Boston, MA  02111-1307,  USA       gnu@gnu.org
20
21 ;;; Commentary:
22 ;;
23 ;; Utility procedures and macros.
24 ;;
25 ;;; Code:
26
27 (define-module (tekuti util)
28   #:use-module (tekuti match-bind)
29   #:use-module (srfi srfi-1)
30   #:use-module (srfi srfi-19)
31   #:export (expanduser match-lines dbg unwind-protect dsu-sort
32             hash-push! list-has-length? list-head-match mapn filter-mapn
33             take-max read-hash write-hash shell:quote foldn
34             call-with-temp-file emailish? urlish?
35             date-increment date-comparator date-before? date-after? compose1
36             rfc822-date->timestamp timestamp->rfc822-date timestamp->atom-date
37             date->timestamp date->rfc822-date timestamp->date
38             string-split/trimming list-head-nice list-tail-nice
39             list-intersperse with-time-debugging))
40
41 (define (emailish? x)
42   (match-bind "^([a-zA-Z0-9._+-]+)@([a-zA-Z0-9-]+\\.)+[a-zA-Z]+$"
43               x (_ . args)
44               x
45               #f))
46
47 ;; hacky #fragment interpreting...
48 (define (urlish? x)
49   (match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+(/[a-zA-Z0-9$_.+!*'(),;/?:#@&=-]*)?$"
50               x (_ . args)
51               x
52               #f))
53
54 ;; bad name relative to mapn...
55 (define (foldn kons n knil values)
56   (if (null? values)
57       knil
58       (foldn kons n
59              (apply kons knil (list-head values n))
60              (list-tail values n))))
61
62 (define-syntax unwind-protect
63   (syntax-rules ()
64     ((_ form cleanup0 cleanups ...)
65      (dynamic-wind (lambda () #t)
66                    (lambda () form)
67                    (lambda () cleanup0 cleanups ...)))))
68
69 (define (call-with-temp-file contents proc)
70   (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
71          (tmp (mkstemp! template)))
72     (display contents tmp)
73     (close tmp)
74     (unwind-protect
75      (proc template)
76      (delete-file template))))
77
78 (define (shell:quote str)
79   (with-output-to-string
80     (lambda ()
81       (display #\')
82       (string-for-each (lambda (ch)
83                          (if (eqv? ch #\')
84                              (begin (display #\\) (display #\'))
85                              (display ch)))
86                        str)
87       (display #\'))))
88
89 (define (expanduser path)
90   (let ((parts (string-split path #\/)))
91     (if (eqv? (string-ref (car parts) 0) #\~)
92         (let ((user (if (= (string-length (car parts)) 1)
93                         (passwd:name (getpwuid (geteuid)))
94                         (substring (car parts) 1))))
95           (string-join (cons (passwd:dir (getpwnam user)) (cdr parts)) "/"))
96         path)))
97
98 (define-syntax match-lines
99   (syntax-rules ()
100     ((_ string pattern bindings expr)
101      (fold
102       (lambda (line seed)
103         (match-bind pattern line bindings
104                     (cons expr seed)
105                     seed))
106       '() (string-split string #\newline)))))
107
108 (define (dbg fmt . args)
109   (apply format (current-error-port) fmt args))
110
111 (define (dsu-sort list key less)
112   (map cdr
113        (stable-sort (map (lambda (x) (cons (key x) x)) list)
114                     (lambda (x y) (less (car x) (car y))))))
115
116 (define (hash-push! h key value)
117   (let ((handle (hash-create-handle! h key '())))
118     (set-cdr! handle (cons value (cdr handle)))))
119
120 (define (take-max list n)
121   (if (or (null? list) (zero? n))
122       '()
123       (cons (car list) (take-max (cdr list) (1- n)))))
124
125 (define (list-has-length? list len)
126   (cond
127    ((zero? len) (null? list))
128    ((null? list) #f)
129    (else (list-has-length? (cdr list) (1- len)))))
130
131 ;; returns tail of l2
132 (define (list-head-match l1 l2 n)
133   (cond
134    ((zero? n) l2)
135    ((null? l2) #f)
136    ((not (equal? (car l1) (car l2))) #f)
137    (else (list-head-match (cdr l1) (cdr l2) (1- n)))))
138
139 (define (list-head-nice list end)
140   (list-head list (min end (length list))))
141
142 (define (list-tail-nice list start)
143   (let ((items-no (length list)))
144     (if (> start (- items-no 1))
145         #nil
146         (list-tail list start))))
147
148 (define (mapn proc l nmax)
149   (let lp ((in l) (out '()) (n nmax))
150     (if (or (null? in) (zero? n))
151         (reverse out)
152         (lp (cdr in) (cons (proc (car in)) out) (1- n)))))
153
154 (define (filter-mapn proc l nmax)
155   (let lp ((in l) (out '()) (n nmax))
156     (if (or (null? in) (zero? n))
157         (reverse out)
158         (let ((val (proc (car in))))
159           (if val
160               (lp (cdr in) (cons val out) (1- n))
161               (lp (cdr in) out n))
162           ))))
163
164 (define (list-intersperse src-l elem)
165   (if (null? src-l) src-l
166       (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
167         (if (null? l) (reverse dest)
168             (loop (cdr l) (cons (car l) (cons elem dest)))))))
169
170 (define (gettimeofday-diff prev)
171   (let ((now (gettimeofday)))
172    (+ (- (car now) (car prev))
173       (* 1e-6 (- (cdr now) (cdr prev))))))
174
175 (define (with-time-debugging* proc)
176   (pk 'start-clock)
177   (let ((start (gettimeofday)))
178     (unwind-protect
179      (proc)
180      (pk 'stop-clock (gettimeofday-diff start)))))
181
182 (define-syntax with-time-debugging
183   (syntax-rules ()
184     ((_ form0 forms ...)
185      (with-time-debugging* (lambda () form0 forms ...)))))
186
187 (define (memoize1 proc)
188   (let ((old-args #f) (cache #f) (proc proc))
189     (lambda args
190       (if (equal? args old-args)
191           cache
192           (let ((val (apply proc args)))
193             (set! old-args args)
194             (set! cache val)
195             val)))))
196
197 (define (write-hash h)
198   (write (hash-fold acons '() h)))
199
200 (define (read-hash)
201   (let ((h (make-hash-table)))
202     (for-each (lambda (pair)
203                 (hash-set! h (car pair) (cdr pair)))
204               (read))
205     h))
206
207 (define* (date-increment date #:key (day 0) (month 0) (year 0))
208   (make-date (date-nanosecond date) (date-second date)
209              (date-minute date) (date-minute date)
210              (+ (date-day date) day) (+ (date-month date) month)
211              (+ (date-year date) year) (date-zone-offset date)))
212
213 (define (date-comparator date comp)
214   (let ((this (time-second (date->time-utc date))))
215     (lambda (that)
216       (comp that this))))
217
218 (define (date-before? date)
219   (date-comparator date <))
220
221 (define (date-after? date)
222   (date-comparator date >))
223
224 (define (compose1 proc . procs)
225   (if (null? procs)
226       proc
227       (let ((other (apply compose1 procs)))
228         (lambda (x)
229           (proc (other x))))))
230
231 (define (string-split/trimming string delimiter)
232   (map string-trim-both (string-split string delimiter)))
233
234 (define (rfc822-date->timestamp str)
235   (+ (time-second (date->time-utc
236                    (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT")))
237      (date-zone-offset (current-date))))
238
239 (define (timestamp->date timestamp)
240   (time-utc->date (make-time time-utc 0 timestamp) 0))
241
242 (define (date->timestamp date)
243   (time-second (date->time-utc date)))
244
245 (define (date->rfc822-date date)
246   (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT"))
247
248 (define (timestamp->atom-date timestamp)
249   (date->string (timestamp->date timestamp)
250                 "~Y-~m-~dT~H:~M:~SZ"))
251
252 (define (timestamp->rfc822-date timestamp)
253   (date->rfc822-date (timestamp->date timestamp)))
254