(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 "dependencies"
:description "Graph the dependencies of this project")
(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 "Reformat options")
(flag :long-name "reformat-file"
:short-name "f"
:description "Read the current timesheet file and dump, correcting any whitespace or formatting errors"))
(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))
(declare (ignorable 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 reformat-main ()
(with-tempores-configuration ()
(format t "~{~a~}"
(mapcar #'unparse
(parse-file *default-time-sheet-file*
t)))))
(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 "dependencies") (format t (tempores.package-grapher::graph-tempores-packages)))
((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")))
((getopt :long-name "reformat-file") (reformat-main))
(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))