haskell-ts-mode.el
changeset 0 4d355b59e2a3
child 1 27f2627e9f2f
equal deleted inserted replaced
-1:000000000000 0:4d355b59e2a3
       
     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