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

Add sorting and don't collect result

Browse source
This commit is contained in:
Tom Willemsen 2012-08-14 23:44:27 +02:00
parent d1bc934f9c
commit 50dc2da0b1
1 changed files with 41 additions and 16 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

43
undone/main.scm
View file

@ -3,34 +3,59 @@
#:use-module (ice-9 rdelim)
#:export (main))
(define-syntax get-field
(lambda (x)
(syntax-case x ()
((_ key alist)
#'(cdr (assq (quote key) alist))))))
(define-syntax define-view
(lambda (x)
(syntax-case x (where)
((_ name doc fmt fields fields* ... where predicate)
(syntax-case x (where sort-by)
((_ name doc fmt fields fields* ...
where predicate
sort-by sort-predicate sort-field)
(with-syntax ((viewname
(datum->syntax
x (symbol-append (syntax->datum #'name) '-view))))
#`(begin
(define (viewname)
doc
(map (lambda (item)
(for-each
(lambda (item)
(let (#,@(map (lambda (field)
#`(#,field (cdr (assq (quote #,field) item))))
#`(#,field
(cdr (assq (quote #,field) item))))
#'(fields fields* ...)))
(if predicate
(format #t fmt
#,@(map (lambda (field)
field)
#'(fields fields* ...))))))
todo-list))
#,(if (syntax->datum #'sort-predicate)
#'(stable-sort
todo-list
(lambda (a b)
(sort-predicate (get-field sort-field a)
(get-field sort-field b))))
#'todo-list)))
(set! view-list
(append view-list
(list (cons 'name viewname)))))))
((_ name doc fmt fields fields* ...
sort-by sort-predicate sort-field)
#'(define-view name doc fmt fields fields* ...
where #t
sort-by sort-predicate sort-field))
((_ name doc fmt fields fields* ...
where predicate)
#'(define-view name doc fmt fields fields* ...
where predicate
sort-by #f nil))
((_ 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-view name doc fmt fields fields* ...
where #t
sort-by #f nil)))))
(define todo-list-file "todo.scm")