;;; org-select.el --- Build custom menus from declarative templates  -*- lexical-binding: t; -*-

;; Copyright (C) 2022  Arthur Miller

;; Author: Arthur Miller <arthur.miller@live.com>
;; Keywords: tools

;; 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 3 of the License, or
;; (at your option) any later version.

;; 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 this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; 
;; 

;;; Code:

(require 'org-macs)

;;; User vars

(defgroup org-select nil
  "Create menus from declarative templates."
  :prefix "org-select-"
  :prefix "osl--"
  :tag "Org Select"
  :group 'org)

(defcustom org-select-back-key [f10]
  "Used to render string for the horizontal separator."
  :type 'character
  :group 'org-select)

(defcustom org-select-horizontal-separator "|"
  "Used to render string for the horizontal separator."
  :type 'string
  :group 'org-select)

(defcustom org-select-vertical-separator "-"
  "Used to render string for the vetical separator."
  :type 'string
  :group 'org-select)

(defcustom org-select-key-decorator-chars ""
  "Characters used to decorate shortcut keys.

This string should contain only two characters, the first one for the left
decorator and the second one for the right decorator.

Example: string \"[]\" will render key \"C\" as \"[C]\"."
  :type 'string
  :group 'org-select)

(defcustom org-select-label-decorators (cons "..." "...")
  "Used to render string for the vetical separator."
  :type 'cons
  :group 'org-select)

;;; Implementation

(defvar-local osl--args nil)
(defvar-local osl--menu-begin nil)
(defvar-local osl--buffer-menu nil)
(defvar-local osl--longest-label 0)
(defvar-local osl--allowed-keys nil)
(defvar-local osl--buffer-window nil)
(defvar-local org-select-mode-map nil)
(defvar-local osl--horizontal-layout nil)
(defvar-local osl--default-handler-fn nil)
(defvar-local osl--current-menu-column nil)

(define-minor-mode org-select-mode ""
  :interactive nil :global nil)

;;;; Help-functions
(defun osl--arg (key)
  (plist-get osl--args key))

(defun osl--default-handler-fn (entry)
  "Try to execute form found in ENTRY if any."
  (let ((form (nth 2 entry)))
    (cond
     ((listp form)
      (eval form))
     (t (if (commandp form)
            (call-interactively form)
          (eval form))))))

(with-eval-after-load
    (setq osl--default-handler-fn #'osl--default-handler-fn))

(defun osl--ignore-key ()
  (interactive)
  (message
   "Invalid key %S"
   ;; I am not happy but it works somewhat
   (edmacro-format-keys (vector last-input-event))))

(defun osl--read-key ()
  (let ((key (read-key-sequence
              (concat
               (or (osl--arg :label) "Org-select") ": "))))
    (funcall (local-key-binding key))))

(defun org-select-quit (&optional abort-message)
  (interactive)
  (catch 'exit
    (when (> 0 (recursion-depth))
      (exit-recursive-edit)
      (top-level)))
    (while osl--buffer-window
      (quit-window t osl--buffer-window)
      (message (or abort-message "Org Select Quit"))))

(defun osl--back ()
  (interactive)
  (osl--draw))

(defun osl--line-length ()
  (- (line-end-position) (line-beginning-position)))

(defun osl--decorate-key (key)
  "Place string KEY between characters specified in DECORATOR string."
  (let ((kd (if (> (length org-select-key-decorator-chars) 0)
                org-select-key-decorator-chars
              (osl--arg :key-decorator))))
    (if (= (length kd) 2)
        (concat (substring kd 0 1) key (substring kd 1))
      key)))

(defun osl--decorate-label (entry)
  "Place string LABEL between strings specified in DECORATORS strings.
DECOARATOR  is a cons containing two elements: left and right decorators."
  (let ((left (car org-select-label-decorators))
        (right (cdr org-select-label-decorators)))
    (if (= (length entry) 2)
        (concat left (cadr entry) right)
      (cadr entry))))

(defun osl--make-separator (&optional marker length)
  (let ((length (or length osl--longest-label))
        (sepch (if (osl--arg :horizontal)
                   (string-to-char org-select-horizontal-separator)
                 (string-to-char org-select-vertical-separator))))
    (if marker
        (concat "sep" (char-to-string sepch))
      (make-string length sepch))))

(defun osl--insert-separator (sep)
  (if (osl--arg :horizontal)
      (osl--insert-horizontal-separator sep)
    (insert sep "\n")))

(defun osl--longest-menu-length ()
  (let ((longest-menu-length 0)
        (menus (buffer-local-value
                'osl--buffer-menu (current-buffer)))
        length)
    (dolist (m menus)
      (setq length (if (symbolp m) (length (eval m)) (length m)))
      (if (> length longest-menu-length) (setq longest-menu-length length)))
    longest-menu-length))

(defun osl--insert-horizontal-separator (sep)
  (goto-char osl--menu-begin)
  (dotimes (i (osl--longest-menu-length))
    (let* ((eol (line-end-position))
           (bol (line-beginning-position))
           (lol osl--longest-label)
           (sep (or org-select-horizontal-separator sep))
           (fill (abs (- eol (+ bol lol)))))
      (goto-char eol)
      (while (> fill 0) (insert " ") (setq fill (1- fill)))
      (goto-char (line-end-position))
      (insert " ")
      (if (> (length sep) 0)
          (insert sep " "))
    (forward-line)
    (setq i (1+ i))))
  (setq osl--current-menu-column (1- (point))))

(defun osl--insert (&rest strings)
  (if (osl--arg :horizontal)
    (goto-char (line-end-position)))
  (apply #'insert strings))

(defun osl--forward-menu ()
  (cond ((osl--arg :horizontal)
         (goto-char osl--menu-begin)
         (setq osl--current-menu-column
               (+ osl--current-menu-column osl--longest-label)))
        (t ;;(insert "\n")
           )))

;;;; Menu drawing
(defun osl--setup-buffer (tables args)
  "Setup buffer local variables needed for an org-select buffer."
  (let* ((buffer (or (plist-get args :label) "*Org-select: "))
         (window (get-buffer-window buffer)))
    (if window (select-window window)
      (org-switch-to-buffer-other-window buffer))
    (with-current-buffer (get-buffer buffer)
      (special-mode)
      (setq cursor-type nil)
      (org-select-mode)
      (setq org-select-mode-map
            (let ((map (make-sparse-keymap)))
              (define-key map [?q] #'org-select-quit)
              (define-key map [?\C-g] #'org-select-quit)
              (define-key map [left] #'osl--back)
              (define-key map [?\C-p] #'osl--back)
              (define-key map [remap newline] #'osl--ignore-key)
              (define-key map [remap self-insert-command] #'osl--ignore-key)
              map))
      (use-local-map org-select-mode-map)
      (setq osl--args args
            osl--buffer-menu tables
            osl--current-menu-column 0
            osl--buffer-window (get-buffer-window)
            osl--default-handler-fn 'osl--default-handler-fn))))

;; menu  is a list of tables, display one table at a time
(defun osl--draw ()
  "Starts menu parsing and insertig."
  (with-silent-modifications
    (erase-buffer)
    (let ((marker (osl--make-separator 'marker))
          (modal (osl--arg :modal))
          (text (osl--arg :text))
          (menus (buffer-local-value
                  'osl--buffer-menu (current-buffer))))
      (when text
        (insert text "\n"))
      (setq osl--menu-begin (point))
      (dolist (menu menus)
        (if (symbolp menu) (setq menu (eval menu)))
        (osl--do-menu menu)
        (setq menus (cdr menus))
        (when menus
          (osl--insert-separator marker)
          (osl--forward-menu)))
      (let ((separator (osl--make-separator)))
        (while (search-backward marker nil t)
          (replace-match "")
          (osl--insert-separator separator)))
      (org-fit-window-to-buffer)
      (goto-char 1) ;; unnecessary but looks prettier if beacon-mode is active
      (if modal (osl--read-key)))))

;; iterate through menu and render a single entry or a group of entries on each
;; iteration
(defun osl--do-menu (menu)
  "Insert one menu at a time."
  (while menu
    (let ((entry (car menu)))
      (setq menu
            (if (> (length entry) 2)
                (osl--do-entry menu)
              (osl--do-group menu))))))

(defun osl--do-group (menu)
  "Do a menu with group nodes."
  (let ((group (car menu))
        (modal (osl--arg :modal))
        (transient (osl--arg :transient))
        newmenu)
    (osl--do-entry menu)
    (while (> (length (cadr menu)) 2)
      (let (entry newentry key)
        (setq menu (cdr menu) entry (car menu))
        (setq key (substring (car entry) 1))
        (push key newentry)
        (dolist (elt (cdr entry)) (push elt newentry))
        (push (nreverse newentry) newmenu)))
    (setq newmenu (nreverse newmenu))
    (define-key org-select-mode-map (kbd (car group))
                (lambda ()
                  (interactive)
                  (with-silent-modifications
                    (erase-buffer)
                    (setq osl--current-menu-column 0)
                    (osl--do-menu newmenu)
                    (if modal (osl--read-key))
                    (if transient (org-select-quit "")))))
    (cdr menu))) ;; return next group in chain

;; we send in the entire menu so we can return next piece in chain,
;; but *the* entry we work with is just the first one (car menu)
(defun osl--do-entry (menu)
  "Display a single entry in the buffer."
  (let* ((entry (car menu))
         (key (car entry))
         (line-length 0)
         (transient (osl--arg :transient)))
    (push key osl--allowed-keys)
    (define-key org-select-mode-map (kbd key)
                (lambda ()
                  (interactive)
                  (let ((label (nth 1 entry))
                        (handler (or (plist-get :handler entry)
                                     osl--default-handler-fn)))
                    (if handler (funcall handler entry))
                    (if transient (org-select-quit ""))
                    (message label))))
    (osl--insert (osl--decorate-key key) "    " (osl--decorate-label entry))
    (setq line-length (- (line-end-position) (line-beginning-position)))
    (if (> line-length osl--longest-label)
        (setq osl--longest-label line-length))
    (if (= 0 osl--current-menu-column)
        (insert "\n")
      (forward-line))
    (cdr menu)))

;;; API

(defun org-select (tables &rest args)
  "Select a member of an alist with multiple keys.

TABLE is an alist which should contain entries where the car is a string.
There should be two types of entries.

1. prefix descriptions like (\"a\" \"Description\")
   This indicates that `a' is a prefix key for multi-letter selection, and
   that there are entries following with keys like \"ab\", \"ax\"...

2. Select-able members must have more than two elements, with the first
   being the string of keys that lead to selecting it, and the second a
   short description string of the item. 

The command will then make a temporary buffer listing all entries
that can be selected with a single key, and all the single key
prefixes.  When you press the key for a single-letter entry, it is selected.
When you press a prefix key, the commands (and maybe further prefixes)
under this key will be shown and offered for selection.

ARGS is a property list containing following members:

:text          a string placed over the selection in the buffer.
:label         a string used for the selections buffer name.
:prompt        a string used when prompting for a key.
:modal         when `t', read minibuffer until dialog is dismissed
:always        when `t', this menu is shown; even descended into submenus
:transient     when `t', the menu is dissmised after user perform an action
:key-decorator a two-character string used to decorate command characters. When
this string is specified, it will take precedence over the global variable
`org-select-key-decorator-chars'.

TABLES are additional menus in the same format as TABLE. If there are more
than one menus, they will be separated by a separator line rendered with
character as specified in `org-select-horizontal-separator'"
  (osl--setup-buffer tables args)
  (osl--draw))

;;; Demo

(require 'org)
(require 'org-capture)

(defun demo1 ()
  "Simple illustration to recreate org-capture menu (visually only)."
  (interactive)
  (org-select
   ;; tables
   '(org-capture-templates
     (("C" "Customize org-capture-templates"
       (customize-variable 'org-capture-templates))
      ("q" "Abort" (org-select-quit "Abort"))))
   ;; description
   :label "*Quick Select*" :key-decorator "[]" :horizontal t
   :text "Select a capture template\n========================="))

(defun demo2 ()
  "Menu composition with automatic separator."
  (interactive)
  (let ((org-select-key-decorator-chars "<>"))
    (org-select
     ;; menus
     '((("h" "Hello, World!" (message "Hello, World!"))
        ("b" "Bar" (message "Hello, Bar!")))
       (("f" "Find File" find-file)
        ("o" "Open File" (flet ((next-read-file-uses-dialog-p () t))
                           (call-interactively #'find-file))))
       (("q" "Abort" (org-select-quit "Abort"))))
     ;; description
     :key-decorator "<>")))

(defun demo3 ()
  "Menu dissapears after a choice is made."
  (interactive)
  (org-select
   ;; menus
   '((("h" "Hello, World!" (message "Hello, World!"))
      ("b" "Bar" (message "Hello, Bar!")))
     (("f" "Find File" find-file)
      ("o" "Open File" (flet ((next-read-file-uses-dialog-p () t))
                         (call-interactively #'find-file))))
     (("q" "Abort" (message "Abort"))))
   ;; description
   :key-decorator "<>" :transient t :horizontal t))

(defun demo4 ()
  "Illustrate nested menus, unicode separator and alternative decorator."
  (interactive)
  (let ((org-select-vertical-separator "─"))
    (org-select
     ;; tables
     '((("g" "Greetings")
        ("gh" "Hello, World!" (message "Hello, World!"))
        ("gb" "Bar" (message "Hello, Bar!")))
       (("f" "Functions")
        ("ff" "Find File" find-file)
        ("fo" "Open File" (flet ((next-read-file-uses-dialog-p () t))
                            (call-interactively #'find-file))))
       (("q" "Abort" (org-select-quit "Abort"))))
       ;; description
     :key-decorator "<>")))

(defun demo5 ()
  "Same as demo4 but modal."
  (interactive)
  (let ((org-select-vertical-separator "─"))
    (org-select
     ;; table
     '((("g" "Greetings")
        ("gh" "Hello, World!" (message "Hello, World!"))
        ("gb" "Bar" (message "Hello, Bar!")))
       ;; more tables
       (("f" "Functions")
        ("ff" "Find File" (call-interactively #'find-file))
        ("fo" "Open File" (flet ((next-read-file-uses-dialog-p () t))
                            (call-interactively 'find-file))))
       (("q" "Abort" (org-select-quit "Abort"))))
     ;; description
     :modal t :transient t)))

(defun demo6 ()
  "Horizontal menus."
  (interactive)
  (let ((org-select-vertical-separator "─"))
    (org-select
     ;; table
     '((("1" "One" (message "One!"))
        ("2" "Two" (message "Two!!"))
        ("3" "Three" (message "Three!!!")))
       (("4" "Four" (message "Four!!!!"))
        ("5" "Five" (message "Five!!!!!"))
        ("6" "six" (message "Six!")))
       (("7" "Seven" (message "Seven!"))
        ("8" "Eight" (message "Eight!"))
        ("9" "Nine" (message "Nine!"))))
     ;; description
     :transient t :horizontal t)))

  (provide 'org-select)

;;; org-select.el ends here