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-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 ()) + + (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)