diff options
| author |  Tom Willemsen | 2012-08-14 23:44:27 +0200 |
|---|---|---|
| committer | Tom Willemsen | 2012-08-14 23:44:27 +0200 |
| commit | 50dc2da0b1710e6f93ffbbfca0db7e9f937a3d8a (patch) | |
| tree | 9e6ed6257c1202540c7a2f95a8e775434c409900 | |
| parent | d1bc934f9c392334f909889ab9d531efd2379188 (diff) | |
| download | undone-50dc2da0b1710e6f93ffbbfca0db7e9f937a3d8a.tar.gz undone-50dc2da0b1710e6f93ffbbfca0db7e9f937a3d8a.zip | |
Add sorting and don't collect result
| -rw-r--r-- | undone/main.scm | 57 |
1 files changed, 41 insertions, 16 deletions
diff --git a/undone/main.scm b/undone/main.scm index 90db4b1..663aa1e 100644 --- a/undone/main.scm +++ b/undone/main.scm @@ -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) - (let (#,@(map (lambda (field) - #`(#,field (cdr (assq (quote #,field) item)))) - #'(fields fields* ...))) - (if predicate - (format #t fmt - #,@(map (lambda (field) - field) - #'(fields fields* ...)))))) - todo-list)) + (for-each + (lambda (item) + (let (#,@(map (lambda (field) + #`(#,field + (cdr (assq (quote #,field) item)))) + #'(fields fields* ...))) + (if predicate + (format #t fmt + #,@(map (lambda (field) + field) + #'(fields fields* ...)))))) + #,(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") |