;;; org-struct.el --- Org-style editing in non-Org buffers  -*- lexical-binding: t; -*-

;; Copyright (C) 2015 Free Software Foundation, Inc.

;; Author: Carsten Dominik <carsten at orgmode dot org>
;; Keywords: outlines

;; 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 <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This file provides two minor modes for using Org-style editing
;; commands in buffers that aren't in Org mode. The first mode,
;; orgstruct-mode, defines key-bindings for structural editing
;; commands like inserting headings and manipulating list items. The
;; second minor mode, orgstruct++-mode, builds on the first, adding
;; functions to handle filling and indentation.

;; The basic orgstruct-mode is a bit of a hack: it hijacks all the
;; keys it needs for structure editing, and wraps them in a function
;; (`orgstruct-make-binding') that checks the context around point.
;; If the text around point looks like Org text, the relevant Org
;; command is run.  If it doesn't, the function checks to see if the
;; currently-active major or minor modes have commands bound to those
;; keys, and, if so, calls those commands.

;; The second minor mode, orgstruct++, special-cases various major
;; modes, such as message-mode, to make sure that Org text structures
;; are filled and indented properly.

;; in orgstruct++ mode, we need to set custom values for
;; indent-line-function, adaptive-fill-function,
;; normal-auto-fill-function, and fill-paragraph-function

;;; Code:

(require 'org)

(declare-function message-goto-body "message" ())

(defvar message-cite-prefix-regexp)	; From message.el

(defcustom orgstruct-heading-prefix-regexp ""
  "Regexp that matches the custom prefix of Org headlines in
orgstruct(++)-mode."
  :group 'org
  :version "24.4"
  :package-version '(Org . "8.3")
  :type 'regexp)
;;;###autoload(put 'orgstruct-heading-prefix-regexp 'safe-local-variable 'stringp)

(defcustom orgstruct-setup-hook nil
  "Hook run after orgstruct-mode-map is filled."
  :group 'org
  :version "24.4"
  :package-version '(Org . "8.0")
  :type 'hook)

(defvar orgstruct-initialized nil)

;;;###autoload
(define-minor-mode orgstruct-mode
  "Toggle the minor mode `orgstruct-mode'.
This mode is for using Org-mode structure commands in other
modes.  The following keys behave as if Org-mode were active, if
the cursor is on a headline, or on a plain list item (both as
defined by Org-mode)."
  nil " OrgStruct" (make-sparse-keymap)
  (funcall (if orgstruct-mode
	       'add-to-invisibility-spec
	     'remove-from-invisibility-spec)
	   '(outline . t))
  (when orgstruct-mode
    (org-load-modules-maybe)
    (unless orgstruct-initialized
      (orgstruct-setup)
      (setq orgstruct-initialized t))))

;;;###autoload
(defun turn-on-orgstruct ()
  "Unconditionally turn on `orgstruct-mode'."
  (orgstruct-mode 1))

(defvar org-fb-vars nil)
(make-variable-buffer-local 'org-fb-vars)

(defun orgstruct-error ()
  "Error when there is no default binding for a structure key."
  (interactive)
  (funcall (if (fboundp 'user-error)
	       'user-error
	     'error)
	   "This key has no function outside structure elements"))

(defun orgstruct-setup ()
  "Setup orgstruct keymap."
  (dolist (cell '((org-demote . t)
		  (org-metaleft . t)
		  (org-metaright . t)
		  (org-promote . t)
		  (org-shiftmetaleft . t)
		  (org-shiftmetaright . t)
		  org-backward-element
		  org-backward-heading-same-level
		  org-ctrl-c-ret
		  org-ctrl-c-minus
		  org-ctrl-c-star
		  org-cycle
		  org-forward-heading-same-level
		  org-insert-heading
		  org-insert-heading-respect-content
		  org-kill-note-or-show-branches
		  org-mark-subtree
		  org-meta-return
		  org-metadown
		  org-metaup
		  org-narrow-to-subtree
		  org-promote-subtree
		  org-reveal
		  org-shiftdown
		  org-shiftleft
		  org-shiftmetadown
		  org-shiftmetaup
		  org-shiftright
		  org-shifttab
		  org-shifttab
		  org-shiftup
		  org-show-subtree
		  org-sort
		  org-up-element
		  outline-demote
		  outline-next-visible-heading
		  outline-previous-visible-heading
		  outline-promote
		  outline-up-heading
		  show-children))
    (let ((f (or (car-safe cell) cell))
	  (disable-when-heading-prefix (cdr-safe cell)))
      (when (fboundp f)
	(let ((new-bindings))
	  (dolist (binding (nconc (where-is-internal f org-mode-map)
				  (where-is-internal f outline-mode-map)))
	    (push binding new-bindings)
	    ;; TODO use local-function-key-map
	    (dolist (rep '(("<tab>" . "TAB")
			   ("<return>" . "RET")
			   ("<escape>" . "ESC")
			   ("<delete>" . "DEL")))
	      (setq binding (read-kbd-macro
			     (let ((case-fold-search))
			       (replace-regexp-in-string
				(regexp-quote (cdr rep))
				(car rep)
				(key-description binding)))))
	      (pushnew binding new-bindings :test 'equal)))
	  (dolist (binding new-bindings)
	    (let ((key (lookup-key orgstruct-mode-map binding)))
	      (when (or (not key) (numberp key))
		(ignore-errors
		  (org-defkey orgstruct-mode-map
			      binding
			      (orgstruct-make-binding
			       f binding disable-when-heading-prefix))))))))))
  (run-hooks 'orgstruct-setup-hook))

(defun orgstruct-make-binding (fun key disable-when-heading-prefix)
  "Create a function for binding in the structure minor mode.
FUN is the command to call inside a table.  KEY is the key that
should be checked in for a command to execute outside of tables.
Non-nil `disable-when-heading-prefix' means to disable the command
if `orgstruct-heading-prefix-regexp' is not empty."
  (let ((name (concat "orgstruct-hijacker-" (symbol-name fun))))
    (let ((nname name)
	  (i 0))
      (while (fboundp (intern nname))
	(setq nname (format "%s-%d" name (setq i (1+ i)))))
      (setq name (intern nname)))
    (eval
     (let ((bindings '((org-heading-regexp
			(concat "^"
				orgstruct-heading-prefix-regexp
				"\\(\\*+\\)\\(?: +\\(.*?\\)\\)?[		]*$"))
		       (org-outline-regexp
			(concat orgstruct-heading-prefix-regexp "\\*+ "))
		       (org-outline-regexp-bol
			(concat "^" org-outline-regexp))
		       (outline-regexp org-outline-regexp)
		       (outline-heading-end-regexp "\n")
		       (outline-level 'org-outline-level)
		       (outline-heading-alist))))
       `(defun ,name (arg)
	  ,(concat "In Structure, run `" (symbol-name fun) "'.\n"
		   "Outside of structure, run the binding of `"
		   (key-description key) "'."
		   (when disable-when-heading-prefix
		     (concat
		      "\nIf `orgstruct-heading-prefix-regexp' is not empty, this command will always fall\n"
		      "back to the default binding due to limitations of Org's implementation of\n"
		      "`" (symbol-name fun) "'.")))
	  (interactive "p")
	  (let* ((disable
		  ,(and disable-when-heading-prefix
			'(not (string= orgstruct-heading-prefix-regexp ""))))
		 (fallback
		  (or disable
		      (not
		       (let* ,bindings
			 (org-context-p 'headline 'item
					,(when (memq fun
						     '(org-insert-heading
						       org-insert-heading-respect-content
						       org-meta-return))
					   '(when orgstruct-is-++
					      'item-body))))))))
	    (if fallback
		(let* ((orgstruct-mode)
		       (binding
			(let ((key ,key))
			  (catch 'exit
			    (dolist
				(rep
				 '(nil
				   ("<\\([^>]*\\)tab>" . "\\1TAB")
				   ("<\\([^>]*\\)return>" . "\\1RET")
				   ("<\\([^>]*\\)escape>" . "\\1ESC")
				   ("<\\([^>]*\\)delete>" . "\\1DEL"))
				 nil)
			      (when rep
				(setq key (read-kbd-macro
					   (let ((case-fold-search))
					     (replace-regexp-in-string
					      (car rep)
					      (cdr rep)
					      (key-description key))))))
			      (when (key-binding key)
				(throw 'exit (key-binding key))))))))
		  (if (keymapp binding)
		      (org-set-transient-map binding)
		    (let ((func (or binding
				    (unless disable
				      'orgstruct-error))))
		      (when func
			(call-interactively func)))))
	      (org-run-like-in-org-mode
	       (lambda ()
		 (interactive)
		 (let* ,bindings
		   (call-interactively ',fun)))))))))
    name))

(defun orgstruct++-mode (&optional arg)
  "Toggle `orgstruct-mode', the enhanced version of it.
In addition to setting orgstruct-mode, this also exports all
indentation and autofilling variables from org-mode into the
buffer.  It will also recognize item context in multiline items."
  (interactive "P")
  (setq arg (prefix-numeric-value (or arg (if orgstruct-mode -1 1))))
  (if (< arg 1)
      (progn (orgstruct-mode -1)
	     (mapc (lambda(v)
		     (org-set-local (car v)
				    (if (eq (car-safe (cadr v)) 'quote) (cadadr v) (cadr v))))
		   org-fb-vars))
    (orgstruct-mode 1)
    (setq org-fb-vars nil)
    (unless org-local-vars
      (setq org-local-vars (org-get-local-variables)))
    (let (var val)
      (mapc
       (lambda (x)
	 (when (string-match
		"^\\(paragraph-\\|auto-fill\\|normal-auto-fill\\|fill-paragraph\\|fill-prefix\\|indent-\\)"
		(symbol-name (car x)))
	   (setq var (car x) val (nth 1 x))
	   (push (list var `(quote ,(eval var))) org-fb-vars)
	   (org-set-local var (if (eq (car-safe val) 'quote) (nth 1 val) val))))
       org-local-vars)
      (org-set-local 'fill-paragraph-function 'orgstruct-fill-paragraph)
      (org-set-local 'adaptive-fill-function 'orgstruct-adaptive-fill-function)
      (org-set-local 'auto-fill-function 'orgstruct-auto-fill-function)
      (org-set-local 'indent-line-function 'orgstruct-indent-line-function)
      (org-set-local 'orgstruct-is-++ t))))

(defvar orgstruct-is-++ nil
  "Is `orgstruct-mode' in ++ version in the current-buffer?")
(make-variable-buffer-local 'orgstruct-is-++)

;;;###autoload
(defun turn-on-orgstruct++ ()
  "Unconditionally turn on `orgstruct++-mode'."
  (orgstruct++-mode 1))

(defun orgstruct-fill-paragraph (&optional justify)
  (interactive)
  (cond
   ((and (derived-mode-p 'message-mode)
	 (or (not (message-in-body-p))
	     (save-excursion (move-beginning-of-line 1)
			     (looking-at message-cite-prefix-regexp))))
    ;; Set appropriate variables for message-mode
    (let ((fill-paragraph-function
	   (cadadr (assoc 'fill-paragraph-function org-fb-vars)))
	  (fill-prefix (cadadr (assoc 'fill-prefix org-fb-vars)))
	  (paragraph-start (cadadr (assoc 'paragraph-start org-fb-vars)))
	  (paragraph-separate (cadadr (assoc 'paragraph-separate org-fb-vars)))
	  (org-element-paragraph-separate (cadadr (assoc 'paragraph-separate org-fb-vars))))
      (org-fill-paragraph)))
   (t
    (org-fill-paragraph))))

(defun orgstruct-adaptive-fill-function ()
  "Find the appropriate fill prefix for the current major mode."
  (cond ((derived-mode-p 'message-mode)
	 (save-excursion
	   (beginning-of-line)
	   (cond ((not (message-in-body-p)) nil)
		 ((org-looking-at-p org-table-line-regexp) nil)
		 ((looking-at message-cite-prefix-regexp)
		  (match-string-no-properties 0))
		 ((looking-at org-outline-regexp)
		  (make-string (length (match-string 0)) ?\s))
		 ((message-in-body-p)
		  (let ((fill-paragraph-function
			 (cadadr (assoc 'fill-paragraph-function org-fb-vars)))
			(fill-prefix (cadadr (assoc 'fill-prefix org-fb-vars)))
			(paragraph-start (cadadr (assoc 'paragraph-start org-fb-vars)))
			(paragraph-separate (cadadr (assoc 'paragraph-separate org-fb-vars)))
			(org-element-paragraph-separate (cadadr (assoc 'paragraph-separate org-fb-vars))))
		    (org-adaptive-fill-function))))))
	(t
	 (org-adaptive-fill-function))))

(defun orgstruct-auto-fill-function ()
  (let ((fc (current-fill-column)))
    (when (and fc (> (current-column) fc))
      (let* ((fill-prefix (orgstruct-adaptive-fill-function))
	     ;; Enforce empty fill prefix, if required.  Otherwise, it
	     ;; will be computed again.
	     (adaptive-fill-mode (not (equal fill-prefix ""))))
	(when fill-prefix (do-auto-fill))))))

(defun orgstruct-indent-line-function ()
  (interactive)
  (cond
   (orgstruct-is-++
    (let ((indent-line-function
	   (cadadr (assq 'indent-line-function org-fb-vars))))
      (indent-according-to-mode)))
   (t
    (org-indent-line))))

(provide 'org-struct)
;;; org-struct.el ends here