new file mode 100644

@@ -0,0 +1,229 @@

+(in-package #:tempores.cli)

+

+(defparameter *interactive* nil)

+(defparameter *version* "0:7")

+

+(defun unroll-date (date-obj)

+  (with-slots (year month day) date-obj

+    (list day month year)))

+

+(defun split-time (time)

+  (let ((time-parts (split-sequence #\: time)))

+    (destructuring-bind (hours minutes . optional-seconds) time-parts

+      (let ((hours (parse-integer hours))

+            (minutes (parse-integer minutes))

+            (seconds (parse-integer (or (car optional-seconds) "0")))

+            (extra (cdr optional-seconds)))

+        (values hours minutes seconds extra)))))

+

+(defun try-fix-time (failed-time)

+  (handler-case

+    (multiple-value-bind (hours minutes seconds extra) (split-time failed-time)

+      (if (and (< hours 24) (< minutes 60) (< seconds 60) (null extra))

+        (values (format nil "~2,'0d:~2,'0d:~2,'0d" hours minutes seconds) t)

+        (values nil nil)))

+    (parse-error (c) c (values nil nil))))

+

+(defun call-with-prompt (stream prompt args cb)

+  (apply #'format stream prompt args)

+  (finish-output *query-io*)

+  (funcall cb (read-line *query-io*)))

+

+(defmacro with-prompt ((result-sym stream prompt &rest args) &body body)

+  `(call-with-prompt ,stream ,prompt (list ,@args)

+                     (lambda (,result-sym)

+                       ,@body)))

+

+(defun abort-with-message (stream message &rest args)

+  (apply #'format stream message args)

+  (abort))

+

+(define-condition parse-time-error (parse-error)

+  ((time-string :initarg :time-string :accessor time-string))

+  (:report (lambda (condition stream)

+             (format stream "Time input did not parse correctly: ~s" (time-string condition)))))

+

+(defun call-with-prompt-for-time (stream prompt args cb)

+  (call-with-prompt

+    stream prompt args

+    (lambda (time-string)

+      (multiple-value-bind (hours minutes seconds extra) (split-time time-string)

+        (funcall cb hours minutes seconds extra)))))

+

+(defmacro with-prompt-for-time ((result-syms stream prompt &rest args) &body body)

+  `(call-with-prompt-for-time ,stream ,prompt (list ,@args)

+                              (lambda (,@result-syms)

+                                ,@body)))

+

+(define-message format-time (hours minutes &optional (seconds 0))

+  (:decimal 2 '0) #\: (:decimal 2 '0) #\: (:decimal 2 '0))

+

+(defun handle-invalid-time (c) c

+  (let ((time (tempores.parser::failed-chunk c)))

+    (multiple-value-bind (new-value success) (try-fix-time time)

+      (when success

+        (progn (warn 'tempores::autocorrect-warning

+                     :old-value time

+                     :new-value new-value)

+               (smug:replace-invalid time new-value))))

+    (if *interactive*

+      (loop

+        (handler-case

+          (with-prompt-for-time ((hours minutes seconds &rest rest)

+                                 *query-io* "Invalid time ~a, replacement? " time)

+            (declare (ignore rest))

+            (let ((replacement (format-time nil hours minutes seconds)))

+              (format *query-io* "~&Replacing ~s with ~s.~%---~%" time replacement)

+              (smug:replace-invalid time replacement)))

+          (parse-error (c) c (format t "~&Invalid entry.~%"))))

+      (abort-with-message t "~&Time ~a is invalid.~%" time))))

+

+(defun handle-invalid-whitespace (ignore-whitespace-errors)

+  (lambda (c) c

+    (let ((extra-whitespace (tempores.parser::failed-chunk c)))

+      (if (or ignore-whitespace-errors

+              (when *interactive*

+                (y-or-n-p "Invalid extra whitespace ~s, truncate?" extra-whitespace)))

+        (smug:replace-invalid extra-whitespace "")

+        (abort-with-message t "~&Whitespace errors~%")))))

+

+(defun parse-file (&optional (file *default-time-sheet-file*) ignore-whitespace-errors)

+  (flet ((parse-string (string)

+           (handler-bind ((tempores.parser::invalid-whitespace

+                            (handle-invalid-whitespace ignore-whitespace-errors))

+                          (parse-error #'handle-invalid-time)

+                          (tempores.parser::invalid-time #'handle-invalid-time) )

+             (smug:parse (tempores.parser::.date-records) string))))

+    (multiple-value-bind (parsed leftovers) (parse-string (read-file-into-string file))

+      (if (or (null leftovers) (string= leftovers ""))

+        parsed

+        (cerror "Continue?" 'parsing-error :leftovers leftovers)))))

+

+(defun pprint-results (results incompletes status)

+  (print-entries results)

+

+  (when incompletes

+    (format t "~&~120,1,0,'-<~>~%Partial Entries:~%")

+    (print-entries incompletes))

+

+  (when status

+    (print-status results)))

+

+(defun sort-by-date (results)

+  (stable-sort results #'local-time:timestamp<

+               :key (alambda (apply #'local-time:encode-timestamp

+                                    (list* 0 0 0 0 (unroll-date (date it)))))))

+

+(defun maybe-nreverse (flag list)

+  (if flag

+    (nreverse list)

+    list))

+

+(define-modify-macro maybe-nreversef (flag)

+                     (lambda (place flag)

+                       (maybe-nreverse flag place)))

+

+(defun list-without-nulls (&rest items)

+  (loop for item in items

+        when item collect item))

+

+(defun pprint-log (args &key client reverse status ignore-whitespace interactive)

+  (labels ((sort-func (client)

+             (apply #'compose

+                    (list-without-nulls

+                      (when reverse #'nreverse)

+                      (when client

+                        (plambda (stable-sort :1 #'string-lessp :key #'client)))

+                      #'sort-by-date)))

+           (sort-results (results &optional (client client))

+             (funcall (sort-func client) results))

+           (get-logs (files)

+             (loop for file in (ensure-list files)

+                   append (tempores:get-log file ignore-whitespace)) ))

+

+    (let ((*default-time-sheet-file* (or args *default-time-sheet-file*))

+          (*interactive* interactive)

+          (*print-pretty* t))

+      (let-each (:be *)

+        (get-logs *default-time-sheet-file*)

+        (group-by-class *)

+        (destructuring-bind (complete-ranges incomplete-ranges) *

+          (let ((complete-results (sort-results complete-ranges client))

+                (incomplete-results (sort-results incomplete-ranges t)))

+            (pprint-results complete-results incomplete-results status)))))))

+

+(defsynopsis (:postfix "TIMESHEETS ...")

+  (text :contents "A program for managing logs of hours worked")

+  (group (:header "Display options")

+         (flag :short-name "s" :long-name "status"

+               :description "Print a short summary of work status")

+         (flag :short-name "W"

+               :long-name "ignore-whitespace"

+               :description "Ignore whitespace errors in input")

+         (flag :short-name "i" :long-name "interactive"

+               :description "Run interactively"))

+  (group (:header "Sort options")

+         (flag :short-name "r"

+               :long-name "reverse"

+               :description "Reverse the sort direction")

+         (flag :short-name "c"

+               :long-name "client"

+               :description "Sort records by client"))

+  (group (:header "Freshbooks")

+         (flag :long-name "post-hours"

+               :description "Post hours to freshbooks (requires manual setup of Freshbooks keys)"))

+  (group (:header "Self-test options")

+         (flag :long-name "run-tests"

+               :description "Run the tests")

+         (enum :long-name "output-style"

+               :description "The kind of output to produce"

+               :default-value :normal

+               :enum '(:xunit :normal)))

+  (group (:header "Generic options")

+         (flag :short-name "v" :long-name "version"

+               :description "Show the program version")

+         (flag :short-name "h" :long-name "help"

+               :description "Show this help")))

+

+(eval-when (:load-toplevel :compile-toplevel :execute)

+  (define-message version-message (version)

+    (:own-line () "tempores file parser, version " :str)))

+

+(defun show-version ()

+  (version-message t *version*))

+

+(defun tests-main (&optional (output-style nil output-style-p))

+  (let ((should-test:*verbose* t))

+    (ecase output-style

+      (:xunit (should-test:test-for-xunit *standard-output* :package :tempores.parser))

+      (:normal (should-test:test :package :tempores.parser)))))

+

+(defun pprint-log-main ()

+  (make-context)

+  (tagbody

+    start

+    (restart-case

+      (cond

+        ((getopt :long-name "help") (help))

+        ((getopt :long-name "version") (show-version))

+        ((getopt :long-name "post-hours") (let ((*print-pretty* nil))

+                                            (loop for item in (tempores.freshbooks::post-time-entries-main)

+                                                  do (format t "Posted an entry")

+                                                  do (plump:serialize item)

+                                                  finally (format t "Don't forget to archive time file."))))

+        ((getopt :long-name "run-tests") (tests-main (getopt :long-name "output-style")))

+        (t (with-tempores-configuration ()

+             (pprint-log

+               (remainder)

+               :client (getopt :long-name "client")

+               :interactive (getopt :long-name "interactive")

+               :ignore-whitespace (getopt :long-name "ignore-whitespace")

+               :status (getopt :long-name "status")

+               :reverse (getopt :long-name "reverse")))))

+      (retry () (go start))

+      (abort ()))))

+

+(defun make-executable ()

+  (dump "tempores" pprint-log-main

+        :compression 8

+        :purify t))

new file mode 100644

@@ -0,0 +1,146 @@

+;; tempores.lisp

+

+(in-package #:tempores)

+

+;;; "tempores" goes here. Hacks and glory await!

+

+(defmacro maybe-list (test &optional val)

+  "If both arguments passed, when test is true, return a list containing val

+   or, when test is false, return nil.  If one argument passed, when test names

+   something that is not a list, return a list containing it, otherwise

+   return nil."

+  (once-only (test)

+    (let ((test (if val test `(not (listp ,test))))

+          (val (if val val test)))

+      `(when ,test

+         (list ,val)))))

+

+(defun combine-date-time (time-obj day month year)

+  (declare (optimize (debug 3)))

+  (with-slots (second minute hour) time-obj

+    (local-time:encode-timestamp 0 second minute hour

+                                 day month year)))

+

+(defun calculate-ranges (ranges date)

+  (declare (optimize (debug 3)))

+  (labels ((time-mod-unit-keyword (time-mod)

+             (make-keyword

+               (string-upcase

+                 (string-case (string-downcase (slot-value time-mod 'unit))

+                   ("mins" "minute")

+                   (t      "hour")))))

+           (make-mod (mod)

+             (when mod

+               (let ((unit (time-mod-unit-keyword mod))

+                     (amount (slot-value mod 'tempores.parser:amount)))

+                 (funcall #'local-time-duration:duration unit amount)))))

+    (with-slots (year month day) date

+      (loop with complete = nil

+        with partial = nil

+        for (start-obj end-obj mod) in ranges

+        for start = (combine-date-time start-obj day month year)

+        for end = (when end-obj (combine-date-time end-obj day month year))

+        for time-mod = (when mod (make-mod mod))

+        if end do (push (local-time-duration:timestamp-difference end start) complete)

+        else do (push start partial)

+        when time-mod do (push time-mod complete)

+        finally (return (values complete partial))))))

+

+(defun calculate-duration-in-15mins (duration)

+  (let ((duration-in-minutes (local-time-duration:duration-as duration :minute)))

+    (coerce (/ (round duration-in-minutes 15) 4)

+            'float)))

+

+(defun calculate-rounded-ranges (ranges)

+  (let-each (:be *)

+    (local-time-duration:duration)

+    (reduce #'local-time-duration:duration+ ranges :initial-value *)

+    (calculate-duration-in-15mins *)))

+

+(defclass log-entry ()

+  ((complete :initarg :complete)

+   (incomplete :initarg :incomplete)))

+

+(defun get-entry-ranges (entry)

+  (flet ((make-entry (record)

+           (let ((date (slot-value entry 'date)))

+             (with-slots (client memo ranges) record

+               (multiple-value-bind (complete partial) (calculate-ranges ranges date)

+                 (list*

+                   (make-complete-entry date client memo (calculate-rounded-ranges complete))

+                   (maybe-list partial

+                               (make-partial-entry date client memo partial))))))))

+    (let-each (:be *)

+      (slot-value entry 'records)

+      (mapcan #'make-entry *))))

+

+(defun get-log (&optional (file *default-time-sheet-file*) ignore-whitespace)

+  (let* ((entries (tempores.cli::parse-file file ignore-whitespace)))

+    (mapcan #'get-entry-ranges entries)))

+

+(defun group-by-client (incompletes)

+  (let ((results (make-hash-table :test 'equalp)))

+    (loop for incomplete in incompletes

+          for client = (client incomplete)

+          do (push incomplete (gethash client results)))

+    (hash-table-alist results)))

+

+(defun update-clients (status-calculator entry)

+  (flet ((ensure-client (client)

+           (ensure-gethash client

+                           (client-totals status-calculator)

+                           (make-instance 'status-line :client client))))

+    (with-accessors ((client client)) entry

+      (let ((client-hash-table (ensure-client client)))

+        (update client-hash-table entry)))))

+

+(defun calculate-results (results &optional (rate *rate*))

+  (let-first (:be status-calculator) (make-status-calculator rate)

+    (dolist (result results)

+      (update-clients status-calculator result)

+      (update status-calculator result))))

+

+(define-message status-line-format (client duration rate cost)

+  (:own-line ()

+   (:titlecase () (:rjust (26) :str))

+   ": " (:float 7 2) " hours @ " (:float 7 2) " $/hr = $" (:float 7 2)))

+

+(defun print-status (results)

+  (let* ((status-calculator (calculate-results results))

+         (client-totals (client-totals status-calculator)))

+    (labels ((print-status-line (status-line)

+               (with-slots (client duration) status-line

+                 (status-line-format t client duration

+                                     (rate status-calculator)

+                                     (calculate-cost status-calculator status-line))))

+             (print-separator ()

+               (format t "~&~120,1,0,'-<~>~%")))

+      (let-each (:be *)

+        (print-separator)

+        (hash-table-keys client-totals)

+        (sort * #'string-lessp)

+        (dolist (client *)

+          (print-status-line (gethash client client-totals)))

+        (format t (total-line status-calculator *rate*))))))

+

+

+(defun group-by-class (list &optional accum1 accum2)

+  (tagbody ; Let's do some TCO ...

+    start

+    (if (null list)

+      (return-from group-by-class (list accum1 accum2))

+      (destructuring-bind (head . tail) list

+        (etypecase head

+          (complete-entry (setf accum1 (cons head accum1))) ; Here we set the accumulators

+          (partial-entry (setf accum2 (cons head accum2)))) ;  to the appropriate values.

+        (setf list tail) ; Here we step towards the terminating condition

+        (go start))))) ; Recurse

+

+(defmacro with-tempores-configuration (() &body body)

+  `(progn

+     (ubiquitous:restore 'tempores)

+     (let ((*rate* (ubiquitous:defaulted-value 0 :rate))

+           (*default-time-sheet-file*

+             (ubiquitous:defaulted-value #p"~/bucket/time.md" :tempores :file)))

+       ,@body)))

+