@@ -28,10 +28,17 @@

 (defpackage #:timesheet

   (:use #:cl #:anaphora #:alexandria #:serapeum #:fwoar.lisputils

         #:timesheet.parser)

-  (:import-from #:format-string-builder #:define-message))

+  (:import-from #:format-string-builder #:define-message)

+  (:export #:with-timesheet-configuration #:pprint-log #:get-log #:timesheet

+           #:*default-time-sheet-file* #:*rate* #:group-by-class #:print-status

+           #:print-entries #:autocorrect-warning))

 (defpackage #:timesheet.cli

   (:use #:cl #:anaphora #:alexandria #:serapeum #:fwoar.lisputils

         #:timesheet.parser #:timesheet #:net.didierverna.clon)

   (:import-from #:format-string-builder #:define-message))

+(in-package #:timesheet)

+

+(defvar *default-time-sheet-file*)

+(defvar *rate*)

@@ -1,41 +1,191 @@

-

 (in-package #:timesheet.cli)

+(defparameter *interactive* nil)

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

+

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

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

-  (group (:header "Main actions")

-         (flag :short-name "c"

-               :long-name "client"

-               :description "Sort records by client")

-         (flag :short-name "r"

-               :long-name "reverse"

-               :description "Reverse the sort direction")

+  (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") 

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

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

-  (group (:header "Other options")

+               :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 "Generic options")

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

-               :description "Show the program version")  

+               :description "Show the program version")

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

                :description "Show this help")))

+(define-message version-message (version)

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

+

+(defun unroll-date (date-obj)

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

+    (list day month year)))

+

+(defun show-version ()

+  (version-message t *version*))

+

+(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 (timesheet.parser::failed-chunk c)))

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

+      (when success

+        (progn (warn 'timesheet::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 (timesheet.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 ((timesheet.parser::invalid-whitespace

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

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

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

+             (smug:parse (timesheet.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 pprint-log (args &key client reverse status ignore-whitespace interactive)

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

+           (setf results (sort-by-date results))

+           (when client

+             (setf results (stable-sort results #'string-lessp :key #'client)))

+           (when reverse

+             (setf results (nreverse results)))

+           results)

+         (get-logs (files)

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

+                 append (timesheet: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)))))))

+

 (defun pprint-log-main ()

   (make-context)

-  (cond 

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

-    (t (timesheet::with-timesheet-configuration ()

-         (timesheet::pprint-log

-           (remainder)

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

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

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

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

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

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

+  (tagbody

+    start

+    (restart-case

+      (cond

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

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

+        (t (with-timesheet-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 "timesheet" pprint-log-main))

+  (dump "timesheet" pprint-log-main

+        :compression 8

+        :purify t))

@@ -20,62 +20,6 @@

    (status-lines :initform nil :accessor :status-lines)

    (entries :initform nil :accessor :entries)))

-(defvar *default-time-sheet-file*)

-(defvar *rate*)

-(defparameter *interactive* nil)

-

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

-  (let ((time-parts (split-sequence #\: failed-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"))))

-        (if (and (< hours 24) (< minutes 60) (< seconds 60))

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

-          (values nil nil))))))

-

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

-  (flet ((parse-string (string)

-           (handler-bind ((timesheet.parser::invalid-whitespace

-                            (lambda (c) c

-                              (let ((extra-whitespace (timesheet.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 "")

-                                  (progn (format t "~&Whitespace errors~%")

-                                         (abort))))))

-                            (timesheet.parser::invalid-time

-                              (lambda (c) c

-                                (let ((time (timesheet.parser::failed-chunk c)))

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

-                                    (when success

-                                      (progn (warn 'autocorrect-warning

-                                                   :old-value time

-                                                   :new-value new-value)

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

-                                    (if *interactive*

-                                      (progn

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

-                                        (finish-output *query-io*)

-                                        (let ((replacement (read-line)))

-                                          (format t "~&Replacing ~s with ~s.~%---~%" time replacement)

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

-                                      (progn

-                                        (format t "~&Time ~a is invalid.~%" time)

-                                        (abort))))))))

-             (smug:parse (timesheet.parser::.date-records) string))))

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

-      (loop

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

-            (return parsed)

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

-      parsed)))

-

-(defun unroll-date (date-obj)

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

-    (list day month year)))

-

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

   (declare (optimize (debug 3)))

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

@@ -97,15 +41,15 @@

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

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

@@ -136,14 +80,9 @@

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

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

-  (let* ((entries (parse-file file ignore-whitespace)))

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

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

-(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 group-by-client (incompletes)

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

     (loop for incomplete in incompletes

@@ -168,11 +107,12 @@

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

+   (: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)))

+  (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

@@ -180,24 +120,14 @@

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

              (print-separator ()

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

-      (let ((client-totals (client-totals status-calculator)))

+      (let-each (:be *)

         (print-separator)

-        (let-each (:be *)

-          (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 pprint-results (results incompletes status)

-  (print-entries results)

+        (hash-table-keys client-totals)

+        (sort * #'string-lessp)

+        (dolist (client *)

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

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

-  (when incompletes

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

-    (print-entries incompletes))

-

-  (when status

-    (print-status results)))

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

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

@@ -211,37 +141,6 @@

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

         (go start))))) ; Recurse

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

-  (when help

-    (show-help)

-    (return-from pprint-log))

-

-  (when version

-    (show-version)

-    (return-from pprint-log))

-

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

-           (setf results (sort-by-date results))

-           (when client

-             (setf results (stable-sort results #'string-lessp :key #'client)))

-           (when reverse

-             (setf results (nreverse results)))

-           results)

-         (get-logs (files)

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

-                 append (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)))))))

-

 (defmacro with-timesheet-configuration (() &body body)

   `(progn

      (ubiquitous:restore 'timesheet)