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

Compare commits

merge into: ryuslash:master
Branches Tags
ryuslash:master
ryuslash:goops
...
pull from: ryuslash:goops
Branches Tags
ryuslash:goops
ryuslash:master
Sign in to create a new pull request.

11 commits
master ... goops

Author SHA1 Message Date
Tom Willemsen
641d76c490 Use primitive-load to avoid compilation 
Since the docstrings are no longer docstring the undonerc file doesn't
need to be compiled anymore.
 2012-10-04 12:16:13 +02:00
Tom Willemsen
bf68193be8 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.
 2012-10-04 11:08:19 +02:00
Tom Willemsen
d6c24c4346 Add view-doc generic 
This function should return a string that explains what the view does.
This should remove the need to compile the undonerc in order to get
the explanation.
 2012-10-04 11:05:30 +02:00
Tom Willemsen
35683db0e6 Compile view.scm first 
This is to avoid automatic compilation to the cache when main.scm is
being built.
 2012-10-04 10:52:11 +02:00
Tom Willemsen
436f57cb55 Add update command 
* undone/main.scm (args->alist): Place argument parsing for add/update
  in separate function for reuse.
  (delete-item): Renamed from `delete', which is in conflict with
  guile's own `delete'.
  (update): New function.
 2012-10-02 02:14:27 +02:00
Tom Willemsen
5e4c1f54f4 Remove <todo-view> definition 
This was only there for testing purposes, it has been moved to my rc file.
 2012-10-01 00:36:22 +02:00
Tom Willemsen
ffcd87e06f Make the <view> class do its work 
I still need to rewrite the macros to work with this new style of
view.
 2012-10-01 00:35:05 +02:00
Tom Willemsen
dcd44d1e93 Seperate view code and clarify the proof 2012-09-27 01:41:02 +02:00
Tom Willemsen
8463e3dec0 Don't fail when generating first id 2012-09-26 19:52:42 +02:00
Tom Willemsen
9c683792be Improve loading of files 2012-09-26 19:52:02 +02:00
Tom Willemsen
40566cee5b GOOPS "Proof of concept" 
Doesn't actually do anything yet, but shows where to start.
 2012-09-26 01:05:41 +02:00
3 changed files with 112 additions and 96 deletions
Show stats Expand all files Collapse all files

2
undone/Makefile
View file

@ -3,7 +3,7 @@ SITEDIR = $(shell pkg-config guile-2.0 --variable=sitedir \
--define-variable=prefix=$(DESTDIR))
COMPDIR = $(DESTDIR)/lib/guile/2.0/site-ccache
objects = main.scm main.go
objects = view.scm view.go main.scm main.go
install-objects = $(addprefix install-,$(objects))
uninstall-objects = $(addprefix uninstall-,$(objects))

146
undone/main.scm
View file

@ -1,6 +1,9 @@
(define-module (undone main)
#:use-module (ice-9 format)
#:use-module (ice-9 rdelim)
#:use-module (oop goops)
#:use-module (srfi srfi-1)
#:use-module (undone view)
#:export (main))
(define-syntax get-field
@ -20,77 +23,14 @@
((_ 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))
(home (getenv "HOME"))
(result #f))
(cond
(xdg
(let ((xdg-stored-file (string-append xdg "/undone/" file)))
(when (file-exists? xdg-stored-file)
(set! result xdg-stored-file))))
(home
(let ((home-stored-file (string-append home "/.undone/" file)))
(when (file-exists? home-stored-file)
(set! result home-stored-file)))))
result))
(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."
@ -114,8 +54,6 @@
result)
'()))
(define view-list '())
(define (mkdirs path)
(let ((parent (dirname path)))
(if (not (file-exists? parent))
@ -134,9 +72,21 @@
(define (next-id)
"Look through all known todo items and get the next id."
(1+ (apply max (map (lambda (elm)
(get-field-value id elm 0))
todo-list))))
(if (> (length todo-list) 0)
(1+ (apply max (map (lambda (elm)
(get-field-value id elm 0))
todo-list)))
1))
(define (args->alist args)
(map (lambda (arg)
(let* ((pair (string-split arg #\=))
(var (string->symbol (car pair)))
(val (cadr pair)))
(when (char=? (string-ref val 0) #\,)
(set! val (string-split (substring val 1) #\,)))
(cons var val)))
args))
(define (add args)
"Add item to the list."
@ -146,18 +96,9 @@
(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) #\,)))
(args->alist args))))))
(cons var val)))
args))))))
(define (delete args)
(define (delete-item args)
"Delete the specified element."
(set! todo-list
(filter (lambda (elm)
@ -165,19 +106,17 @@
(string->number (car args)))))
todo-list)))
(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"))
(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 '()))))
(view-class (if view-cons (cdr view-cons) '())))
(if (or (eq? <view> view-class)
(memq view-class (class-subclasses <view>)))
(print-view (make view-class #:todo-list todo-list))
(format #t "Unknown view: ~a~%" view-name))))
(define (load-rc-file)
"Load the RC file containing custom views and such."
@ -185,7 +124,21 @@
(save-module-excursion
(lambda ()
(set-current-module (resolve-module '(undone main)))
(load rc-file))))
(primitive-load rc-file))))
(define (update args)
(let ((item
(find (lambda (elm)
(let ((id (assq 'id elm)))
(and id (eq? (cdr id) (string->number (car args))))))
todo-list))
(alist (args->alist (cdr args))))
(set! todo-list (delete item todo-list))
(for-each
(lambda (elm)
(set! item (assq-set! item (car elm) (cdr elm))))
alist)
(set! todo-list (append (list item) todo-list))))
(define (main args)
(when (and rc-file (file-exists? rc-file))
@ -197,15 +150,18 @@
(add (list-tail args 2))
(save))
((delete)
(delete (list-tail args 2))
(delete-item (list-tail args 2))
(save))
((view)
(view (list-tail args 2)))
((update)
(update (list-tail args 2))
(save))
((views)
(display "Defined views:")
(newline)
(for-each
(lambda (view)
(format #t "~a~20t~a~%"
(car view) (procedure-documentation (cdr view))))
(car view) (view-doc (make (cdr view)))))
view-list)))))

60
undone/view.scm Normal file
View file

@ -0,0 +1,60 @@
(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 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)
(define-generic print-item)
(define-generic get-list-for)
(define-generic print-view)
(define-generic view-doc)
(define-class <view> ()
(todo-list #:init-value '() #:init-keyword #:todo-list))
(define view-list `((view . ,<view>)))
(define-method (sort-view (v <view>) l) l)
(define-method (print-item (v <view>) item)
(format #t "~2d ~a~%"
(cdr (assq 'id item))
(cdr (assq 'content item))))
(define-method (filter-view (v <view>))
(lambda (elm)
(and (assq 'id elm) (assq 'content elm))))
(define-method (get-list-for (v <view>))
(filter (filter-view v)
(sort-view v (slot-ref v 'todo-list))))
(define-method (print-view (v <view>))
(for-each
(lambda (item) (print-item v item))
(get-list-for v)))
(define-method (view-doc (v <view>))
"Default view, show only the basics.")