ryuslash/undone
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Re-implement (part of) define-view in view.scm

Browse source 
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.
This commit is contained in:
Tom Willemsen 2012-10-04 11:08:19 +02:00
parent d6c24c4346
commit bf68193be8
2 changed files with 22 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

56
undone/main.scm
View file

@ -23,62 +23,6 @@
((_ key alist) ((_ key alist)
#'(get-field-value key alist #f))))) #'(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) (define (stored-file xdg-env file)
"Try to get FILE stored either in XDG-ENV or the home directory." "Try to get FILE stored either in XDG-ENV or the home directory."
(let ((xdg (getenv xdg-env)) (let ((xdg (getenv xdg-env))

23
undone/view.scm
View file

@ -1,7 +1,28 @@
(define-module (undone view) (define-module (undone view)
#:use-module (oop goops) #:use-module (oop goops)
#:export (<view> view-list sort-view filter-view print-item #: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 sort-view)
(define-generic filter-view) (define-generic filter-view)