Replace several define-macro' uses with syntax-rules' and `syntax-case'
This commit is contained in:
Andreas Rottmann
Andy Wingo
parent
1c0d0f2a85
commit
2649cadc43
4 changed files with 92 additions and 100 deletions
|
|
@ -56,9 +56,11 @@
|
|||
(output git-condition-output)
|
||||
(status git-condition-status))
|
||||
|
||||
(define-macro (false-if-git-error . body)
|
||||
`(,guard (c ((,git-condition? c) #f))
|
||||
,@body))
|
||||
(define-syntax false-if-git-error
|
||||
(syntax-rules ()
|
||||
((_ body0 body ...)
|
||||
(guard (c ((git-condition? c) #f))
|
||||
body0 body ...))))
|
||||
|
||||
;;;
|
||||
;;; running git
|
||||
|
|
|
|||
|
|
@ -128,68 +128,80 @@
|
|||
#f)
|
||||
#f)))))
|
||||
|
||||
(define-macro (let-request request bindings . body)
|
||||
(let ((request-var (gensym)))
|
||||
(define-syntax let-request
|
||||
(lambda (stx)
|
||||
(define (make-binding b)
|
||||
(cond
|
||||
((symbol? b) `(,b (,rref ,request-var ',b)))
|
||||
((list? b) `(,(car b) (,rref ,request-var ',(car b) ,@(cdr b))))
|
||||
(else (error "what" b))))
|
||||
`(let ((,request-var ,request))
|
||||
(let (,@(map make-binding bindings))
|
||||
,@body))))
|
||||
(syntax-case b ()
|
||||
((id option ...)
|
||||
(identifier? #'id)
|
||||
#'(id (rref request-var 'id option ...)))
|
||||
(id
|
||||
(identifier? #'id)
|
||||
#'(id (rref request-var 'id)))))
|
||||
(syntax-case stx ()
|
||||
((_ request (binding ...) body ...)
|
||||
(with-syntax (((binding ...) (map make-binding #'(binding ...))))
|
||||
#`(let ((request-var request))
|
||||
(let (binding ...)
|
||||
body ...)))))))
|
||||
|
||||
(define-macro (path-proc-case path . clauses)
|
||||
(let ((path-var (gensym)))
|
||||
(define-syntax path-proc-case
|
||||
(lambda (stx)
|
||||
(define (optional-argument? arg)
|
||||
(eqv? (string-ref arg (1- (string-length arg))) #\?))
|
||||
(eqv? (string-ref arg (- (string-length arg) 1)) #\?))
|
||||
(define (required-argument? arg)
|
||||
(eqv? (string-ref arg (1- (string-length arg))) #\!))
|
||||
(eqv? (string-ref arg (- (string-length arg) 1)) #\!))
|
||||
(define (output-argument? arg)
|
||||
(or (optional-argument? arg) (required-argument? arg)))
|
||||
(define (process-clause clause)
|
||||
(or (list-has-length? clause 2) (error "foo"))
|
||||
(if (eq? (car clause) 'else)
|
||||
clause
|
||||
(let ((pat (map symbol->string (car clause)))
|
||||
(proc (cadr clause)))
|
||||
(syntax-case clause (else)
|
||||
((else expr ...) clause)
|
||||
(((p ...) proc)
|
||||
(let ((pat (map (lambda (p)
|
||||
(symbol->string (syntax->datum p)))
|
||||
#'(p ...))))
|
||||
(cond
|
||||
((find-tail output-argument? pat)
|
||||
=> (lambda (tail)
|
||||
(define test
|
||||
(let* ((npat (length pat))
|
||||
(ntail (length tail))
|
||||
(req (find-tail required-argument? tail))
|
||||
(let* ((req (find-tail required-argument? tail))
|
||||
(opt (find-tail optional-argument? tail))
|
||||
(npat (length pat))
|
||||
(ntail (length tail))
|
||||
(nopt (if opt (length opt) 0))
|
||||
(nreq (if req (- (length req) nopt) 0)))
|
||||
(lambda (path)
|
||||
(let ((pathtail (list-head-match pat path (- npat ntail))))
|
||||
;(pk pat npat ntail req opt nopt nreq path pathtail)
|
||||
(if (and pathtail (>= (length pathtail) nreq)
|
||||
(<= (length pathtail) (+ nreq nopt)))
|
||||
(append pathtail
|
||||
(make-list (- (+ nreq nopt) (length pathtail)) #f))
|
||||
#f)))))
|
||||
`((,test ,path-var)
|
||||
#`((let ((pathtail (list-head-match '#,pat
|
||||
path-var
|
||||
(- #,npat #,ntail))))
|
||||
;;(pk pat npat ntail req opt nopt nreq path pathtail)
|
||||
(if (and pathtail (>= (length pathtail) #,nreq)
|
||||
(<= (length pathtail) (+ #,nreq #,nopt)))
|
||||
(append
|
||||
pathtail
|
||||
(make-list (- (+ #,nreq #,nopt) (length pathtail)) #f))
|
||||
#f))
|
||||
=> (lambda (outargs)
|
||||
(lambda args
|
||||
(apply ,proc (append args outargs)))))))
|
||||
(apply proc (append args outargs))))))))
|
||||
(else
|
||||
`((equal? ,path-var ',pat) ,proc))))))
|
||||
`(let ((,path-var ,path))
|
||||
(cond ,@(map process-clause clauses)))))
|
||||
#`((equal? path-var '#,pat) proc)))))))
|
||||
(syntax-case stx ()
|
||||
((_ path clause ...)
|
||||
(with-syntax (((cond-clause ...) (map process-clause #'(clause ...))))
|
||||
#`(let ((path-var path))
|
||||
(cond cond-clause ...)))))))
|
||||
|
||||
(define (rcons*-fold request . keys-and-procs)
|
||||
(foldn (lambda (request k proc)
|
||||
(rcons k (proc request) request))
|
||||
2 request keys-and-procs))
|
||||
|
||||
(define-macro (request-path-case request . clauses)
|
||||
`(,path-proc-case
|
||||
(,let-request ,request (method path)
|
||||
(define-syntax request-path-case
|
||||
(syntax-rules ()
|
||||
((_ request clause ...)
|
||||
(path-proc-case
|
||||
(let-request request (method path)
|
||||
(cons method path))
|
||||
,@clauses))
|
||||
clause ...))))
|
||||
|
||||
(define (request-server-name request)
|
||||
(let ((headers (rref request 'headers)))
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
date-increment date-comparator date-before? date-after? compose1
|
||||
rfc822-date->timestamp timestamp->rfc822-date timestamp->atom-date
|
||||
timestamp->date string-split/trimming
|
||||
list-intersperse with-backtrace with-time-debugging define-memoized))
|
||||
list-intersperse with-backtrace with-time-debugging))
|
||||
|
||||
(define (emailish? x)
|
||||
(match-bind "^([a-zA-Z0-9._+-]+)@([a-zA-Z0-9-]+\\.)+[a-zA-Z]+$"
|
||||
|
|
@ -88,36 +88,26 @@
|
|||
(string-join (cons (passwd:dir (getpwnam user)) (cdr parts)) "/"))
|
||||
path)))
|
||||
|
||||
(define-macro (match-lines string pattern bindings expr)
|
||||
(let ((line (gensym)) (seed (gensym)))
|
||||
`(,fold
|
||||
(lambda (,line ,seed)
|
||||
(,match-bind ,pattern ,line ,bindings
|
||||
(cons ,expr ,seed)
|
||||
,seed))
|
||||
'() (string-split ,string #\newline))))
|
||||
|
||||
;; clause := ((pat args) body...)
|
||||
(define-macro (match-case string . clauses)
|
||||
(let ((str (gensym)))
|
||||
`(let ((,str ,string))
|
||||
,(let lp ((in clauses))
|
||||
(let ((clause (car in)))
|
||||
(if (eq? (car clause) 'else)
|
||||
`(begin ,@(cdr clause))
|
||||
`(match-bind ,(caar clause) ,str ,(cadar clause)
|
||||
(begin ,@(cdr clause))
|
||||
,(if (null? (cdr in))
|
||||
#f
|
||||
(lp (cdr in))))))))))
|
||||
(define-syntax match-lines
|
||||
(syntax-rules ()
|
||||
((_ string pattern bindings expr)
|
||||
(let ((rx (irregex pattern)))
|
||||
(fold
|
||||
(lambda (line seed)
|
||||
(match-bind rx line bindings
|
||||
(cons expr seed)
|
||||
seed))
|
||||
'() (string-split string #\newline))))))
|
||||
|
||||
(define (dbg fmt . args)
|
||||
(apply format (current-error-port) fmt args))
|
||||
|
||||
(define-macro (unwind-protect form . cleanups)
|
||||
`(dynamic-wind (lambda () #t)
|
||||
(lambda () ,form)
|
||||
(lambda () ,@cleanups)))
|
||||
(define-syntax unwind-protect
|
||||
(syntax-rules ()
|
||||
((_ form cleanup0 cleanups ...)
|
||||
(dynamic-wind (lambda () #t)
|
||||
(lambda () form)
|
||||
(lambda () cleanup0 cleanups ...)))))
|
||||
|
||||
(define (dsu-sort list key less)
|
||||
(map cdr
|
||||
|
|
@ -196,8 +186,10 @@
|
|||
(fluid-set! the-last-stack (make-stack #t 2 0))
|
||||
(apply throw args)))))
|
||||
|
||||
(define-macro (with-backtrace . forms)
|
||||
`(,with-backtrace* (lambda () ,@forms)))
|
||||
(define-syntax with-backtrace
|
||||
(syntax-rules ()
|
||||
((_ form0 forms ...)
|
||||
(with-backtrace* (lambda () form0 forms ...)))))
|
||||
|
||||
(define (gettimeofday-diff prev)
|
||||
(let ((now (gettimeofday)))
|
||||
|
|
@ -211,8 +203,10 @@
|
|||
(proc)
|
||||
(pk 'stop-clock (gettimeofday-diff start)))))
|
||||
|
||||
(define-macro (with-time-debugging . forms)
|
||||
`(,with-time-debugging* (lambda () ,@forms)))
|
||||
(define-syntax with-time-debugging
|
||||
(syntax-rules ()
|
||||
((_ form0 forms ...)
|
||||
(with-time-debugging* (lambda () form0 forms ...)))))
|
||||
|
||||
(define (memoize1 proc)
|
||||
(let ((old-args #f) (cache #f) (proc proc))
|
||||
|
|
@ -224,11 +218,6 @@
|
|||
(set! cache val)
|
||||
val)))))
|
||||
|
||||
(define-macro (define-memoized form . body)
|
||||
`(begin
|
||||
(define ,form ,@body)
|
||||
(set! ,(car form) (,memoize1 ,(car form)))))
|
||||
|
||||
(define (write-hash h)
|
||||
(write (hash-fold acons '() h)))
|
||||
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@
|
|||
#:use-module (tekuti template)
|
||||
#:use-module (tekuti page)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (let-headers header-ref
|
||||
#:export (header-ref
|
||||
handle-request))
|
||||
|
||||
(define *status-names*
|
||||
|
|
@ -53,17 +53,6 @@
|
|||
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
|
||||
"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
|
||||
|
||||
;;; useless macro
|
||||
(define-macro (let-headers headers bindings . body)
|
||||
(let ((headers-var (gensym)))
|
||||
`(let ((,headers-var ,headers))
|
||||
(let (,@(map (lambda (binding)
|
||||
`(,(car binding)
|
||||
(or (assoc-ref ,headers-var ,(cadr binding))
|
||||
(error "Missing header:" ,(cadr binding)))))
|
||||
bindings))
|
||||
,@body))))
|
||||
|
||||
(define (make-output request)
|
||||
(lambda (port)
|
||||
(let ((sxml (or (rref request 'sxml #f)
|
||||
|
|
|
|||
Loading…
Reference in a new issue