ryuslash/undone
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Simplify macro

Browse source
This commit is contained in:
Tom Willemsen 2012-08-14 22:53:43 +02:00
parent 8681daf54a
commit d1bc934f9c
1 changed files with 15 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
undone/main.scm
View file

@ -5,8 +5,8 @@
(define-syntax define-view (define-syntax define-view
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x (where)
((_ name doc fmt fields fields* ...) ((_ name doc fmt fields fields* ... where predicate)
(with-syntax ((viewname (with-syntax ((viewname
(datum->syntax (datum->syntax
x (symbol-append (syntax->datum #'name) '-view)))) x (symbol-append (syntax->datum #'name) '-view))))
@ -15,16 +15,22 @@
doc doc
(map (lambda (item) (map (lambda (item)
(let (#,@(map (lambda (field) (let (#,@(map (lambda (field)
#`(#,field (cdr (assq (quote #,field) item)))) #`(#,field (cdr (assq (quote #,field) item))))
#'(fields fields* ...))) #'(fields fields* ...)))
(format #t fmt (if predicate
#,@(map (lambda (field) (format #t fmt
field) #,@(map (lambda (field)
#'(fields fields* ...))))) field)
#'(fields fields* ...))))))
todo-list)) todo-list))
(set! view-list (set! view-list
(append view-list (append view-list
(list (cons 'name viewname)))))))))) (list (cons 'name viewname)))))))
((_ name doc fmt fields fields* ...)
(with-syntax ((viewname
(datum->syntax
x (symbol-append (syntax->datum #'name) '-view))))
#'(define-view name doc fmt fields fields* ... where #t))))))
(define todo-list-file "todo.scm") (define todo-list-file "todo.scm")