;;; workgroups.keys.el --- Set default workgroups keys

;;; Commentary:

;;

;;; Code:

(require 'workgroups-variables)

(require 'workgroups-utils-basic)

(defcustom wg-prefix-key (kbd "C-c z")

  "Workgroups' prefix key.

Setting this variable requires that `workgroups-mode' be turned

off and then on again to take effect."

  :type 'string

  :group 'workgroups)

(defvar workgroups-mode-map nil

  "Workgroups Mode's keymap.")

(defvar wg-prefixed-map

  (wg-fill-keymap

   (make-sparse-keymap)

   ;; workgroups

   (kbd "C-c")        'wg-create-workgroup

   (kbd "c")          'wg-create-workgroup

   (kbd "C")          'wg-clone-workgroup

   (kbd "A")          'wg-rename-workgroup

   (kbd "C-'")        'wg-switch-to-workgroup

   (kbd "'")          'wg-switch-to-workgroup

   (kbd "C-v")        'wg-switch-to-workgroup

   (kbd "v")          'wg-switch-to-workgroup

   ;; session

   (kbd "C-s")        'wg-save-session

   (kbd "C-w")        'wg-save-session-as

   (kbd "C-f")        'wg-open-session

   ;; killing and yanking

   (kbd "C-k")        'wg-kill-workgroup

   (kbd "k")          'wg-kill-workgroup

   (kbd "M-W")        'wg-kill-ring-save-base-wconfig

   (kbd "M-w")        'wg-kill-ring-save-working-wconfig

   (kbd "C-y")        'wg-yank-wconfig

   (kbd "y")          'wg-yank-wconfig

   (kbd "M-k")        'wg-kill-workgroup-and-buffers

   (kbd "K")          'wg-delete-other-workgroups

   ;; workgroup switching

   (kbd "M-v")        'wg-switch-to-workgroup-other-frame

   (kbd "C-j")        'wg-switch-to-workgroup-at-index

   (kbd "j")          'wg-switch-to-workgroup-at-index

   (kbd "0")          'wg-switch-to-workgroup-at-index-0

   (kbd "1")          'wg-switch-to-workgroup-at-index-1

   (kbd "2")          'wg-switch-to-workgroup-at-index-2

   (kbd "3")          'wg-switch-to-workgroup-at-index-3

   (kbd "4")          'wg-switch-to-workgroup-at-index-4

   (kbd "5")          'wg-switch-to-workgroup-at-index-5

   (kbd "6")          'wg-switch-to-workgroup-at-index-6

   (kbd "7")          'wg-switch-to-workgroup-at-index-7

   (kbd "8")          'wg-switch-to-workgroup-at-index-8

   (kbd "9")          'wg-switch-to-workgroup-at-index-9

   (kbd "C-p")        'wg-switch-to-workgroup-left

   (kbd "p")          'wg-switch-to-workgroup-left

   (kbd "C-n")        'wg-switch-to-workgroup-right

   (kbd "n")          'wg-switch-to-workgroup-right

   (kbd "C-a")        'wg-switch-to-previous-workgroup

   (kbd "a")          'wg-switch-to-previous-workgroup

   ;; updating and reverting

   ;; wconfig undo/redo

   (kbd "C-r")        'wg-revert-workgroup

   (kbd "r")          'wg-revert-workgroup

   (kbd "C-S-r")      'wg-revert-all-workgroups

   (kbd "R")          'wg-revert-all-workgroups

   (kbd "<left>")     'wg-undo-wconfig-change

   (kbd "<right>")    'wg-redo-wconfig-change

   (kbd "[")          'wg-undo-wconfig-change

   (kbd "]")          'wg-redo-wconfig-change

   (kbd "{")          'wg-undo-once-all-workgroups

   (kbd "}")          'wg-redo-once-all-workgroups

   ;; wconfig save/restore

   (kbd "C-d C-s")    'wg-save-wconfig

   (kbd "C-d C-'")    'wg-restore-saved-wconfig

   (kbd "C-d C-k")    'wg-kill-saved-wconfig

   ;; workgroup movement

   (kbd "C-x")        'wg-swap-workgroups

   (kbd "C-,")        'wg-offset-workgroup-left

   (kbd "C-.")        'wg-offset-workgroup-right

   ;; window moving and frame reversal

   (kbd "|")          'wg-reverse-frame-horizontally

   (kbd "\\")         'wg-reverse-frame-vertically

   (kbd "/")          'wg-reverse-frame-horizontally-and-vertically

   ;; toggling

   (kbd "C-t C-m")    'wg-toggle-mode-line-display

   (kbd "C-t C-b")    'wg-toggle-buffer-list-filtration

   (kbd "C-t C-d")    'wg-toggle-window-dedicated-p

   ;; misc

   (kbd "!")          'wg-reset

   (kbd "?")          'wg-help

   )

  "The keymap that sits on `wg-prefix-key'.")

(defun wg-make-workgroups-mode-map ()

  "Return Workgroups' minor-mode-map.

This map includes `wg-prefixed-map' on `wg-prefix-key', as well

as Workgroups' command remappings."

  (let ((map (make-sparse-keymap)))

    (define-key map wg-prefix-key

      wg-prefixed-map)

    (when (and (fboundp 'winner-undo)

               (fboundp 'winner-redo))

      (define-key map [remap winner-undo] 'wg-undo-wconfig-change)

      (define-key map [remap winner-redo] 'wg-redo-wconfig-change))

    (setq workgroups-mode-map map)))

(provide 'workgroups-keys)

;;; workgroups-keys.el ends here

(defun wg-util-swap (elt1 elt2 list)

  "Return a copy of LIST with ELT1 and ELT2 swapped.

Return nil when ELT1 and ELT2 aren't both present."

  (wg-when-let ((p1 (cl-position elt1 list))

                (p2 (cl-position elt2 list)))

    (wg-move-elt elt1 (wg-move-elt elt2 list p1) p2)))

(defun wg-dups-p (list &rest keys)

  "Return non-nil when LIST contains duplicate elements.

Keywords supported: :test :key

\(fn LIST [KEYWORD VALUE]...)"

  (let ((test (or (plist-get keys :test) 'eq))

        (key (or (plist-get keys :key) 'identity)))

    (cl-loop for (elt . rest) on list

             for elt = (funcall key elt)

             when (cl-find elt rest :test test :key key) return elt)))

(defun wg-string-list-union (&optional list1 list2)

  "Return the `union' of LIST1 and LIST2, using `string=' as the test.

This only exists to get rid of duplicate lambdas in a few reductions."

  (cl-union list1 list2 :test 'string=))

;;; alists

(defun wg-make-alist (&rest kvps)

  "Return a new alist from KVPS."

  (let (alist)

    (while kvps

      (push (cons (car kvps) (cadr kvps)) alist)

      (setq kvps (cddr kvps)))

    (nreverse alist)))

(defun wg-aget (alist key &optional default)

  "Return the value of KEY in ALIST. Uses `assq'.

If PARAM is not found, return DEFAULT which defaults to nil."

  (aif (assq key alist) (cdr it) default))

(defun wg-acopy (alist)

  "Return a copy of ALIST's toplevel list structure."

  (mapcar (lambda (kvp) (cons (car kvp) (cdr kvp))) alist))

(defun wg-aput (alist key value)

  "Return a new alist from ALIST with KEY's value set to VALUE."

  (let* ((found nil)

         (new (wg-docar (kvp alist)

                (if (not (eq key (car kvp))) kvp

                  (setq found (cons key value))))))

    (if found new (cons (cons key value) new))))

(defun wg-aremove (alist key)

  "`remove' KEY's key-value-pair from ALIST."

  (remove (assoc key alist) alist))

;;; symbols and strings

(defun wg-toggle (symbol)

  "Toggle SYMBOL's truthiness."

  (set symbol (not (symbol-value symbol))))

(defun wg-symcat (&rest symbols-and-strings)

  "Return a new interned symbol by concatenating SYMBOLS-AND-STRINGS."

  (intern (mapconcat (lambda (obj) (if (symbolp obj) (symbol-name obj) obj))

                     symbols-and-strings "")))

(defun wg-make-string (times string &optional separator)

  "Like `make-string', but includes a separator."

  (mapconcat 'identity (make-list times string) (or separator "")))

;;; buffers

(defun wg-get-buffer (buffer-or-name)

  "Return BUFFER-OR-NAME's buffer, or error."

  (or (get-buffer buffer-or-name)

      (error "%S does not identify a buffer" buffer-or-name)))

(defun wg-buffer-name (buffer-or-name)

  "Return BUFFER-OR-NAME's `buffer-name', or error."

  (buffer-name (wg-get-buffer buffer-or-name)))

(defun wg-buffer-file-name (buffer-or-name)

  "Return BUFFER-OR-NAME's `buffer-file-name', or error."

  (buffer-file-name (wg-get-buffer buffer-or-name)))

(defun wg-buffer-major-mode (buffer-or-name)

  "Return BUFFER's major-mode."

  (with-current-buffer buffer-or-name major-mode))

(defun wg-current-buffer-p (buffer-or-name)

  "Return t if BUFFER-OR-NAME is the current buffer, nil otherwise."

  (eq (wg-get-buffer buffer-or-name) (current-buffer)))

(defmacro wg-buffer-local-setq (buffer var value)

  "`setq' VAR to VALUE while BUFFER is current.

Note that this won't make VAR buffer-local if it isn't already."

  `(with-current-buffer ,buffer (setq ,var ,value)))

(defun wg-interesting-buffers ()

  "Return a list of only the interesting buffers in `buffer-list'."

  (cl-remove-if (lambda (bname) (string-match "^ " bname))

                (wg-buffer-list-emacs) :key 'buffer-name))

(defun wg-get-first-buffer-matching-regexp (regexp &optional buffer-list)

  "Return the first buffer in BUFFER-LIST with a name matching REGEXP.

BUFFER-LIST should contain buffer objects and/or buffer names."

  (cl-find regexp (or buffer-list (wg-buffer-list-emacs))

           :test 'string-match :key 'wg-buffer-name))

;;; files

(defun wg-write-sexp-to-file (sexp file)

  "Write the printable representation of SEXP to FILE."

  (with-temp-buffer

    (let ((print-level nil)  (print-length nil))

      (insert (format "%S" sexp)))

    (write-file file)))

(defun wg-read-sexp-from-file (file)

  "Return a Lisp object from FILE."

  (with-temp-buffer

    (insert-file-contents file)

    (goto-char (point-min))

    (read (current-buffer))))

(defalias 'wg-lisp-object-from-file 'wg-read-sexp-from-file)

(defun wg-file-under-root-path-p (root-path file-path)

  "Return t when FILE-PATH is under ROOT-PATH, nil otherwise."

  (string-match (concat "^" (regexp-quote (expand-file-name root-path)))

                (expand-file-name file-path)))

;;; frames

(defun wg-cyclic-nth-from-frame (&optional n frame)

  "Return the frame N places away from FRAME in `frame-list' cyclically.

N defaults to 1, and FRAME defaults to `selected-frame'."

  (wg-cyclic-nth-from-elt

   (or frame (selected-frame)) (frame-list) (or n 1)))

;;; namespace-prefixed defstruct

(defmacro wg-defstruct (prefix name-form &rest slot-defs)

  "`defstruct' wrapper that namespace-prefixes all generated functions.

Note: this doesn't yet work with :conc-name, and possibly other

options."

  (declare (indent 2))

  (let* ((name (if (consp name-form) (car name-form) name-form))

         (prefixed-name (wg-symcat prefix "-" name)))

    (cl-labels ((rebind (opstr)

                      (let ((oldfnsym (wg-symcat opstr "-" prefix "-" name)))

                        `((fset ',(wg-symcat prefix "-" opstr "-" name)

                                (symbol-function ',oldfnsym))

                          (fmakunbound ',oldfnsym)))))

      ;; `eval-and-compile' gets rid of byte-comp warnings ("function `foo' not

      ;; known to be defined").  We can accomplish this with `declare-function'

      ;; too, but it annoyingly requires inclusion of the function's arglist,

      ;; which gets ugly.

      `(eval-and-compile

         (cl-defstruct ,(if (symbolp name-form) prefixed-name

                       `(,prefixed-name ,@(cdr name-form)))

           ,@slot-defs)

         ,@(rebind "make")

         ,@(rebind "copy")

         ',prefixed-name))))

(defmacro wg-with-slots (obj slot-bindings &rest body)

  "Bind OBJ's slot values to symbols in BINDS, then eval BODY.

The car of each element of SLOT-BINDINGS is the bound symbol, and

the cadr as the accessor function."

  (declare (indent 2))

  (wg-with-gensyms (objsym)

    `(let* ((,objsym ,obj)

            ,@(wg-docar (slot slot-bindings)

                `(,(car slot) (,(cadr slot) ,objsym))))

       ,@body)))

;;; misc

(defun wg-add-or-remove-hooks (remove &rest pairs)

  "Add FUNCTION to or remove it from HOOK, depending on REMOVE."

  (dolist (pair (wg-partition pairs 2))

    (funcall (if remove 'remove-hook 'add-hook)

             (car pair) (cadr pair))))

(defmacro wg-set-parameter (place parameter value)

  "Set PARAMETER to VALUE at PLACE.

This needs to be a macro to allow specification of a setf'able place."

  (wg-with-gensyms (p v)

    `(let ((,p ,parameter) (,v ,value))

       (wg-pickelable-or-error ,p)

       (wg-pickelable-or-error ,v)

       (setf ,place (wg-aput ,place ,p ,v))

       ,v)))

;;; uid utils

(defun wg-time-to-b36 ()

  "Convert `current-time' into a b36 string."

  (apply 'concat (wg-docar (time (current-time))

                   (wg-int-to-b36 time 4))))

(defun wg-b36-to-time (b36)

  "Parse the time in B36 string from UID."

  (cl-loop for i from 0 to 8 by 4

           collect (wg-b36-to-int (cl-subseq b36 i (+ i 4)))))

(defalias 'wg-uid-to-time 'wg-b36-to-time)

(defun wg-generate-uid (&optional prefix)

  "Return a new uid, optionally prefixed by PREFIX."

  (concat prefix (wg-time-to-b36) "-" (wg-int-to-b36 string-chars-consed)))

(defun wg-uid-to-seconds (uid)

  "Return the `float-time' parsed from UID with `wg-uid-to-time'."

  (float-time (wg-uid-to-time uid)))

(defun wg-get-value (arg)

  "Get a value of ARG if it exists."

  (if (boundp `,arg) (eval arg)))

(defmacro wg-support (mode pkg params)

  "Macro to create (de)serialization functions for a buffer.

You need to save/restore a specific MODE which is loaded from a

package PKG.  In PARAMS you give local variables to save and a

deserialization function."

  `(let ((mode-str (symbol-name ,mode))

         (args ,params))

     (eval `(defun ,(intern (format "wg-deserialize-%s-buffer" mode-str)) (buffer)

              "DeSerialization function created with `wg-support'.

Gets saved variables and runs code to restore a BUFFER."

              (when (require ',,pkg nil 'noerror)

                (wg-dbind (this-function variables) (wg-buf-special-data buffer)

                  (let ((default-directory (car variables))

                        (df (cdr (assoc 'deserialize ',,params)))

                        (user-vars (car (cdr variables))))

                    (if df

                        (funcall df buffer user-vars)

                      (get-buffer-create wg-default-buffer))

                    )))))

     (eval `(defun ,(intern (format "wg-serialize-%s-buffer" mode-str)) (buffer)

              "Serialization function created with `wg-support'.

Saves some variables to restore a BUFFER later."

              (when (get-buffer buffer)

                (with-current-buffer buffer

                  (when (eq major-mode ',,mode)

                    (let ((sf (cdr (assoc 'serialize ',,params)))

                          (save (cdr (assoc 'save ',,params))))

                      (list ',(intern (format "wg-deserialize-%s-buffer" mode-str))

                            (list default-directory

                                  (if sf (funcall sf buffer)

                                    (if save (mapcar 'wg-get-value save)))

                                  ))))))))

     ;; Maybe change a docstring for functions

     ;;(put (intern (format "wg-serialize-%s-buffer" (symbol-name mode)))

     ;;     'function-documentation

     ;;     (format "A function created by `wg-support'."))

     ;; Add function to `wg-special-buffer-serdes-functions' variable

     (eval `(add-to-list 'wg-special-buffer-serdes-functions

                         ',(intern (format "wg-serialize-%s-buffer" mode-str)) t))

     ))

(defvar wg-current-session nil "Current session object.")

(defun wg-current-session (&optional noerror)

  "Return `wg-current-session' or scream unless NOERROR."

  (or wg-current-session

      (unless noerror

        (error "No session is defined"))))

(defun wg-read-buffer-mode ()

  "Return the buffer switching package (ido or iswitchb) to use, or nil."

  (if (eq wg-current-buffer-list-filter-id 'fallback) 'fallback

    (cl-case (let (workgroups-mode) (command-remapping 'switch-to-buffer))

      (ido-switch-buffer 'ido)

      (otherwise 'fallback))))

(defun wg-read-buffer-function (&optional mode)

  "Return MODE's or `wg-read-buffer-mode's `read-buffer' function."

  (cl-case (or mode (wg-read-buffer-mode))

    (ido 'ido-read-buffer)

    (fallback (lambda (prompt &optional default require-match)

                (let (read-buffer-function)

                  (read-buffer prompt default require-match))))))

(defun wg-completing-read

    (prompt choices &optional pred require-match initial-input history default)

  "Do a completing read.  The function called depends on what's on."

  (cl-ecase (wg-read-buffer-mode)

    (ido

     (ido-completing-read prompt choices pred require-match

                          initial-input history default))

    (fallback

     (completing-read prompt choices pred require-match

                      initial-input history default))))

;; locate-dominating-file

(defun wg-get-first-existing-dir (&optional dir)

  "Test if DIR exists and return it.

If not - try to go to the parent dir and do the same."

  (let* ((d (or dir default-directory)))

    (if (file-directory-p d) d

      (let* ((cur d) (parent (file-name-directory (directory-file-name cur))))

        (while (and (> (length cur) (length parent))

                    (not (file-directory-p parent)))

          (message "Test %s" parent)

          (setq cur parent)

          (setq parent (file-name-directory (directory-file-name cur))))

        parent))))

(provide 'workgroups-utils-basic)

;;; workgroups-utils-basic.el ends here