undone/undone/main.scm

(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
  (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 (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 (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."
  (set! todo-list
        (append todo-list
                (list
                 (append
                  `((id . ,(next-id))
                    (content . ,(string-trim-right (read-delimited ""))))
                  (args->alist args))))))

(define (delete-item 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 (view args)
  "Show a list of todo items."
  (let* ((view-name (or (and (pair? args) (car args))
                        "view"))
         (view-symbol (string->symbol view-name))
         (view-cons (assq view-symbol view-list))
         (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."
  ;; 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 (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))
    (load-rc-file))

  (if (> (length args) 1)
      (case (string->symbol (cadr args))
        ((add)
         (add (list-tail args 2))
         (save))
        ((delete)
         (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))))
          view-list)))))