;;; -*- lexical-binding: t -*-
;;; tacc.el --- A pomidoro timer supporting tags and customizable export

;; Author: Brady McDonough <me@bradymcd.ca>
;; URL: git.bradymcd.ca/brady/tacc
;; Keywords: tools, time, pomidoro, accountability
;; Version: 0.0.1
;;

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or version 3 at your
;; option.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This implements a slightly modified pomidoro timer with a focus on
;; programmer customizability.
;; By default it is just a timer and the serialization and recording of your
;; time data is up to you (if that's something you even need)
;; Each successive work and break timer may be longer than the last. Work time
;; can also be tagged for better time accounting.

;;; Index:
;; 01.1 Indexed settings variables
;; 01.2 Indexed face settings
;; 02   Error types
;; 03   Behaviour group
;; 03.1 Tag prompt text completion
;; 03.2 Sound
;; 04   Record keeping
;; 05   Timer display buffer
;; 05.2 State checks
;; 05.3 State manipulation
;; 05.4 Timer buffer rendering
;; 07   Initialization
;; 08.1 Interactive helpers
;; 08.2 Interactive functions
;; 09   Hooks registration
;; 10   Provides

;;; Code:

;; TODOS:
;; ERROR: timer shutdown seems to leave things in a wrong state and buffer doesn't die properly
;;         Check on the logic of push-current, needs predicates rather than lazy if conditions
;;         I'm not calling anything to destroy the buffer on desched
;; BUG: The buffer is immortal?
;;

;; Optional
(require 'icicles nil t)

;; 01.1 Customs and Indexed Variables
(defconst tacc-dir (file-name-directory load-file-name))

(defgroup tacc nil
  "Root group definition for tacc"
  :prefix "tacc-"
  :group 'applications)

(defcustom tacc-buffer-name "*Work Timer*"
  "The name used for the timer display buffer"
  :type 'string :group 'tacc)

(defcustom tacc-suppress-tag-prompt t
  "If set nil tacc will ask for a new tag every time a work period begins"
  :type 'boolean :group 'tacc)

(defvar tacc-display-buffer-settings '((display-buffer-below-selected)
                                       (inhibit-same-window . t)
                                       (dedicated . t))
  "Passed into display-buffer. How a window should be created or reused")

(defvar tacc-display-buffer-window-settings '((window-min-height . 10)
                                              (window-height . 0.25))
  "Passed into display-buffer. The window's overall size")

(defun m:s (mins secs)
  "Readability function for minute and second values"
  (+ secs (* 60 mins)))

(defcustom tacc-work-seconds (m:s 30 0)
  "The length of a base pomidoro round"
  :type 'integer :group 'tacc)

(defcustom tacc-work-seconds-increment 0
  "The time to add to each successive work cycle"
  :type 'integer :group 'tacc)

(defcustom tacc-break-seconds (m:s 5 0)
  "The length of a base break round"
  :type 'integer :group 'tacc)

(defcustom tacc-break-seconds-increment 0
  "The time to add to each successive break cycle"
  :type 'integer :group 'tacc)

(defcustom tacc-chime-interval (m:s 0 27)
  "The time between alerts for timers running past their length"
  :type 'integer :group 'tacc)

;; 01.2 Faces
(defgroup tacc-faces nil
  "Custom faces for tacc"
  :group 'tacc
  :group 'faces
  :prefix "tacc-")

(defface tacc-graph-work
  '((t :inherit success))
  "For work graph bars"
  :group 'tacc-faces)

(defface tacc-graph-break
  '((t :inherit warning))
  "For break graph bars"
  :group 'tacc-faces)

(defface tacc-graph-void
  '((t :inherit shadow))
  "For filler graph bars"
  :group 'tacc-faces)

(defface tacc-clock
  '((t :height 3.0))
  "For the clock and timer"
  :group 'tacc-faces)

(defface tacc-clock-pause
  '((t :inherit (tacc-clock italic ansi-slow-blink)))
  "For the timer while the timer isn't running"
  :group 'tacc-faces)

(defface tacc-overwork
  '((t :inherit (tacc-clock error)))
  "for the timer whenever we are in overwork"
  :group 'tacc-faces)

(defface tacc-tag
  '((t :inherit link-visited))
  "The face the tag is printed in"
  :group 'tacc-faces)

;; 02 Errors
(define-error 'tacc-error "Generic error from the tacc-timer module" 'error)
(define-error 'tacc-error-illegal-buffer-state
  "Precondition failed, the timer buffer is in an invalid state" 'tacc-error)
(define-error 'tacc-error-serialization-registered
  "Failed to register a serialization, serializations must have unique names"
  'tacc-error)

;; 03 Behavior group
(defgroup tacc-behavior nil
  "Low level behavior settings for tacc"
  :group 'tacc
  :prefix "tacc-")

;; 03.1 Tag prompts and completion
(defvar tacc-tag-history nil
  "Tag name history, used for completions")

(defcustom tacc-tag-history-file
  (expand-file-name "tags-history" tacc-dir)
  "Tag history storage file, for completions"
  :type '(file :must-match t)
  :group 'tacc-behavior)

(defcustom tacc-tag-completion-functions nil
  "A list of user defined functions for generating completions for tagging.
Each function must have no required arguments and return a list of strings"
  :type 'hook
  :group 'tacc-behavior)

(defun tacc-load-tag-history ()
  "Load completions for tags"
  (with-temp-buffer
    (insert-file-contents tacc-tag-history-file)
    (setq tacc-tag-history (split-string (buffer-string) "\n"))))

(defun tacc-save-tag-history ()
  "Save completions for tags"
  (with-temp-file tacc-tag-history-file
    (insert (mapconcat 'identity
                       tacc-tag-history
                       "\n"))))

;; 03.2 Sound
(defcustom tacc-sound-tick
  (expand-file-name "tick.wav" tacc-dir)
  "The 'Tick' sound of the timer"
  :type '(file :must-match t)
  :group 'tacc-behavior)

(defcustom tacc-sound-chime
  (expand-file-name "chime.wav" tacc-dir)
  "The break and work alarm sound of the timer"
  :type '(file :must-match t)
  :group 'tacc-behavior)

(defun tacc-play-sound-file-emacs (file)
  "Play some file in a child emacs process"
  (if (fboundp 'play-sound-internal)
      (start-process "tacc-play-sound"
                     nil
                     (car command-line-args)
                     "--batch"
                     "--eval" (format "(play-sound-file \"%s\")" file))
    (warn "Emacs lacks builtin sound support")))

(defcustom tacc-play-sound-file #'tacc-play-sound-file-emacs
  "Asyncronous function to play sounds. Set to nil to disable sound"
  :type '(choice (const nil)
                 function)
  :group 'tacc-behavior)

;; 04 Record keeping
(defvar tacc-serials '()
  "A list of serialization functions keyed with names registered at runtime")

(defun tacc-register-serialization (name serialize)
  "The supplied `serialize' function will be run every time a work session has
ended, either because `tacc-end-timer' was called by the user or when emacs
closes with a session still live. Supplied serialize function must take as an
argument a cons list of records.
A record is an alist layed out as follows:
`(:ts    . <unix timestamp>)
 (:end   . <unix timestamp>)
 (:state . <:break | :work>)
 (:tag   . <an assigned tag name>)'
The supplied `name' will be used to generate a new (empty) abnormal hook,
`tacc-<name>-output-functions'. Each function added to this hook will be
called with the output of the `serialize' function as an argument. Keep in
mind that this is *not* a copy, if your output function mutates its input for
any reason it should copy the argument first."
  (let* ((sym-name (format "tacc-%s-output-functions" name)))
    (if (intern-soft sym-name)
        (error "tacc-register-serialization failed, it seems %s is already \
registered" sym-name)
      (set (intern sym-name) '())
      (push (cons name serialize) tacc-serials))))

(defun tacc-save-record (records)
  "Calls all user-defined serializers and output functions"
  (dolist (ser tacc-serials)
    (let* ((sym-name (format "tacc-%s-output-functions" (car ser)))
           (fn (cdr ser))
           (data (funcall fn records)))
      (run-hook-with-args (intern sym-name) data))))

;; 05 Timer display buffer
(defvar tacc-timer-mode-map
  (let ((map (make-sparse-keymap)))
    map))

(define-derived-mode tacc-timer-mode
  special-mode tacc-buffer-name
  "Major mode for the tacc timer"
  (setq-local show-trailing-whitespace nil
              tacc-locs `((clock-start . ,(copy-marker 0))
                          (clock-end   . ,(copy-marker 0))
                          (graph-start . ,(copy-marker 0))
                          (graph-end   . ,(copy-marker 0)))))

(defun tacc-info-initial ()
  "Returns the initial state of tacc-info"
    `((history  . ())
      (cycle    . 0)
      (work-ts  . nil)
      (break-ts . nil)
      (end-ts   . nil)
      (state    . stop)
      (tag      . "")))

(defvar tacc-info (tacc-info-initial)
  "State information related to the timer")

(defvar tacc-timer nil
  "Timer object controlling tacc's second-by-second update")

;; 05.2 State checks

(defun tacc-buffer ()
  "Gets the tacc-timer buffer if there is one"
  (get-buffer tacc-buffer-name))

(defun tacc-running? ()
  "Checks if there is a live timer running"
  (timerp tacc-timer))

(defun tacc-running-state? (state)
  "Checks if the state supplied indicates a live timer"
  (cond ((eq state 'pause) nil)
        ((eq state 'stop) nil)
        ((eq state 'work) t)
        ((eq state 'break) t)
        ('t (signal 'tacc-error-illegal-buffer-state state))))

(defun tacc-invariant ()
  "Returns t if tacc is in a legal state for mutating tacc-info
Note, if there is no tacc-buffer then you shouldn't be touching tacc-info"
  (if (bufferp (tacc-buffer))
      (if (and (timerp tacc-timer)
               (tacc-running-state? tacc-info))
          t)
    (signal 'tacc-error-illegal-buffer-state (tacc-buffer))))

;; 05.3 Predicates and helpers
(defun tacc-chime-p (countdown-ts)
  "Should I play a chime on this second?"
  (if (time-less-p countdown-ts 0)
      (= 0 (mod (time-to-seconds countdown-ts)
                tacc-chime-interval))))

(defun tacc-work-period (cycle)
  "How long is the current work period?"
  (+ tacc-work-seconds
     (* cycle tacc-work-seconds-increment)))

(defun tacc-break-period (cycle)
  "How long is the current break period?"
  (+ tacc-break-seconds
     (* cycle tacc-break-seconds-increment)))

(defun tacc-start-ts (state work-ts break-ts)
  "Given the state, which timestamp did we start on?"
  (if (eq state 'work) work-ts break-ts))

(defun tacc-est-ts (state cycle work-ts break-ts)
  "Given the state and cycle, how long is the current time segment?"
  (let ((start-ts (tacc-start-ts state work-ts break-ts)))
    (time-add start-ts
              (if (eq state 'work)
                  (tacc-work-period cycle)
                (tacc-break-period cycle)))))

;; 05.3 State manipulation

(defun tacc-tick ()
  "Time marches on. Called every second while a tacc timer is running"
  (let* ((now (current-time))
         (state (alist-get 'state tacc-info))
         (cycle (alist-get 'cycle tacc-info))
         (work-ts (alist-get 'work-ts tacc-info))
         (break-ts (alist-get 'break-ts tacc-info))
         (est (tacc-est-ts state cycle work-ts break-ts))
         (countdown (time-subtract est now)))
    (tacc-timer-buffer-update state est countdown now)
    (if (functionp tacc-play-sound-file)
        (cond ((tacc-chime-p countdown)
               (funcall tacc-play-sound-file tacc-sound-chime))
              (t (funcall tacc-play-sound-file tacc-sound-tick))))))

(defun tacc-schedule ()
  "Note the time and schedule the first tick"
  (setcdr (assoc 'state tacc-info) 'work)
  (setcdr (assoc 'work-ts tacc-info) (current-time))
  (setq tacc-timer (run-with-timer 't 1 'tacc-tick)))

(defun tacc-deschedule ()
  "Deschedule the timer"
  (setcdr (assoc 'end-ts tacc-info) (current-time))
  (setq tacc-timer (cancel-timer tacc-timer)))

(defun tacc-push-current ()
  "Push the current period into the record"
  (let* ((stack       (assoc 'history  tacc-info))
         (work-place  (assoc 'work-ts  tacc-info))
         (break-place (assoc 'break-ts tacc-info))
         (end-place   (assoc 'end-ts   tacc-info))
         (tag (alist-get 'tag tacc-info "")))
    (let ((work-cond  (if (cdr work-place) 't nil))
          (break-cond (if (cdr break-place) 't nil)))
      (if work-cond
          (let ((ts (time-to-seconds (cdr work-place)))
                (end (time-to-seconds (if break-cond
                                          (cdr break-place)
                                        (cdr end-place)))))
            (push `((ts    . ,ts)
                    (end   . ,end)
                    (state . work)
                    (tag   . ,tag))
                  stack)))
      (if break-cond
          (let ((ts (time-to-seconds (cdr break-place)))
                (end (time-to-seconds (cdr end-place))))
            (push `((ts    . ,ts)
                    (end   . ,end)
                    (state . break)
                    (tag   . ,tag))
                  stack))))
    (setcdr work-place  nil)
    (setcdr break-place nil)
    (setcdr end-place   nil)))

(defun tacc-kill-buffer-confirm ()
  "Ask for confirmation if a timer is still running"
  (if (tacc-running?)
    (yes-or-no-p "Are you sure you want to kill the timer buffer? This will\
 end the current timer session as well.")
    t))

(defun tacc-buffer-cleanup ()
  "Save and cleanup the timer state if a timer is still live"
  (if (tacc-running?)
      (progn (tacc-deschedule)
             (tacc-push-current))))

;; 06.4 Rendering

(defun space-divider (width segments)
  (let ((ticker 0)
        (rem (mod width segments))
        (len (/ width segments)))
   (lambda ()
     (setf ticker (1+ ticker))
     (+ len (if (<= ticker rem) 1 0)))))

(defun gradient-string (width chars)
  (mapconcat (let ((ticker 0)
                   (rem (mod width (length chars)))
                   (len (/ width (length chars))))
               (lambda (c)
                 (make-string (+ len (if (<= (setq ticker (1+ ticker)) rem) 1 0))
                              c)))
             chars ""))

(defun tacc-header-render (width)
  "Returns a string for the header of the tacc timer"
  (propertize (gradient-string width "'\"'") ;▓░ ▒█
              'face 'shadow))

(defmacro tacc-render-with-buffer (&rest body)
  "Executes the body in tacc-buffer with (let-alist tacc-info), suppress read only"
  `(let* ((buffer (tacc-buffer))
          (window (get-buffer-window buffer t)))
     (with-current-buffer buffer
       (let ((width (window-total-width window 'floor))
             (inhibit-read-only t))
         (let-alist (buffer-local-value 'tacc-locs buffer)
           (goto-char (point-min))
           ,@body)))))

(defmacro tacc-insert-between (start end &rest strings)
 "Replace the text in the region between start and end with string"
  `(save-restriction
     (narrow-to-region ,start ,end)
     (delete-region ,start ,end)
     (goto-char ,start)
     (insert ,@strings)
     (set-marker ,start (point-min))
     (set-marker ,end (point-max))))

(defconst tacc-pause-glyph ?⏸)
(defconst tacc-run-glyph ?▶)
(defconst tacc-graph-char ?█)

(defun tacc-init-timer-buffer ()
  "Initialized the timer buffer display. Sets needed edit positions"
  (let* ((buffer (get-buffer-create tacc-buffer-name))
         (window (display-buffer buffer
                                 (append tacc-display-buffer-settings
                                         tacc-display-buffer-window-settings))))
    (with-current-buffer buffer
      (tacc-timer-mode)
      (make-local-variable 'kill-buffer-query-functions)
      (add-hook 'kill-buffer-query-functions 'tacc-kill-buffer-confirm)
      (let ((width (window-total-width window 'floor))
            (inhibit-read-only t))
        (goto-char (point-min))
        (let-alist (buffer-local-value 'tacc-locs buffer)
          (insert (tacc-header-render width))
          (set-marker .clock-start (point))
          (set-marker .clock-end (point-max))
          (tacc-insert-between
           .clock-start .clock-end
           (tacc-clock-render 'work 1 0))
          (insert "\n")
          (set-marker .graph-start (point))
          (set-marker .graph-end (point-max))
          (tacc-insert-between
           .graph-start .graph-end
           "Tag: \n"
           (tacc-graph-bar-render width 0.0 0.0 1.0)))))))


(defun tacc-clock-glyph (state)
  "Returns the correct play or pause glyph for each state"
  (string (cond ((eq state 'work) tacc-run-glyph)
         ((eq state 'break) tacc-run-glyph)
         ((eq state 'pause) tacc-pause-glyph)
         ((eq state 'stop) tacc-pause-glyph))))

(defun tacc-clock-render (state countdown now)
  "Draw the clock"
  (let* ((overwork (time-less-p countdown 1))
         (count-fmt (if overwork "+%M:%S" "-%M:%S"))
         (count-face (cond (overwork 'tacc-overwork)
                           ((eq state 'pause) 'tacc-clock-pause)
                           ('t 'tacc-clock))))
    (concat
     (propertize (format-time-string "%T" now) 'face 'tacc-clock)
     (propertize (format-time-string count-fmt countdown) 'face count-face)
     (propertize (tacc-clock-glyph state) 'face 'tacc-clock))))

(defun tacc-graph-bar-render (width work break void)
  "Return a graph bar width characters wide with the given proportions as \
float"
  (let ((width (- width 5)))
    (concat
     "  "
     (propertize (make-string (round (* width work)) tacc-graph-char)
                 'face 'tacc-graph-work)
     (propertize (make-string (round (* width break)) tacc-graph-char)
                 'face 'tacc-graph-break)
     (propertize (make-string (round (* width void)) tacc-graph-char)
                 'face 'tacc-graph-void)
     "  \n")))

(defun tacc-tag-render (tag)
  (concat "    Tag: "
          (propertize (if (string= tag "") "<None>" tag)
                      'face 'tacc-tag)
          "\n"))

(defun tacc-timer-buffer-update (state est-ts countdown now)
 "Update the timer buffer rendering"
  (tacc-render-with-buffer
   (tacc-insert-between
    .clock-start .clock-end
    (let-alist tacc-info
      (tacc-clock-render state countdown now)))
   (tacc-insert-between
    .graph-start .graph-end
    (let-alist tacc-info
      (concat (tacc-tag-render .tag)
              (let* ((est-s   (time-to-seconds est-ts))
                     (now-s   (time-to-seconds now))
                     (end-s   (if (< est-s now-s) now-s est-s))
                     (work-s  (time-to-seconds .work-ts))
                     (break-s (time-to-seconds .break-ts))

                     (total (- end-s work-s))
                     (work-prop (/ (- (if (numberp break-s) break-s now-s) work-s) total))
                     (break-prop (/ (if (numberp break-s) (- now-s break-s) 0) total))
                     (void-prop (- 1 (+ work-prop break-prop))))
                (tacc-graph-bar-render width work-prop break-prop void-prop)))))))

(defun tacc-new-graph-bar-render ()
  (tacc-render-with-buffer
   (save-restriction
     (narrow-to-region .graph-start .graph-start)
     (goto-char (point-min))
     (insert "\n")
     (set-marker .graph-start (point-min))
     (set-marker .graph-end (point-max))
     (insert "\n"))))

;; 07 Init

(defun tacc-init ()
  "Orchestrates all initialization functions"
  (let ((tag (tacc-tag-prompt)))
    (tacc-init-timer-buffer)
    (setcdr (assoc 'tag tacc-info) tag)
    (tacc-schedule)))

;; 08.1 Interactive Helpers

(defun tacc-tag-prompt ()
  "Prompt for a tag and return the user's input"
  (let ((last-tag (if (bufferp (tacc-buffer))
                      (alist-get 'tag tacc-info)
                    nil))
        (completions (append (flatten-tree
                              (apply 'funcall (if tacc-tag-completion-functions
                                                  tacc-tag-completion-functions
                                                `(,(lambda () "")))))
                             tacc-tag-history)))
    (completing-read (concat "Enter a tag name"
                             (if (< (length last-tag) 0)
                                 (format " (currently %s)" last-tag) "")
                             ": ")
                     completions
                     'stringp
                     nil
                     nil
                     'tacc-tag-history)))

(defun tacc-tag-prompt-soft ()
  "Prompt for a tag unless the user doesn't want us to
Returns the current tag if no prompt is made"
  (if tacc-suppress-tag-prompt
      (alist-get 'tag tacc-info)
    (tacc-tag-prompt)))

;; 08.2 Interactive

(defun tacc-start-timer ()
  "Starts the tacc timer"
  (interactive)
  (if (bufferp (tacc-buffer))
      (message "A timer is already running")
    (tacc-init)))

(defun tacc-set-tag ()
  "Sets a tag for live timer sessions going forward"
  (interactive)
  (if (tacc-running?)
      (setcdr (assoc 'tag tacc-info) (tacc-tag-prompt))
    (message "There isn't a live timer session to tag")))

(defun tacc-cycle-increment (state)
  "Increments the cycle counter if the current state is a 'break"
  (if (eq state 'break)
      (let* ((cycle-place (assoc 'cycle tacc-info))
             (cycle (cdr cycle-place)))
        (setcdr cycle-place (1+ cycle)))))

(defun tacc-timer-state-forward ()
  "Move the tacc timer state forward"
  (interactive)
  (if (tacc-running?)
       (let* ((state-place (assoc 'state   tacc-info))
              (state       (cdr state-place))
              (work-ts     (assoc 'work-ts  tacc-info))
              (break-ts    (assoc 'break-ts tacc-info))
              (end-ts      (assoc 'end-ts   tacc-info))
              (ts (current-time)))
         (if (eq state 'work)
             (progn (setcdr break-ts ts)
                    (setcdr state-place 'break))
           (progn (setcdr end-ts ts)
                  (tacc-push-current)
                  (setcdr work-ts ts)
                  (setcdr state-place 'work)
                  (tacc-new-graph-bar-render)))
         (tacc-cycle-increment state))
    (message "There is no timer to advance")))

(defun tacc-timer-state-skip ()
  "Move the tacc timer state to a new work cycle"
  (interactive)
  (if (tacc-running?)
       (let* ((state-place (assoc 'state tacc-info))
              (work-ts     (assoc 'work-ts tacc-info))
              (end-ts      (assoc 'end-ts tacc-info))
              (ts (current-time)))
         (setcdr end-ts ts)
         (tacc-push-current)
         (tacc-cycle-increment 'break)
         (setcdr work-ts ts)
         (setcdr state-place 'work)
         (tacc-new-graph-bar-render))))

(defun tacc-pause-timer ()
  "Pause the tacc timer session"
  (tacc-deschedule)
  (tacc-push-current)
  (setcdr (assoc 'state tacc-info) 'pause))

(defun tacc-unpause-timer ()
  "Unpause the tacc timer session"
  (tacc-new-graph-bar-render)
  (tacc-schedule))

(defun tacc-hold-timer ()
  "Pause/unpause the tacc timer session"
  (interactive)
  (if (tacc-running?)
      (let ((state (alist-get 'state tacc-info)))
        (if (eq state 'pause)
            (tacc-unpause-timer)
          (tacc-pause-timer))))
    (message "There isn't a live timer session to pause/unpause"))

(defun tacc-end-timer ()
  "Ends the current timer session, runs serialization and kills the buffer"
  (interactive)
  (tacc-deschedule)
  (tacc-push-current)
  (tacc-save-record (assoc 'history tacc-info))
  (setcdr (assoc 'state tacc-info) 'stop)
  (kill-buffer (tacc-buffer)))

;; 09 Hooks setup
(add-hook 'after-init-hook 'tacc-load-tag-history)
(add-hook 'kill-emacs-hook 'tacc-save-tag-history)

;; 10 Provides

(provide 'tacc)

;;; tacc.el ends here