emacs/lisp/mir-orgstuff.el

;;; mir-orgstuff.el --- Hacking on top of Org mode.

;;; Commentary:

;; Some of the things I want to do with org aren't built-in or intended.  This
;; file is the cum total of my intent to implement these things.

;;; Code:

(require 'dash)
(require 'f)
(require 'ox-publish)
(require 'hyperbole)

(defvar org-directory (expand-file-name "org/" "~"))
(defvar org-agenda-files '("~/org/"))
(defvar org-vw-staging-dir "/unicron_shared/webbed-site/staging/")
(defvar org-vw-export-dir "/unicron_shared/webbed-site/public/")
(defvar org-wiki-regex "\\`[^.].*\\.org\\'")
(defvar org-vw--link-re (rx "[[" (* any) (+ alnum)
			    ".org][" (* any) "]]"))

;; need to make a hyperbole
(add-to-list 'hkey-alist '((and
			    (eq major-mode 'org-mode)
			    (not (smart-org)))
			   . ((org-vw-make-newlink) . nil)))

;; ------------------- links and exporting -------------------------------------
(defun org-vw-link-at-point ()
  (interactive)
  (save-match-data
    (string-match org-vw--link-re (thing-at-point 'line))
    (with-current-buffer (
			  ;; it was at this point that she gave up from scratch
			  ))
    (buffer-substring-no-properties match-beginning match-end)))
(defun org-vw--get-link-basename (link)
  (if (string-match-p org-vw--link-re link)
      (--> link
	   (split-string it "]\\[")
	   (car it)
	   (string-trim it "\\[\\[" "]]")
	   (string-trim-right it "/index\.org$"))
    (error "malformed link, what are you doing")))
;; (org-vw--get-link-basename "[[lasdfjl/index.org][asdlkfj]]")
(defun fix-links-temporarily-in-current-buffer ()
  "Run every link thru `org-vw-preexp-link'."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (while (save-excursion
	     (re-search-forward
	      org-vw--link-re nil 'no-error))
      (goto-char (match-beginning 0))
      (org-vw-preexp-link))))
(string-match-p org-vw--link-re
		"[[maybe-not.org][maybe not]]")
(defun htmlize-current-buffer-to-file (file)
  "Run `htmlize-buffer' and save the result to FILE."
  (interactive "sWrite to file: ")
  (with-current-buffer (htmlize-buffer)
    (write-file file)
    (kill-buffer (current-buffer))))
(defun mir/export-buffer-to-html-fixed-links (file)
  "Synthesis of `fix-links-temporarily-in-current-buffer' and `htmlize-current-buffer-to-file'.  FILE is to be written."
  (interactive "sExport to file: ")
  (ignore-errors
    (evil-with-single-undo
      (fix-links-temporarily-in-current-buffer)
      (htmlize-current-buffer-to-file file))
    (evil-undo-pop)) ;todo later: can we wrap in something less evil?
  )
(defun org-vw-get-index-name (source basedir)
  "Given SOURCE, return the org link pointing to the corresponding html."
  (let* ((basename (file-name-directory source)))
    (if (string= (expand-file-name "index" basedir) basename)
	"./"
      (progn
	;; (ignore-errors (mkdir (format "%s/%s/" basedir basename) t))
	(format "./%s/" basename)) )))
;; (file-name-directory "test/index.tft")

;; big folder level export
(defun all-orgs-mds-in-dir (dir)
  "Return a list of every markdown and org file in DIR."
  (let ((default-directory dir))
    (--remove
     (or
      (f-directory-p it)
      (not (or
	    (string= (f-ext it) "md")
	    (string= (f-ext it) "org")
	    ))
      )
     (f-entries dir nil t))))
;; (all-orgs-mds-in-dir "/unicron_shared/webbed-site/public/")
;; loop over this

(defun do-file-in-sitedir (file sitedir)
  "too tired to write words. only code sry"
  (with-current-buffer (or (get-file-buffer file) (find-file file))
    (mir/export-buffer-to-html-fixed-links
     (org-vw-get-index-name file sitedir))))
(defun org-vw-export ()
  "htmlize recursively all org files in SITEDIR."
  (interactive "sDirectory (leave blank for current): ")
  (let* ((orgs-mds (all-orgs-mds-in-dir org-vw-staging-dir)))
    (message "------- org and markdown files: %s" orgs-mds)
    (--map
     (progn
       (message "operating on %s" it)
       (do-file-in-sitedir it (org-vw-get-index-name it sitedir)))
     orgs-mds)
    ))

;; -------------------- 

;; --------------------- below be dragons --------------------------------------

(defun org-vw-preexp-link ()
  "Re-format the next instance of name.org to name/ ."
  (let* ((link-regex org-vw--link-re)
	 (endpoint (re-search-forward link-regex))
	 (startpoint (re-search-backward link-regex))
	 (old-link-text (buffer-substring-no-properties startpoint endpoint))
	 (old-link-components
	  (--map (string-trim it (rx (+ "[")) (rx (+ "]")))
		 (split-string old-link-text "]\\[" t)))
	 (new-link-components
	  (list (org-vw-get-index-name
		 (car old-link-components)
		 org-vw-export-dir
		 ;; default-directory ; figure because we're necessarily in the buffer right?
		 )
		(cadr old-link-components)))
	 (new-link-text (format "[[%s][%s]]"
				(car new-link-components)
				(cadr new-link-components)))
	 (length-diff (- (length old-link-text) (length new-link-text))))
    (delete-region startpoint endpoint)
    (insert new-link-text)
    )
  )
;; ----------- that was a big dragon. carry on ---------------------------------

(defun org-vw-named-index-org (word)
  "given word, generate the absolute filename for that org-vw entry."
  (expand-file-name
   (format "%s/index.org" (downcase word)) org-vw-staging-dir))

(defun org-vw-make-newlink ()
  "Make the word at point the link to an org file, like in VimWiki."
  (interactive)
  ;; todo: can we use `save-excusion' ?
  (let* ((oldpoint (point))
	 (current-word (thing-at-point 'word 'no-properties))
	 (cw-file-name (org-vw-named-index-org current-word)))
    (backward-word)
    (kill-word 1)
    (org-insert-link nil cw-file-name current-word)
    (goto-char oldpoint)))
;; (org-insert-link nil "~/" "a file or sth")

;; (defun org-vw-show-markup () ;;broken, just use org-appear or sth
;;   "When on a line containing hidden characters, show them."
;;   (interactive)
;;   (let ((point (point))
;; 	(bol (point-at-bol))
;; 	(eol (point-at-eol)))
;;     (remove-text-properties bol eol
;; 			    '(invisible nil))
;;     t))
(defun org-vw-back ()
  "Go back to the previous org file and bury this buffer."
  (interactive)
  (if (buffer-modified-p)
      (if (y-or-n-p "Do you want to save this file?")
	  (save-buffer)))
  (bury-buffer)
  (other-window 1))

(defvar org-vw-pre-hook nil
  "Hook to run before org-vw-mode has been loaded.")
(define-minor-mode org-vw-mode
  "Org VimWiki mode."
  :lighter " VW"
  :keymap (make-sparse-keymap)
  (run-hooks org-vw-pre-hook)
  ;; TODO: This is a hack, because hyperbole is scary. Ideal implementation
  ;; would add a proper case rather than this weird fallback.
  ;; (require 'hyperbole)
  ;; (make-local-variable action-key-default-function)
  ;; (setq-local action-key-default-function #'org-vw-make-newlink)
  ;; General:
  (general-define-key
   :keymaps 'local
   :states 'normal
   "DEL" 'org-vw-back)
  (dolist (key mir/org-dwim-char-chars)
    (general-define-key
     :keymaps 'local
     key 'mir/org-dwim-char))
  )
;; (add-to-list 'auto-mode-alist `(,org-wiki-regex . org-vw-mode))
(add-hook 'org-mode-hook #'org-vw-mode)

;; ------------------ ABANDON ALL SANITY, YE WHO ENTER HERE --------------------

(defvar mir/org-dwim-char-chars '("_" "/" "*" "+" "~" "="))
(defun mir/org-dwim-char (&optional char)
  "If a region is active (visual mode), surround selection with CHAR.

If in a word, surround it with CHAR (like `evil-surround') or, if word is
already surrounded with CHAR, un-surround it.  If on the first character of a
word, run the default function that Evil binds the key CHAR to.

If the next character is the same as CHAR, move cursor past it \(like
`electric-pair').

If the line is a block delimiter or heading, or when in a protected block \(see
variable `org-protecting-blocks') or properties drawer, just insert the
character CHAR.

Otherwise, insert two of CHAR and put point between them like `electric-pair'."
  (interactive)		       ; TODO: can we make CHAR an arg to `interactive'?
  (let* ((char (or char (string-to-char (this-command-keys))))
	 (word (thing-at-point 'word 'no-properties))
	;;; test conditions here to be eval'd, separating flow from data
	 ;; at beginning of line
	 (beginning-of-line-test '(bolp))
	 ;; at beginning of word
	 (beginning-of-word-test `(or ,beginning-of-line-test
				      (eq (char-before (point)) ?\ )))
	 ;; word is surrounded by `char'
	 (surrounded-by-char-test
	  '(and (eq (char-before (beginning-of-thing 'word)) char)
		(eq (char-after (end-of-thing 'word)) char)))
	 ;; char before and char after are the same
	 (double-char-test (eq char (char-after)))
	 ;; Weird Org exceptions because org
	 (org-exceptions-test
	  '(or (and (bolp)
		    (string-match-p (rx bol (or "#" "*"))
				    (thing-at-point 'line 'no-properties)))
	       (org-in-block-p org-protecting-blocks)
	       (org-at-property-p))))
    (cond
     ((eq evil-state 'visual)
      (let* ((beg (region-beginning))
	     (end (region-end)))
	(evil-surround-region beg end evil-visual-selection char nil)))
     ((eq evil-state 'normal)
      (if (eval beginning-of-word-test)
	  ;; run original function bound to key
	  (let ((charstr (make-string 1 char)))
	    (call-interactively (alist-get charstr org-vw-old-binds-alist
					   nil nil #'string=)))
	(save-excursion
	  (if (eval surrounded-by-char-test)
	      (progn
		(search-backward (char-to-string char)) (delete-char 1)
		(search-forward (char-to-string char)) (delete-char -1))
	    (evil-with-single-undo
	      (beginning-of-thing 'word)
	      (insert char)
	      (end-of-thing 'word)
	      (insert char))))))
     ((eval double-char-test) (right-char))
     ((eval org-exceptions-test) (insert char))
     ((and (eval beginning-of-line-test) (eq char ?*))
      (insert char))
     (t (progn
	  (insert (make-string 2 char))
	  (left-char))))))
(defun org-vw-snapshot-bindings ()
  "Make an alist of the functions formerly ran by keys to be bound to `mir/org-dwim-char'.

Store it in the variable `org-vw-old-binds-alist'."
  (unless org-vw-old-binds-alist
    (defvar-local org-vw-old-binds-alist
	  (mapcar (lambda (key)
		    (cons key (key-binding key)))
		  mir/org-dwim-char-chars))))
(add-hook 'org-vw-pre-hook #'org-vw-snapshot-bindings nil 'local)

;; (defun org-vw-backspace)

;; (setq debug-on-error t)
;; --------- LET THY BRAIN NO LONGER TREMBLE, FOR I AM BECOME COMPLETE ---------

(provide 'mir-orgstuff)
;;; mir-orgstuff.el ends here