225 lines
7 KiB
Scheme
225 lines
7 KiB
Scheme
(define-module (undone main)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (ice-9 rdelim)
|
|
#:use-module (oop goops)
|
|
#:use-module (undone view)
|
|
#:export (main))
|
|
|
|
(define-syntax get-field
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ key alist)
|
|
#'(assq (quote key) alist)))))
|
|
|
|
(define-syntax get-field-value
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ key alist default)
|
|
#'(let ((field (get-field key alist)))
|
|
(if field
|
|
(cdr field)
|
|
default)))
|
|
((_ 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))
|
|
(stored-file (string-append
|
|
(getenv "HOME") "/.undone/" file)))
|
|
(unless (or (file-exists? stored-file) (not xdg))
|
|
(set! stored-file (string-append xdg "/undone/" file)))
|
|
stored-file))
|
|
|
|
(define (config-file file)
|
|
"Try to get FILE from the configuration file location."
|
|
(stored-file "XDG_CONFIG_HOME" file))
|
|
|
|
(define (data-file file)
|
|
"Try to get FILE from the data file location."
|
|
(stored-file "XDG_DATA_HOME" file))
|
|
|
|
(define todo-list-file
|
|
(data-file "todo.scm"))
|
|
|
|
(define rc-file
|
|
(config-file "undonerc.scm"))
|
|
|
|
(define todo-list
|
|
(if (and todo-list-file (file-exists? todo-list-file))
|
|
(let* ((port (open-input-file todo-list-file))
|
|
(result (read port)))
|
|
(close-port port)
|
|
result)
|
|
'()))
|
|
|
|
(define view-list '())
|
|
|
|
(define (mkdirs path)
|
|
(let ((parent (dirname path)))
|
|
(if (not (file-exists? parent))
|
|
(mkdirs parent)))
|
|
|
|
(if (not (file-exists? path))
|
|
(mkdir path)))
|
|
|
|
(define (save)
|
|
"Save the list."
|
|
(mkdirs (dirname todo-list-file))
|
|
|
|
(let ((port (open-output-file todo-list-file)))
|
|
(write todo-list port)
|
|
(close-port port)))
|
|
|
|
(define (next-id)
|
|
"Look through all known todo items and get the next id."
|
|
(if (> (length todo-list) 0)
|
|
(1+ (apply max (map (lambda (elm)
|
|
(get-field-value id elm 0))
|
|
todo-list)))
|
|
1))
|
|
|
|
(define (add args)
|
|
"Add item to the list."
|
|
(set! todo-list
|
|
(append todo-list
|
|
(list
|
|
(append
|
|
`((id . ,(next-id))
|
|
(content . ,(string-trim-right (read-delimited ""))))
|
|
(map (lambda (arg)
|
|
(let* ((pair (string-split arg #\=))
|
|
(var (string->symbol (car pair)))
|
|
(val (cadr pair)))
|
|
(if (char=? (string-ref val 0) #\,)
|
|
(set! val (string-split
|
|
(substring val 1) #\,)))
|
|
|
|
(cons var val)))
|
|
args))))))
|
|
|
|
(define (delete args)
|
|
"Delete the specified element."
|
|
(set! todo-list
|
|
(filter (lambda (elm)
|
|
(not (eq? (get-field-value id elm)
|
|
(string->number (car args)))))
|
|
todo-list)))
|
|
|
|
(define-class <todo-view> (<view>))
|
|
|
|
(define-method (sort-view (v <todo-view>) l)
|
|
(reverse l))
|
|
|
|
(define-method (filter-view (v <todo-view>))
|
|
(lambda (elm)
|
|
(let ((state (assq 'state elm)))
|
|
(and state (not (string= (cdr state) "done"))))))
|
|
|
|
(define-method (print-item (v <todo-view>) item)
|
|
(format #t "~a ~a~%"
|
|
(cdr (assq 'state item))
|
|
(cdr (assq 'content item))))
|
|
|
|
(define-view default
|
|
"Default todo-list view, show only the title."
|
|
"~2d ~a~%" id content)
|
|
|
|
(define (view args)
|
|
"Show a list of todo items."
|
|
(let* ((view-name (or (and (pair? args) (car args))
|
|
"default"))
|
|
(view-symbol (string->symbol view-name))
|
|
(view-cons (assq view-symbol view-list))
|
|
(view-func (if view-cons (cdr view-cons) '())))
|
|
(if (procedure? view-func)
|
|
(apply view-func '()))))
|
|
|
|
(define (load-rc-file)
|
|
"Load the RC file containing custom views and such."
|
|
;; Ugly hack, can't thinkg of a better way right now, though...
|
|
(save-module-excursion
|
|
(lambda ()
|
|
(set-current-module (resolve-module '(undone main)))
|
|
(load rc-file))))
|
|
|
|
(define (main args)
|
|
(when (and rc-file (file-exists? rc-file))
|
|
(load-rc-file))
|
|
|
|
(if (> (length args) 1)
|
|
(case (string->symbol (cadr args))
|
|
((add)
|
|
(add (list-tail args 2))
|
|
(save))
|
|
((delete)
|
|
(delete (list-tail args 2))
|
|
(save))
|
|
((view)
|
|
(view (list-tail args 2)))
|
|
((views)
|
|
(display "Defined views:")
|
|
(newline)
|
|
(for-each
|
|
(lambda (view)
|
|
(format #t "~a~20t~a~%"
|
|
(car view) (procedure-documentation (cdr view))))
|
|
view-list))))
|
|
|
|
(print-view (make <todo-view> #:todo-list todo-list)))
|