-
Notifications
You must be signed in to change notification settings - Fork 0
/
lisp-file-header.el
192 lines (166 loc) · 6.26 KB
/
lisp-file-header.el
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
187
188
189
190
191
192
;;; lisp-file-header.el --- Read the `file-header' form in Lisp languages -*- lexical-binding: t -*-
;; Copyright 2020, 2023, 2024 Lassi Kortela
;; SPDX-License-Identifier: ISC
;; Author: Lassi Kortela <lassi@lassi.io>
;; URL: https://github.com/lispunion/emacs-lisp-file-header
;; Package-Requires: ((emacs "24.3"))
;; Package-Version: 0.1.0
;; Keywords: languages lisp
;; This file is not part of GNU Emacs.
;;; Commentary:
;; Read the `file-header' form in Lisp languages.
;;; Code:
(require 'lisp-local)
(defun lisp-file-header--read-atmosphere ()
"Internal helper for `lisp-file-header-read'."
(let ((done nil))
(while (not done)
(if (or (looking-at "[ \n\r\t]+")
(looking-at ";.*$"))
(goto-char (match-end 0))
(setq done t)))))
(defun lisp-file-header--read-string ()
"Internal helper for `lisp-file-header-read'."
(let ((result ""))
(while (not (looking-at "\""))
(when (looking-at "$")
(signal 'invalid-read-syntax '("Multi-line string")))
(when (looking-at "[^\"\\\n\r]+")
(setq result (concat result (match-string-no-properties 0)))
(goto-char (match-end 0)))
(when (looking-at "\\\\\\(.\\)")
(setq result (concat result (match-string-no-properties 1)))
(goto-char (match-end 0))))
(goto-char (match-end 0))
result))
(defun lisp-file-header--read-list ()
"Internal helper for `lisp-file-header-read'."
(let ((result '())
(done nil))
(while (not done)
(lisp-file-header--read-atmosphere)
(cond ((looking-at ")")
(goto-char (match-end 0))
(setq done t))
(t
(setq result (cons (lisp-file-header--read-datum)
result)))))
(reverse result)))
(defun lisp-file-header--read-datum ()
"Internal helper for `lisp-file-header-read'."
(cond ((looking-at "\"")
(goto-char (match-end 0))
(lisp-file-header--read-string))
((looking-at "(")
(goto-char (match-end 0))
(lisp-file-header--read-list))
((looking-at ")")
(signal 'invalid-read-syntax '(")")))
((looking-at "[A-Za-z0-9*+-]+")
(let ((object (car (read-from-string
(match-string-no-properties 0)))))
(goto-char (match-end 0))
object))
((looking-at ".")
(signal 'invalid-read-syntax
(list (match-string-no-properties 0))))
(t
(signal 'end-of-file '()))))
(defun lisp-file-header--read ()
"Internal helper for `lisp-file-header-read'."
(let ((rounds 5)
(result nil))
(while (> rounds 0)
(lisp-file-header--read-atmosphere)
(let ((datum (condition-case _ (lisp-file-header--read-datum)
((invalid-read-syntax end-of-file)
(setq rounds 0)
nil))))
(cond ((and (consp datum)
(eql 'file-header (car datum)))
(setq result datum)
(setq rounds 0))
(t
(setq rounds (1- rounds))))))
result))
(defun lisp-file-header-read ()
"Read the `file-header' form in the current buffer.
Reads the current buffer using a lenient form of S-expression
syntax. If a (file-header ...) form is found near the top,
returns that form as an Emacs Lisp object. If a `file-header'
form is not found or cannot be read, nil is returned."
(save-match-data
(save-excursion
(save-restriction
(widen)
(goto-char (point-min))
(when (search-forward "file-header" 5000 t)
(goto-char (point-min))
(lisp-file-header--read))))))
(defun lisp-file-header-buffer-p ()
"Return non-nil if the current buffer has a (file-header ...) form."
(not (null (lisp-file-header-read))))
(defun lisp-file-header--get (body path)
"Internal helper to get subform PATH from (file-header BODY...)."
(dolist (name path body)
(when (and body (listp body))
(let ((entry (assoc name body)))
(setq body (and entry (cdr entry)))))))
(defun lisp-file-header-get (path)
"Get subform PATH from (file-header ...) in the current buffer."
(let ((body (cdr (lisp-file-header-read))))
(lisp-file-header--get body path)))
(defvar lisp-file-header-default-mode
'lisp-data-mode)
(defvar lisp-file-header--languages
'((clojure clojure-mode)
(clojurescript clojurescript-mode)
(common-lisp lisp-mode)
(elisp emacs-lisp-mode)
(emacs-lisp emacs-lisp-mode)
(newlisp newlisp-mode)
(racket racket-mode)
(scheme scheme-mode)))
(defun lisp-file-header--apply-language (body)
"Apply the `language' section of (file-header BODY ...)."
(let ((any-mode-found nil))
(dolist (language-name (lisp-file-header--get body '(language)))
(let ((mode nil))
(dolist (entry lisp-file-header--languages)
(when (and (not mode) (equal language-name (elt entry 0)))
(setq mode (elt entry 1))))
(when (fboundp mode)
(setq any-mode-found t)
(funcall mode))))
(unless any-mode-found
(funcall lisp-file-header-default-mode))))
(defun lisp-file-header--apply-indent (body)
"Apply the `indent' section of (file-header BODY ...)."
(let ((indent (lisp-file-header--get body '(indent))))
(dolist (indent-form indent)
(unless (and (listp indent-form)
(= 2 (length indent-form)))
(error "Bad indent: %S" indent-form))
(let ((sym (elt indent-form 0))
(ind (elt indent-form 1)))
(unless (symbolp sym)
(error "Bad indent: %S" indent-form))
(unless (and (integerp ind) (>= ind 0))
(error "Bad indent: %S" ind))
(lisp-local-set-indent (car indent-form)
(cadr indent-form))))))
(defun lisp-file-header--apply (body)
"Apply (file-header BODY ...)."
(lisp-file-header--apply-language body)
(lisp-file-header--apply-indent body))
(defun lisp-file-header-apply ()
"Apply `file-header' from current buffer."
(interactive)
(let ((body (cdr (lisp-file-header-read))))
(lisp-file-header--apply body)
(not (null body))))
(add-to-list 'magic-mode-alist
(cons 'lisp-file-header-buffer-p
'lisp-file-header-apply))
(provide 'lisp-file-header)
;;; lisp-file-header.el ends here