org-link-edit.el 14 KB

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