contrib/lisp/org-link-edit.el

   1 ;;; org-link-edit.el --- Slurp and barf with Org links
   2
   3 ;; Copyright (C) 2015 Kyle Meyer <kyle@kyleam.com>
   4
   5 ;; Author:  Kyle Meyer <kyle@kyleam.com>
   6 ;; URL: https://github.com/kyleam/org-link-edit
   7 ;; Keywords: convenience
   8 ;; Version: 1.0.0
   9 ;; Package-Requires: ((cl-lib "0.5") (org "8.2"))
  10
  11 ;; This program is free software; you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; This program is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Org Link Edit provides Paredit-inspired slurping and barfing
  27 ;; commands for Org link descriptions.
  28 ;;
  29 ;; There are four commands, all which operate when point is on an Org
  30 ;; link.
  31 ;;
  32 ;; - org-link-edit-forward-slurp
  33 ;; - org-link-edit-backward-slurp
  34 ;; - org-link-edit-forward-barf
  35 ;; - org-link-edit-backward-barf
  36 ;;
  37 ;; Org Link Edit doesn't bind these commands to any keys.  Finding
  38 ;; good keys for these commands is difficult because, while it's
  39 ;; convenient to be able to quickly repeat these commands, they won't
  40 ;; be used frequently enough to be worthy of a short, repeat-friendly
  41 ;; binding.  Using Hydra [1] provides a nice solution to this.  After
  42 ;; an initial key sequence, any of the commands will be repeatable
  43 ;; with a single key.  (Plus, you get a nice interface that displays
  44 ;; the key for each command.)  Below is one example of how you could
  45 ;; configure this.
  46 ;;
  47 ;;     (define-key org-mode-map YOUR-KEY
  48 ;;       (defhydra hydra-org-link-edit ()
  49 ;;         "Org Link Edit"
  50 ;;         ("j" org-link-edit-forward-slurp "forward slurp")
  51 ;;         ("k" org-link-edit-forward-barf "forward barf")
  52 ;;         ("u" org-link-edit-backward-slurp "backward slurp")
  53 ;;         ("i" org-link-edit-backward-barf "backward barf")
  54 ;;         ("q" nil "cancel")))
  55 ;;
  56 ;; [1] https://github.com/abo-abo/hydra
  57
  58 ;;; Code:
  59
  60 (require 'org)
  61 (require 'org-element)
  62 (require 'cl-lib)
  63
  64 (defun org-link-edit--get-link-data ()
  65   "Return list with information about the link at point.
  66 The list includes
  67 - the position at the start of the link
  68 - the position at the end of the link
  69 - the link text
  70 - the link description (nil when on a plain link)"
  71   (let ((el (org-element-context)))
  72     ;; Don't use `org-element-lineage' because it isn't available
  73     ;; until Org version 8.3.
  74     (while (and el (not (memq (car el) '(link))))
  75       (setq el (org-element-property :parent el)))
  76     (unless (eq (car el) 'link)
  77       (user-error "Point is not on a link"))
  78     (save-excursion
  79       (goto-char (org-element-property :begin el))
  80       (cond
  81        ;; Use match-{beginning,end} because match-end is consistently
  82        ;; positioned after ]], while the :end property is positioned
  83        ;; at the next word on the line, if one is present.
  84        ((looking-at org-bracket-link-regexp)
  85         (list (match-beginning 0)
  86               (match-end 0)
  87               (match-string-no-properties 1)
  88               (or (and (match-end 3)
  89                        (match-string-no-properties 3))
  90                   "")))
  91        ((looking-at org-plain-link-re)
  92         (list (match-beginning 0)
  93               (match-end 0)
  94               (match-string-no-properties 0)
  95               nil))
  96        (t
  97         (error "What am I looking at?"))))))
  98
  99 (defun org-link-edit--forward-blob (n &optional no-punctuation)
 100   "Move forward N blobs (backward if N is negative).
 101
 102 A block of non-whitespace characters is a blob.  If
 103 NO-PUNCTUATION is non-nil, trailing punctuation characters are
 104 not considered part of the blob when going in the forward
 105 direction.
 106
 107 If the edge of the buffer is reached before completing the
 108 movement, return nil.  Otherwise, return t."
 109   (let* ((forward-p (> n 0))
 110          (nblobs (abs n))
 111          (skip-func (if forward-p 'skip-syntax-forward 'skip-syntax-backward))
 112          skip-func-retval)
 113     (while (/= nblobs 0)
 114       (funcall skip-func " ")
 115       (setq skip-func-retval (funcall skip-func "^ "))
 116       (setq nblobs (1- nblobs)))
 117     (when (and forward-p no-punctuation)
 118       (let ((punc-tail-offset (save-excursion (skip-syntax-backward "."))))
 119         ;; Don't consider trailing punctuation as part of the blob
 120         ;; unless the whole blob consists of punctuation.
 121         (unless (= skip-func-retval (- punc-tail-offset))
 122           (goto-char (+ (point) punc-tail-offset)))))
 123     (/= skip-func-retval 0)))
 124
 125 ;;;###autoload
 126 (defun org-link-edit-forward-slurp (&optional n)
 127   "Slurp N trailing blobs into link's description.
 128
 129   The \[\[http://orgmode.org/\]\[Org mode\]\] site
 130
 131                         |
 132                         v
 133
 134   The \[\[http://orgmode.org/\]\[Org mode site\]\]
 135
 136 A blob is a block of non-whitespace characters.  When slurping
 137 forward, trailing punctuation characters are not considered part
 138 of a blob.
 139
 140 After slurping, return the slurped text and move point to the
 141 beginning of the link.
 142
 143 If N is negative, slurp leading blobs instead of trailing blobs."
 144   (interactive "p")
 145   (setq n (or n 1))
 146   (cond
 147    ((= n 0))
 148    ((< n 0)
 149     (org-link-edit-backward-slurp (- n)))
 150    (t
 151     (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data)
 152       (goto-char (save-excursion
 153                    (goto-char end)
 154                    (or (org-link-edit--forward-blob n 'no-punctuation)
 155                        (user-error "Not enough blobs after the link"))
 156                    (point)))
 157       (let ((slurped (buffer-substring-no-properties end (point))))
 158         (setq slurped (replace-regexp-in-string "\n+" " " slurped))
 159         (when (and (= (length desc) 0)
 160                    (string-match "^\\s-+\\(.*\\)" slurped))
 161           (setq slurped (match-string 1 slurped)))
 162         (setq desc (concat desc slurped)
 163               end (+ end (length slurped)))
 164         (delete-region beg (point))
 165         (insert (org-make-link-string link desc))
 166         (goto-char beg)
 167         slurped)))))
 168
 169 ;;;###autoload
 170 (defun org-link-edit-backward-slurp (&optional n)
 171   "Slurp N leading blobs into link's description.
 172
 173   The \[\[http://orgmode.org/\]\[Org mode\]\] site
 174
 175                         |
 176                         v
 177
 178   \[\[http://orgmode.org/\]\[The Org mode\]\] site
 179
 180 A blob is a block of non-whitespace characters.
 181
 182 After slurping, return the slurped text and move point to the
 183 beginning of the link.
 184
 185 If N is negative, slurp trailing blobs instead of leading blobs."
 186   (interactive "p")
 187   (setq n (or n 1))
 188   (cond
 189    ((= n 0))
 190    ((< n 0)
 191     (org-link-edit-forward-slurp (- n)))
 192    (t
 193     (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data)
 194       (goto-char (save-excursion
 195                    (goto-char beg)
 196                    (or (org-link-edit--forward-blob (- n))
 197                        (user-error "Not enough blobs before the link"))
 198                    (point)))
 199       (let ((slurped (buffer-substring-no-properties (point) beg)))
 200         (when (and (= (length desc) 0)
 201                    (string-match "\\(.*\\)\\s-+$" slurped))
 202           (setq slurped (match-string 1 slurped)))
 203         (setq slurped (replace-regexp-in-string "\n+" " " slurped))
 204         (setq desc (concat slurped desc)
 205               beg (- beg (length slurped)))
 206         (delete-region (point) end)
 207         (insert (org-make-link-string link desc))
 208         (goto-char beg)
 209         slurped)))))
 210
 211 (defun org-link-edit--split-first-blobs (string n)
 212   "Split STRING into (N first blobs . other) cons cell.
 213 'N first blobs' contains all text from the start of STRING up to
 214 the start of the N+1 blob.  'other' includes the remaining text
 215 of STRING.  If the number of blobs in STRING is fewer than N,
 216 'other' is nil."
 217   (when (< n 0) (user-error "N cannot be negative"))
 218   (with-temp-buffer
 219     (insert string)
 220     (goto-char (point-min))
 221     (with-syntax-table org-mode-syntax-table
 222       (let ((within-bound (org-link-edit--forward-blob n)))
 223         (skip-syntax-forward " ")
 224         (cons (buffer-substring 1 (point))
 225               (and within-bound
 226                    (buffer-substring (point) (point-max))))))))
 227
 228 (defun org-link-edit--split-last-blobs (string n)
 229   "Split STRING into (other . N last blobs) cons cell.
 230 'N last blobs' contains all text from the end of STRING back to
 231 the end of the N+1 last blob.  'other' includes the remaining
 232 text of STRING.  If the number of blobs in STRING is fewer than
 233 N, 'other' is nil."
 234   (when (< n 0) (user-error "N cannot be negative"))
 235   (with-temp-buffer
 236     (insert string)
 237     (goto-char (point-max))
 238     (with-syntax-table org-mode-syntax-table
 239       (let ((within-bound (org-link-edit--forward-blob (- n))))
 240         (skip-syntax-backward " ")
 241         (cons (and within-bound
 242                    (buffer-substring 1 (point)))
 243               (buffer-substring (point) (point-max)))))))
 244
 245 ;;;###autoload
 246 (defun org-link-edit-forward-barf (&optional n)
 247   "Barf N trailing blobs from link's description.
 248
 249   The \[\[http://orgmode.org/\]\[Org mode\]\] site
 250
 251                         |
 252                         v
 253
 254   The \[\[http://orgmode.org/\]\[Org\]\] mode site
 255
 256 A blob is a block of non-whitespace characters.
 257
 258 After barfing, return the barfed text and move point to the
 259 beginning of the link.
 260
 261 If N is negative, barf leading blobs instead of trailing blobs."
 262   (interactive "p")
 263   (setq n (or n 1))
 264   (cond
 265    ((= n 0))
 266    ((< n 0)
 267     (org-link-edit-backward-barf (- n)))
 268    (t
 269     (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data)
 270       (when (= (length desc) 0)
 271         (user-error "Link has no description"))
 272       (pcase-let ((`(,new-desc . ,barfed) (org-link-edit--split-last-blobs
 273                                            desc n)))
 274         (unless new-desc (user-error "Not enough blobs in description"))
 275         (delete-region beg end)
 276         (insert (org-make-link-string link new-desc))
 277         (if (string= new-desc "")
 278             ;; Two brackets are dropped when an empty description is
 279             ;; passed to `org-make-link-string'.
 280             (progn (goto-char (- end (+ 2 (length desc))))
 281                    (setq barfed (concat " " barfed)))
 282           (goto-char (- end (- (length desc) (length new-desc)))))
 283         (insert barfed)
 284         (goto-char beg)
 285         barfed)))))
 286
 287 ;;;###autoload
 288 (defun org-link-edit-backward-barf (&optional n)
 289   "Barf N leading blobs from link's description.
 290
 291   The \[\[http://orgmode.org/\]\[Org mode\]\] site
 292
 293                         |
 294                         v
 295
 296   The Org \[\[http://orgmode.org/\]\[mode\]\] site
 297
 298 A blob is a block of non-whitespace characters.
 299
 300 After barfing, return the barfed text and move point to the
 301 beginning of the link.
 302
 303 If N is negative, barf trailing blobs instead of leading blobs."
 304   (interactive "p")
 305   (setq n (or n 1))
 306   (cond
 307    ((= n 0))
 308    ((< n 0)
 309     (org-link-edit-forward-barf (- n)))
 310    (t
 311     (cl-multiple-value-bind (beg end link desc) (org-link-edit--get-link-data)
 312       (when (= (length desc) 0)
 313         (user-error "Link has no description"))
 314       (pcase-let ((`(,barfed . ,new-desc) (org-link-edit--split-first-blobs
 315                                            desc n)))
 316         (unless new-desc (user-error "Not enough blobs in description"))
 317         (delete-region beg end)
 318         (insert (org-make-link-string link new-desc))
 319         (when (string= new-desc "")
 320           (setq barfed (concat barfed " ")))
 321         (goto-char beg)
 322         (insert barfed)
 323         (goto-char (+ beg (length barfed)))
 324         barfed)))))
 325
 326 (provide 'org-link-edit)
 327 ;;; org-link-edit.el ends here