all messages for Emacs-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
blob 1c5c3581b92b1e691035f659f0d9af65eb4c2454 7769 bytes (raw)
name: lisp/org-src-context.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
 
;;; org-src-context.el --- LSP support for org-src buffers  -*- lexical-binding: t; -*-

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

;; Author: Karthik Chikmagalur <karthikchikmagalur@gmail.com>
;; Keywords: tools, languages, extensions

;; 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:

;; This file contains the code dealing with Language Server Protocol support via
;; other packages in Org Source buffers.

;;; Code:

(require 'org)
(require 'ob)
(require 'ob-tangle)
(require 'org-src)
(require 'cl-lib)

(declare-function eglot--maybe-activate-editing-mode "eglot")
(declare-function eglot-current-server "eglot")
(declare-function lsp-deferred "lsp-mode")

(defgroup org-src-context nil
  "Provides LSP support in org-src buffers."
  :group 'org)

(defcustom org-src-context-narrow-p t
  "Whether org-src buffers should be narrowed to the code block
with Eglot enabled."
  :type 'boolean
  :group 'org-src-context)

(defface org-src-context-read-only
  '((((class color) (min-colors 257) (background light))
     :background "#ffeeee" :extend t)
    (((class color) (min-colors 88) (background light))
     :background "#ffdddd" :extend t)
    (((class color) (min-colors 88) (background dark))
     :background "#553333" :extend t))
  "Face for read-only sections of org-src buffer"
  :group 'org-src-context)

(defvar-local org-src-context--before-block-marker nil)
(defvar-local org-src-context--after-block-marker nil)

(defun org-src-context--edit-src-ad (orig-fn &rest args)
  "Set up `org-src-mode' buffers for use with Eglot, Emacs' LSP client.

This does the following:

- Include all the code blocks associated with the current tangle
  file in the org-src buffer.
- Associate the buffer with a temporary file.
- Connect to a running LSP server with Eglot."
  (if-let* ((info (org-babel-get-src-block-info 'light))
            (lang (car info))
            (this-block-data
             (save-excursion
               (goto-char
                (org-element-property :begin (org-element-at-point)))
               (car (org-babel-tangle-single-block 1 t))))
            (tangle-file (car this-block-data))
            (this-block (cadr this-block-data))
            (all-blocks (cdar (org-babel-tangle-collect-blocks
                               lang (alist-get :tangle (caddr info)))))
            (extra-blocks (list nil)))
    
      (prog1 (apply orig-fn args)
        (setq extra-blocks
              (cl-loop for block in all-blocks
                       until (equal (nth 1 block) (nth 1 this-block))
                       collect block into before-blocks
                       finally return
                       (cons before-blocks (nthcdr (1+ (length before-blocks))
                                                   all-blocks))))
        
        (when (or (car extra-blocks) (cdr extra-blocks))
          (save-excursion
          ;; TODO: Handle :padlines, :shebang
          
          ;; Code blocks before the current one
          (cl-loop initially do
                   (progn (goto-char (point-min))
                          (when (car extra-blocks) (insert "\n") (backward-char 1)))
                   for block in (car extra-blocks)
                   for code = (propertize (concat "\n" (nth 6 block)
                                                  (propertize "\n" 'rear-nonsticky t))
                                          'read-only t
                                          'font-lock-face 'org-src-context-read-only)
                   do (insert code))
          (setq-local org-src-context--before-block-marker (point-marker))
          (set-marker-insertion-type org-src-context--before-block-marker nil)
          
          (setq-local org-src-context--after-block-marker (point-max-marker))
          (set-marker-insertion-type org-src-context--after-block-marker nil)
          ;; Code blocks after the current one
          (cl-loop initially do (goto-char (point-max))
                   for block in (cdr extra-blocks)
                   for code = (propertize (concat "\n" (nth 6 block)
                                                  (propertize "\n" 'rear-nonsticky t))
                                          'read-only t
                                          'font-lock-face 'org-src-context-read-only)
                   do (insert code))
          
          (when org-src-context-narrow-p
            (narrow-to-region (marker-position org-src-context--before-block-marker)
                              (marker-position org-src-context--after-block-marker)))))
        
        (org-src-context--connect-maybe info tangle-file))
    
    ;; No tangle file, don't do anything
    (apply orig-fn args)))

(defun org-src-context--exit-src-ad ()
  "Format `org-src-mode' buffers before updating the associated
Org buffer."
  (when-let ((markerp org-src-context--before-block-marker)
             (markerp org-src-context--after-block-marker)
             (beg (marker-position org-src-context--before-block-marker))
             (end (marker-position org-src-context--after-block-marker))
             (inhibit-read-only t))
    (when org-src-context-narrow-p
      (widen))
    (delete-region end (point-max))
    (delete-region (point-min) beg)))

(defun org-src-context--lsp-connect ()
  "Connect to an LSP server managing the current buffer's file."
  (when-let (((fboundp 'eglot-current-server))
             (current-server (eglot-current-server)))
    (eglot--maybe-activate-editing-mode)))

(defun org-src-context--connect-maybe (info tangle-file)
  "Prepare org source block buffer for an LSP connection"
  (when tangle-file
    ;; Handle directory paths in tangle-file
    (let* ((fnd (file-name-directory tangle-file))
           (mkdirp (thread-last info caddr (alist-get :mkdirp)))
           ;;`file-name-concat' is emacs 28.1+ only
           (fnd-absolute (concat (temporary-file-directory) (or fnd ""))))
      (cond
       ((not fnd) t)
       ((file-directory-p fnd-absolute) t)
       ((and fnd (and (stringp mkdirp) (string= (downcase mkdirp) "yes")))
        (make-directory fnd-absolute 'parents))
       (t (user-error
           (format "Cannot create directory \"%s\", please use the :mkdirp header arg." fnd))))
      
      (setq buffer-file-name (concat (temporary-file-directory) tangle-file))
      (org-src-context--lsp-connect))))

(define-minor-mode org-src-context-mode
  "Toggle Org-Src-Context mode. When turned on, you can start persistent
LSP connections using Eglot in org-src buffers.

To inform the Language Server about files corresponding to code
blocks to track, use `:tangle' headers with code blocks. LSP
support is limited to the current file being edited."
  :global t
  :lighter nil
  :group 'org-src-context
  (if org-src-context-mode
      (progn
        (advice-add 'org-edit-src-code :around #'org-src-context--edit-src-ad)
        (advice-add 'org-edit-src-exit :before #'org-src-context--exit-src-ad))
    (advice-remove 'org-edit-src-code #'org-src-context--edit-src-ad)
    (advice-remove 'org-edit-src-exit #'org-src-context--exit-src-ad)))

(provide 'org-src-context)
;;; org-src-context.el ends here


debug log:

solving 1c5c358 ...
found 1c5c358 in https://yhetil.org/emacs/87bkqmdhqz.fsf@gmail.com/

applying [1/1] https://yhetil.org/emacs/87bkqmdhqz.fsf@gmail.com/
diff --git a/lisp/org-src-context.el b/lisp/org-src-context.el
new file mode 100644
index 0000000..1c5c358

1:88: trailing whitespace.
    
1:97: trailing whitespace.
        
1:101: trailing whitespace.
          
1:114: trailing whitespace.
          
1:125: trailing whitespace.
          
Checking patch lisp/org-src-context.el...
Applied patch lisp/org-src-context.el cleanly.
warning: squelched 4 whitespace errors
warning: 9 lines add whitespace errors.

index at:
100644 1c5c3581b92b1e691035f659f0d9af65eb4c2454	lisp/org-src-context.el

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/emacs.git
	https://git.savannah.gnu.org/cgit/emacs/org-mode.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.