|
1 ;;; haskell-ts-mode.el --- A treesit based major mode for haskell -*- lexical-binding:t -*- |
|
2 |
|
3 ;; Copyright (C) 2024 Pranshu Sharma |
|
4 |
|
5 |
|
6 ;; Author: Pranshu Sharma <pranshusharma366 at gmail> |
|
7 ;; URL: https://codeberg.org/pranshu/haskell-ts-mode |
|
8 ;; Package-Requires: ((emacs "29.3")) |
|
9 ;; Version: 1 |
|
10 ;; Keywords: languages, haskell |
|
11 |
|
12 ;; This program is free software; you can redistribute it and/or modify |
|
13 ;; it under the terms of the GNU General Public License as published by |
|
14 ;; the Free Software Foundation, either version 3 of the License, or |
|
15 ;; (at your option) any later version. |
|
16 |
|
17 ;; This program is distributed in the hope that it will be useful, |
|
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
20 ;; GNU General Public License for more details. |
|
21 |
|
22 ;; You should have received a copy of the GNU General Public License |
|
23 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. |
|
24 |
|
25 ;;; Commentary: |
|
26 |
|
27 ;; This is a major mode that uses treesitter to provide all the basic |
|
28 ;; major mode stuff, like indentation, font lock, etc... |
|
29 |
|
30 ;;; Code: |
|
31 |
|
32 (require 'comint) |
|
33 (require 'treesit) |
|
34 |
|
35 (declare-function treesit-parser-create "treesit.c") |
|
36 (declare-function treesit-node-start "treesit.c") |
|
37 (declare-function treesit-node-parent "treesit.c") |
|
38 (declare-function treesit-node-prev-sibling "treesit.c") |
|
39 (declare-function treesit-node-next-sibling "treesit.c") |
|
40 (declare-function treesit-node-end "treesit.c") |
|
41 (declare-function treesit-node-child "treesit.c") |
|
42 (declare-function treesit-node-type "treesit.c") |
|
43 |
|
44 (defgroup haskell-ts-mode nil |
|
45 "Group that contains haskell-ts-mode variables" |
|
46 :group 'langs) |
|
47 |
|
48 (defvar haskell-ts-font-lock-feature-list |
|
49 `((comment str pragma parens) |
|
50 (type definition function args) |
|
51 (match keyword) |
|
52 (otherwise signature type-sig))) |
|
53 |
|
54 (defcustom haskell-ts-use-indent t |
|
55 "Set to non-nil to use the indentation provided by haskell-ts-mode" |
|
56 :group 'haskell-ts-mode |
|
57 :type 'boolean) |
|
58 |
|
59 (defcustom haskell-ts-font-lock-level 4 |
|
60 "Level of font lock, 1 for minimum highlghting and 4 for maximum." |
|
61 :group 'haskell-ts-mode |
|
62 :type 'integer) |
|
63 |
|
64 (defvar haskell-ts-prettify-symbols-alist |
|
65 '(("\\" . "λ") |
|
66 ("/=" . "≠") |
|
67 ("->" . "→") |
|
68 ("=>" . "⇒") |
|
69 ("<-" . "←") |
|
70 ("<=" . "≥") |
|
71 (">=" . "≤"))) |
|
72 |
|
73 (defvar haskell-ts-font-lock |
|
74 (treesit-font-lock-rules |
|
75 :language 'haskell |
|
76 :feature 'keyword |
|
77 `(["module" "import" "data" "let" "where" "case" "type" |
|
78 "if" "then" "else" "of" "do" "in" "instance" "class"] |
|
79 @font-lock-keyword-face) |
|
80 :language 'haskell |
|
81 :feature 'otherwise |
|
82 :override t |
|
83 `(((match (guards guard: (boolean (variable) @font-lock-keyword-face))) |
|
84 (:match "otherwise" @font-lock-keyword-face))) |
|
85 :language 'haskell |
|
86 :feature 'type-sig |
|
87 "(signature (binding_list (variable) @font-lock-doc-markup-face)) |
|
88 (signature (variable) @font-lock-doc-markup-face)" |
|
89 :language 'haskell |
|
90 :feature 'args |
|
91 :override 'keep |
|
92 (concat |
|
93 "(function (infix left_operand: (_) @haskell-ts--fontify-arg))" |
|
94 "(function (infix right_operand: (_) @haskell-ts--fontify-arg))" |
|
95 "(generator . (_) @haskell-ts--fontify-arg)" |
|
96 "(bind (as (variable) . (_) @haskell-ts--fontify-arg))" |
|
97 "(patterns) @haskell-ts--fontify-arg") |
|
98 :language 'haskell |
|
99 :feature 'type |
|
100 `((type) @font-lock-type-face |
|
101 (constructor) @font-lock-type-face) |
|
102 :language 'haskell |
|
103 :override t |
|
104 :feature 'signature |
|
105 `((signature (function) @haskell-ts--fontify-type) |
|
106 (context (function) @haskell-ts--fontify-type)) |
|
107 :language 'haskell |
|
108 :feature 'match |
|
109 `((match ("|" @font-lock-doc-face) ("=" @font-lock-doc-face)) |
|
110 (list_comprehension ("|" @font-lock-doc-face |
|
111 (qualifiers (generator "<-" @font-lock-doc-face)))) |
|
112 (match ("->" @font-lock-doc-face))) |
|
113 :language 'haskell |
|
114 :feature 'comment |
|
115 `(((comment) @font-lock-comment-face) |
|
116 ((haddock) @font-lock-doc-face)) |
|
117 :language 'haskell |
|
118 :feature 'pragma |
|
119 `((pragma) @font-lock-preprocessor-face |
|
120 (cpp) @font-lock-preprocessor-face) |
|
121 :language 'haskell |
|
122 :feature 'str |
|
123 :override t |
|
124 `((char) @font-lock-string-face |
|
125 (string) @font-lock-string-face |
|
126 (quasiquote (quoter) @font-lock-type-face) |
|
127 (quasiquote (quasiquote_body) @font-lock-preprocessor-face)) |
|
128 :language 'haskell |
|
129 :feature 'parens |
|
130 :override t |
|
131 `(["(" ")" "[" "]"] @font-lock-operator-face |
|
132 (infix operator: (_) @font-lock-operator-face)) |
|
133 :language 'haskell |
|
134 :feature 'function |
|
135 :override t |
|
136 `((function name: (variable) @font-lock-function-name-face) |
|
137 (function (infix (operator) @font-lock-function-name-face)) |
|
138 (declarations (type_synomym (name) @font-lock-function-name-face)) |
|
139 (bind (variable) @font-lock-function-name-face) |
|
140 (function (infix (infix_id (variable) @font-lock-function-name-face))) |
|
141 (bind (as (variable) @font-lock-function-name-face)))) |
|
142 "A function that returns the treesit font lock lock settings for haskell.") |
|
143 |
|
144 (defun haskell-ts--stand-alone-parent (_ parent bol) |
|
145 (save-excursion |
|
146 (goto-char (treesit-node-start parent)) |
|
147 (let ((type (treesit-node-type parent))) |
|
148 (if (and (not bol) |
|
149 (or (looking-back "^[ \t]*" (line-beginning-position)) |
|
150 (seq-some |
|
151 (lambda (kw) |
|
152 (string= type kw)) |
|
153 '("when" "where" "do" "let" "local_binds" "function")))) |
|
154 (treesit-node-start parent) |
|
155 (haskell-ts--stand-alone-parent 1 (funcall |
|
156 (if bol 'treesit-node-parent 'identity) |
|
157 (treesit-node-parent parent)) |
|
158 nil))))) |
|
159 |
|
160 (defvar haskell-ts--ignore-types |
|
161 (regexp-opt '("comment" "cpp" "haddock")) |
|
162 "Node types that will be ignored by indentation.") |
|
163 |
|
164 (defvar haskell-ts-indent-rules |
|
165 (let* ((p-sib |
|
166 (lambda (node arg) |
|
167 (let* ((func (if arg |
|
168 'treesit-node-prev-sibling |
|
169 'treesit-node-next-sibling)) |
|
170 (n (funcall func node))) |
|
171 (while (and n (string-match haskell-ts--ignore-types |
|
172 (treesit-node-type n))) |
|
173 (setq n (funcall func n))) |
|
174 n))) |
|
175 (p-prev-sib |
|
176 (lambda (node _ _) (treesit-node-start (funcall p-sib node t)))) |
|
177 (p-n-prev (lambda (node) (funcall p-sib node t))) |
|
178 (parent-first-child (lambda (_ parent _) |
|
179 (treesit-node-start (treesit-node-child parent 0))))) |
|
180 `((haskell |
|
181 ((node-is "^cpp$") column-0 0) |
|
182 ((parent-is "^comment$") column-0 0) |
|
183 ((parent-is "^haddock$") column-0 0) |
|
184 ((parent-is "^imports$") column-0 0) |
|
185 ;; Infix |
|
186 ((n-p-gp nil "infix" "infix") |
|
187 (lambda (_ node _) |
|
188 (let ((first-inf nil)) |
|
189 (while (string= "infix" |
|
190 (treesit-node-type |
|
191 (setq node (treesit-node-parent node)))) |
|
192 (setq first-inf node)) |
|
193 (funcall ,parent-first-child nil first-inf nil))) |
|
194 0) |
|
195 ((node-is "^infix$") ,parent-first-child 0) |
|
196 |
|
197 ;; Lambda |
|
198 ((parent-is "^lambda\\(_case\\)?$") standalone-parent 2) |
|
199 |
|
200 ((parent-is "^class_declarations$") prev-sibling 0) |
|
201 |
|
202 ((node-is "^where$") parent 2) |
|
203 |
|
204 ;; in |
|
205 ((node-is "^in$") parent 0) |
|
206 |
|
207 ((parent-is "qualifiers") parent 0) |
|
208 |
|
209 ;; list |
|
210 ((node-is "^]$") parent 0) |
|
211 ((parent-is "^list$") standalone-parent 2) |
|
212 |
|
213 ;; If then else |
|
214 ((node-is "^then$") parent 2) |
|
215 ((node-is "^else$") parent 2) |
|
216 |
|
217 ((parent-is "^apply$") haskell-ts--stand-alone-parent 1) |
|
218 ((node-is "^quasiquote$") grand-parent 2) |
|
219 ((parent-is "^quasiquote_body$") (lambda (_ _ c) c) 0) |
|
220 ((lambda (node parent bol) |
|
221 (when-let ((n (treesit-node-prev-sibling node))) |
|
222 (while (string= "comment" (treesit-node-type n)) |
|
223 (setq n (treesit-node-prev-sibling n))) |
|
224 (string= "do" (treesit-node-type n)))) |
|
225 haskell-ts--stand-alone-parent |
|
226 3) |
|
227 ((parent-is "^do$") ,p-prev-sib 0) |
|
228 |
|
229 ((parent-is "^alternatives$") ,p-prev-sib 0) |
|
230 |
|
231 ;; prev-adaptive-prefix is broken sometimes |
|
232 (no-node |
|
233 (lambda (_ _ _) |
|
234 (save-excursion |
|
235 (goto-char (line-beginning-position 0)) |
|
236 (back-to-indentation) |
|
237 (point))) |
|
238 0) |
|
239 |
|
240 ((parent-is "^data_constructors$") parent 0) |
|
241 |
|
242 ;; where |
|
243 ((lambda (node _ _) |
|
244 (let ((n (treesit-node-prev-sibling node))) |
|
245 (while (string= "comment" (treesit-node-type n)) |
|
246 (setq n (treesit-node-prev-sibling n))) |
|
247 (string= "where" (treesit-node-type n)))) |
|
248 |
|
249 (lambda (_ b _) |
|
250 (+ 1 (treesit-node-start (treesit-node-prev-sibling b)))) |
|
251 3) |
|
252 ((parent-is "local_binds\\|instance_declarations") ,p-prev-sib 0) |
|
253 |
|
254 ;; Match |
|
255 ((lambda (node _ _) |
|
256 (and (string= "match" (treesit-node-type node)) |
|
257 (string-match (regexp-opt '("patterns" "variable")) |
|
258 (treesit-node-type (funcall ,p-n-prev node))))) |
|
259 standalone-parent 2) |
|
260 |
|
261 ((node-is "match") ,p-prev-sib 0) |
|
262 ((parent-is "match") standalone-parent 2) |
|
263 |
|
264 ((parent-is "^haskell$") column-0 0) |
|
265 ((parent-is "^declarations$") column-0 0) |
|
266 |
|
267 ((parent-is "^record$") standalone-parent 2) |
|
268 |
|
269 ((parent-is "^exports$") |
|
270 (lambda (_ b _) (treesit-node-start (treesit-node-prev-sibling b))) |
|
271 0) |
|
272 ((n-p-gp nil "signature" "foreign_import") grand-parent 3) |
|
273 ((parent-is "^case$") standalone-parent 4) |
|
274 ((node-is "^alternatives$") |
|
275 (lambda (_ b _) |
|
276 (treesit-node-start (treesit-node-child b 0))) |
|
277 2) |
|
278 ((node-is "^comment$") |
|
279 ;; Indenting comments by priorites: |
|
280 ;; 1. next relevent sibling if exists |
|
281 ;; 2. previous relevent sibling if exists |
|
282 ;; 3. parent |
|
283 ;; (relevent means type not it haskell-ts--ignore-types) |
|
284 (lambda (node parent _) |
|
285 (if-let ((next-sib (funcall ,p-sib node nil))) |
|
286 (treesit-node-start next-sib) |
|
287 (if-let ((prev-sib (funcall ,p-prev-sib node nil nil))) |
|
288 prev-sib |
|
289 (treesit-node-start parent)))) |
|
290 0) |
|
291 ;; Backup |
|
292 (catch-all parent 2))))) |
|
293 |
|
294 ;; Copied from haskell-tng-mode, changed a bit |
|
295 |
|
296 (defvar haskell-ts-mode-syntax-table |
|
297 (let ((table (make-syntax-table))) |
|
298 ;; The defaults are mostly fine |
|
299 (mapc |
|
300 (lambda (ls) |
|
301 (mapc |
|
302 (lambda (char) |
|
303 (modify-syntax-entry char (car ls) table)) |
|
304 (cdr ls))) |
|
305 '(("_" ?! ?_) |
|
306 ("w" ?') |
|
307 ;; Haskell has some goofy comment enders like C-q C-l |
|
308 (">" 13 10 12 11) |
|
309 ("_ 123" ?-) |
|
310 ("(}1nb" ?\{) |
|
311 ("){4nb" ?\}) |
|
312 ("<" ?#) |
|
313 (">" ?\n) |
|
314 ;; Special operaters |
|
315 ("." ?\, ?\; ?@) |
|
316 ("\"" ?\") |
|
317 ("$`" ?\`))) |
|
318 table)) |
|
319 |
|
320 (defmacro haskell-ts-imenu-name-function (check-func) |
|
321 `(lambda (node) |
|
322 (let ((nn (treesit-node-child node 0 node))) |
|
323 (if (funcall ,check-func node) |
|
324 (if (string= (treesit-node-type nn) "infix") |
|
325 (treesit-node-text (treesit-node-child nn 1)) |
|
326 (haskell-ts-defun-name node)) |
|
327 nil)))) |
|
328 |
|
329 (defun haskell-ts-indent-defun (pos) |
|
330 "Indent the current function." |
|
331 (interactive "d") |
|
332 (let ((node (treesit-node-at pos))) |
|
333 (while (not (string-match |
|
334 "^declarations$\\|haskell" |
|
335 (treesit-node-type (treesit-node-parent node)))) |
|
336 (setq node (treesit-node-parent node))) |
|
337 (indent-region (treesit-node-start node) (treesit-node-end node)))) |
|
338 |
|
339 (defvar haskell-ts-mode-map |
|
340 (let ((km (make-sparse-keymap))) |
|
341 (define-key km (kbd "C-c C-c") 'haskell-ts-compile-region-and-go) |
|
342 (define-key km (kbd "C-c C-r") 'haskell-ts-run-haskell) |
|
343 (define-key km (kbd "C-M-q") 'haskell-ts-indent-defun) ; For those who don't have emacs 30 |
|
344 km) |
|
345 "Map for haskell-ts-mode.") |
|
346 |
|
347 ;;;###autoload |
|
348 (define-derived-mode haskell-ts-mode prog-mode "haskell ts mode" |
|
349 "Major mode for Haskell files using tree-sitter." |
|
350 (unless (treesit-ready-p 'haskell) |
|
351 (error "Tree-sitter for Haskell is not available")) |
|
352 (treesit-parser-create 'haskell) |
|
353 (setq-local treesit-defun-type-regexp "\\(?:\\(?:function\\|struct\\)_definition\\)") |
|
354 ;; Indent |
|
355 (when haskell-ts-use-indent |
|
356 (setq-local treesit-simple-indent-rules haskell-ts-indent-rules) |
|
357 (setq-local indent-tabs-mode nil)) |
|
358 ;; Comment |
|
359 (setq-local comment-start "-- ") |
|
360 (setq-local comment-use-syntax t) |
|
361 (setq-local comment-start-skip "\\(?: \\|^\\)-+") |
|
362 ;; Elecric |
|
363 (setq-local electric-pair-pairs |
|
364 '((?` . ?`) (?\( . ?\)) (?{ . ?}) (?\" . ?\") (?\[ . ?\]))) |
|
365 ;; Nav |
|
366 (setq-local treesit-defun-name-function 'haskell-ts-defun-name) |
|
367 (setq-local treesit-defun-type-regexp |
|
368 ;; Since haskell is strict functional, any 2nd level |
|
369 ;; entity is defintion |
|
370 (cons ".+" |
|
371 (lambda (node) |
|
372 (and (not (string-match haskell-ts--ignore-types (treesit-node-type node))) |
|
373 (string= "declarations" (treesit-node-type (treesit-node-parent node))))))) |
|
374 (setq-local prettify-symbols-alist haskell-ts-prettify-symbols-alist) |
|
375 ;; Imenu |
|
376 (setq-local treesit-simple-imenu-settings |
|
377 `((nil haskell-ts-imenu-func-node-p nil |
|
378 ,(haskell-ts-imenu-name-function #'haskell-ts-imenu-func-node-p)) |
|
379 ("Signatures.." haskell-ts-imenu-sig-node-p nil |
|
380 ,(haskell-ts-imenu-name-function #'haskell-ts-imenu-sig-node-p)) |
|
381 ("Data..." haskell-ts-imenu-data-type-p nil |
|
382 (lambda (node) |
|
383 (treesit-node-text (treesit-node-child node 1)))))) |
|
384 ;; font-lock |
|
385 (setq-local treesit-font-lock-level haskell-ts-font-lock-level) |
|
386 (setq-local treesit-font-lock-settings haskell-ts-font-lock) |
|
387 (setq-local treesit-font-lock-feature-list |
|
388 haskell-ts-font-lock-feature-list) |
|
389 (treesit-major-mode-setup)) |
|
390 |
|
391 (defun haskell-ts--fontify-arg (node &optional _ _ _) |
|
392 (if (string= "variable" (treesit-node-type node)) |
|
393 (put-text-property |
|
394 (treesit-node-start node) |
|
395 (treesit-node-end node) |
|
396 'face font-lock-variable-name-face) |
|
397 (mapc 'haskell-ts--fontify-arg (treesit-node-children node)))) |
|
398 |
|
399 (defun haskell-ts--fontify-type (node &optional _ _ _) |
|
400 (let ((last-child (treesit-node-child node -1))) |
|
401 (if (string= (treesit-node-type last-child) "function") |
|
402 (haskell-ts--fontify-type last-child) |
|
403 (put-text-property |
|
404 (treesit-node-start last-child) |
|
405 (treesit-node-end last-child) |
|
406 'face font-lock-variable-name-face)))) |
|
407 |
|
408 (defun haskell-ts-imenu-node-p (regex node) |
|
409 (and (string-match-p regex (treesit-node-type node)) |
|
410 (string= (treesit-node-type (treesit-node-parent node)) "declarations"))) |
|
411 |
|
412 (defun haskell-ts-imenu-func-node-p (node) |
|
413 (haskell-ts-imenu-node-p "function\\|bind" node)) |
|
414 |
|
415 (defun haskell-ts-imenu-sig-node-p (node) |
|
416 (haskell-ts-imenu-node-p "signature" node)) |
|
417 |
|
418 (defun haskell-ts-imenu-data-type-p (node) |
|
419 (haskell-ts-imenu-node-p "data_type" node)) |
|
420 |
|
421 (defun haskell-ts-defun-name (node) |
|
422 (treesit-node-text (treesit-node-child node 0))) |
|
423 |
|
424 (defun haskell-ts-compile-region-and-go (start end) |
|
425 "Compile the text from START to END in the haskell proc." |
|
426 (interactive "r") |
|
427 (let ((hs (haskell-ts-haskell-session))) |
|
428 (comint-send-string hs ":{\n") |
|
429 (comint-send-region hs start end) |
|
430 (comint-send-string hs "\n:}\n"))) |
|
431 |
|
432 (defun haskell-ts-run-haskell() |
|
433 (interactive) |
|
434 (pop-to-buffer-same-window |
|
435 (if (comint-check-proc "*haskell*") |
|
436 "*haskell*" |
|
437 (make-comint "haskell" "ghci" nil buffer-file-name)))) |
|
438 |
|
439 (defun haskell-ts-haskell-session () |
|
440 (get-buffer-process "*haskell*")) |
|
441 |
|
442 (defvar eglot-server-programs) |
|
443 |
|
444 (defun haskell-ts-setup-eglot() |
|
445 (interactive) |
|
446 (add-to-list 'eglot-server-programs |
|
447 '(haskell-ts-mode . ("haskell-language-server-wrapper" "--lsp")))) |
|
448 |
|
449 (when (treesit-ready-p 'haskell) |
|
450 (add-to-list 'auto-mode-alist '("\\.hs\\'" . haskell-ts-mode))) |
|
451 |
|
452 (provide 'haskell-ts-mode) |
|
453 |
|
454 ;;; haskell-ts-mode.el ends here |