From 50dc2da0b1710e6f93ffbbfca0db7e9f937a3d8a Mon Sep 17 00:00:00 2001
From: Tom Willemsen <tom@ryuslash.org>
Date: Tue, 14 Aug 2012 23:44:27 +0200
Subject: [PATCH] Add sorting and don't collect result

---
 undone/main.scm | 57 +++++++++++++++++++++++++++++++++++--------------
 1 file 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")