Use primitive-load to avoid compilation

Since the docstrings are no longer docstring the undonerc file doesn't
need to be compiled anymore.

undone/Makefile

@@ -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))
 

undone/main.scm

@@ -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"))
+        (stored-file (string-append
-        (result #f))
+                      (getenv "HOME") "/.undone/" file)))
-    (cond
+    (unless (or (file-exists? stored-file) (not xdg))
-     (xdg
+      (set! stored-file (string-append xdg "/undone/" file)))
-      (let ((xdg-stored-file (string-append xdg "/undone/" file)))
+    stored-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))
 
 (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."
+  (if (> (length todo-list) 0)
       (1+ (apply max (map (lambda (elm)
                             (get-field-value id elm 0))
-                      todo-list))))
+                          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)
+                  (args->alist args))))))
-                         (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)))
+(define (delete-item args)
-                       args))))))
-
-(define (delete 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) '())))
+         (view-class (if view-cons (cdr view-cons) '())))
-    (if (procedure? view-func)
+    (if (or (eq? <view> view-class)
-        (apply view-func '()))))
+            (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)))))

undone/view.scm

@@ -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.")