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