From bf68193be8d65bbbd63334c9c55986520bd3cadc Mon Sep 17 00:00:00 2001
From: Tom Willemsen <tom@ryuslash.org>
Date: Thu, 4 Oct 2012 11:08:19 +0200
Subject: [PATCH] Re-implement (part of) define-view in view.scm

This new macro should replace most of the functionality of the old
one, for the moment it only allows specification of what to print how.
---
 undone/main.scm | 56 -------------------------------------------------
 undone/view.scm | 23 +++++++++++++++++++-
 2 files changed, 22 insertions(+), 57 deletions(-)

diff --git a/undone/main.scm b/undone/main.scm
index aae732b..b9d0fcd 100644
--- a/undone/main.scm
+++ b/undone/main.scm
@@ -23,62 +23,6 @@
       ((_ key alist)
        #'(get-field-value key alist #f)))))
 
-(define-syntax define-view
-  (lambda (x)
-    (syntax-case x (where sort-by)
-      ((_ name doc fmt fields fields* ...
-          where predicate
-          sort-by sort-predicate sort-field)
-       (with-syntax ((view-name
-                      (datum->syntax
-                       x (symbol-append (syntax->datum #'name) '-view)))
-                     (filtered-list
-                      #`(filter (lambda (elm)
-                                  (and #,@(map
-                                           (lambda (field)
-                                             #`(get-field #,field elm))
-                                           #'(fields fields* ...))))
-                                todo-list)))
-         #`(begin
-             (define (view-name)
-               doc
-               (for-each
-                (lambda (item)
-                  (let (#,@(map
-                            (lambda (field)
-                              #`(#,field (get-field-value #,field item)))
-                            #'(fields fields* ...)))
-                    (if predicate
-                        (format #t fmt
-                                #,@(map (lambda (field)
-                                          field)
-                                        #'(fields fields* ...))))))
-                #,(if (syntax->datum #'sort-predicate)
-                      #`(stable-sort
-                         filtered-list
-                         (lambda (a b)
-                           (sort-predicate
-                            (get-field-value sort-field a)
-                            (get-field-value sort-field b))))
-                      #'filtered-list)))
-             (set! view-list
-                   (append view-list
-                           (list (cons 'name view-name)))))))
-      ((_ 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* ...)
-       #'(define-view name doc fmt fields fields* ...
-           where #t
-           sort-by #f nil)))))
-
 (define (stored-file xdg-env file)
   "Try to get FILE stored either in XDG-ENV or the home directory."
   (let ((xdg (getenv xdg-env))
diff --git a/undone/view.scm b/undone/view.scm
index 61ec5c7..80db915 100644
--- a/undone/view.scm
+++ b/undone/view.scm
@@ -1,7 +1,28 @@
 (define-module (undone view)
   #:use-module (oop goops)
   #:export (<view> view-list sort-view filter-view print-item
-                   get-list-for print-view view-doc))
+                   get-list-for print-view view-doc define-view))
+
+(define-syntax define-view
+  (lambda (x)
+    (syntax-case x (item)
+      ((_ name doc print-item-form)
+       (with-syntax ((view-name
+                      (datum->syntax
+                       x (symbol-append '< (syntax->datum #'name) '-view>)))
+                     (item (datum->syntax x 'item)))
+         #`(begin
+             (define-class view-name (<view>))
+
+             (define-method (view-doc (v view-name))
+               doc)
+
+             (define-method (print-item (v view-name) item)
+               print-item-form)
+
+             (set! view-list
+                   (append view-list
+                           (list (cons 'name view-name))))))))))
 
 (define-generic sort-view)
 (define-generic filter-view)