Re: Merge haskell-ts-mode in upstream

[Philip Kaludercic <philipk@posteo.net>]

Pranshu Sharma via "Emacs development discussions."
Pranshu Sharma via "Emacs development discussions."
<emacs-devel@gnu.org> writes:

> Hello emacskin,
>
> Around Augest, I asked for this first, but I still had do deal with the
> FSF bureaucracy, but now that is done (and I have made a lot of changes
> to the mode), I think it's ready.

Hi, I have added Yuan Fu as I assume he is the most knowledgeable about
the Tree-Sitter aspects of the code.

> I've attached a file.
>
> The repo is here: https://hg.bauherren.ovh/haskell-ts-mode/ , but I've
> attached the main file.

I see that you have started a new repository.  Do you want us to mirror
your changes with all the commit history, or are you OK with us just
copying over the coded periodically whenever you want to update the code?

It might also make sense to move your package from NonGNU ELPA to GNU
ELPA, but that is not strictly related to this.

I'll take the opportunity to re-comment the code:

> ;;; haskell-ts-mode.el --- A treesit based major mode for haskell -*- lexical-binding:t -*-
>
> ;; Copyright (C) 2024  Pranshu Sharma
>
>
> ;; Author: Pranshu Sharma <pranshusharma366 at gmail>
> ;; URL: https://codeberg.org/pranshu/haskell-ts-mode

Is this URL still accurate?

> ;; Package-Requires: ((emacs "29.3"))
> ;; Version: 1
> ;; Keywords: languages, haskell
>
> ;; 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 is a major mode that uses treesitter to provide all the basic
> ;; major mode stuff, like indentation, font lock, etc...

I am not clear about this aspect of -ts-modes, but wouldn't it make
sense to link to the grammar that you tested the major mode against?

> ;;; Code:
>
> (require 'comint)
> (require 'treesit)
>
> (declare-function treesit-parser-create "treesit.c")
> (declare-function treesit-node-start "treesit.c")
> (declare-function treesit-node-parent "treesit.c")
> (declare-function treesit-node-prev-sibling "treesit.c")
> (declare-function treesit-node-next-sibling "treesit.c")
> (declare-function treesit-node-end "treesit.c")
> (declare-function treesit-node-child "treesit.c")
> (declare-function treesit-node-type "treesit.c")
>
> (defgroup haskell-ts-mode nil
>   "Group that contains haskell-ts-mode variables"
>   :group 'langs)

There is no such group, you probably meant `languages'?

>
> (defvar haskell-ts-font-lock-feature-list
>   `((comment str pragma parens)
>     (type definition function args)
>     (match keyword)
>     (otherwise signature type-sig)))
>
> (defcustom haskell-ts-use-indent t
>   "Set to non-nil to use the indentation provided by haskell-ts-mode"
>   :group 'haskell-ts-mode

You can drop the :group declarations, they automatically fall back to
the last `defgroup'.

>   :type 'boolean)
>
> (defcustom haskell-ts-font-lock-level 4
>   "Level of font lock, 1 for minimum highlghting and 4 for maximum."
>   :group 'haskell-ts-mode
>   :type 'integer)

It might even make sense to use a choice here, as not all integer values
are valid.

> (defvar haskell-ts-prettify-symbols-alist

Would it make sense for this to be a defconst?

>   '(("\\" . "λ")
>     ("/=" . "≠")
>     ("->" . "→")
>     ("=>" . "⇒")
>     ("<-" . "←")
>     ("<=" . "≥")
>     (">=" . "≤")))
>
> (defvar haskell-ts-font-lock
>   (treesit-font-lock-rules
>    :language 'haskell
>    :feature 'keyword
>    `(["module" "import" "data" "let" "where" "case" "type"
>       "if" "then" "else" "of" "do" "in" "instance" "class"]
>      @font-lock-keyword-face)
>    :language 'haskell
>    :feature 'otherwise
>    :override t
>    `(((match (guards guard: (boolean (variable) @font-lock-keyword-face)))
>       (:match "otherwise" @font-lock-keyword-face)))
>    :language 'haskell
>    :feature 'type-sig
>    "(signature (binding_list (variable) @font-lock-doc-markup-face))
>     (signature (variable) @font-lock-doc-markup-face)"
>    :language 'haskell
>    :feature 'args
>    :override 'keep
>    (concat
>     "(function (infix left_operand: (_) @haskell-ts--fontify-arg))"
>     "(function (infix right_operand: (_) @haskell-ts--fontify-arg))"
>     "(generator . (_) @haskell-ts--fontify-arg)"
>     "(bind (as (variable) . (_) @haskell-ts--fontify-arg))"
>     "(patterns) @haskell-ts--fontify-arg")
>    :language 'haskell
>    :feature 'type
>    `((type) @font-lock-type-face
>      (constructor) @font-lock-type-face)
>    :language 'haskell
>    :override t
>    :feature 'signature
>    `((signature (function) @haskell-ts--fontify-type)
>      (context (function) @haskell-ts--fontify-type))
>    :language 'haskell
>    :feature 'match
>    `((match ("|" @font-lock-doc-face) ("=" @font-lock-doc-face))
>      (list_comprehension ("|" @font-lock-doc-face
> 			  (qualifiers (generator "<-" @font-lock-doc-face))))
>      (match ("->" @font-lock-doc-face)))
>    :language 'haskell
>    :feature 'comment
>    `(((comment) @font-lock-comment-face)
>      ((haddock) @font-lock-doc-face))
>    :language 'haskell
>    :feature 'pragma
>    `((pragma) @font-lock-preprocessor-face
>      (cpp) @font-lock-preprocessor-face)
>    :language 'haskell
>    :feature 'str
>    :override t
>    `((char) @font-lock-string-face
>      (string) @font-lock-string-face
>      (quasiquote (quoter) @font-lock-type-face)
>      (quasiquote (quasiquote_body) @font-lock-preprocessor-face))
>    :language 'haskell
>    :feature 'parens
>    :override t
>    `(["(" ")" "[" "]"] @font-lock-operator-face
>      (infix operator: (_) @font-lock-operator-face))
>    :language 'haskell
>    :feature 'function
>    :override t
>    `((function name: (variable) @font-lock-function-name-face)
>      (function (infix (operator)  @font-lock-function-name-face))
>      (declarations (type_synomym (name) @font-lock-function-name-face))
>      (bind (variable) @font-lock-function-name-face)
>      (function (infix (infix_id (variable) @font-lock-function-name-face)))
>      (bind (as (variable) @font-lock-function-name-face))))
>   "The treesitter font lock settings for haskell.")
>
> (defun haskell-ts--stand-alone-parent (_ parent bol)
>   (save-excursion
>     (goto-char (treesit-node-start parent))
>     (let ((type (treesit-node-type parent)))
>       (if (and (not bol)
> 	       (or (looking-back "^[ \t]*" (line-beginning-position))
> 		   (seq-some
> 		    (lambda (kw) 
> 		      (string= type kw))
> 		    '("when" "where" "do" "let" "local_binds" "function"))))

Why are you using `seq-some' and not a faster primitive like `member'?
In this context, the behaviour should be the same, unless you are
expecting that `type' can be something else than a string?

> 	  (treesit-node-start parent)
> 	(haskell-ts--stand-alone-parent 1 (funcall
> 					   (if bol 'treesit-node-parent 'identity)
> 					   (treesit-node-parent parent))
> 					nil)))))
>
> (defvar haskell-ts--ignore-types
>   (regexp-opt '("comment" "cpp" "haddock"))
>   "Node types that will be ignored by indentation.")
>
> (defvar haskell-ts-indent-rules
>   (let* ((p-sib
> 	  (lambda (node arg)
> 	    (let* ((func (if arg
> 			     'treesit-node-prev-sibling
> 			   'treesit-node-next-sibling))

You probably want to sharp-quote these.

> 		   (n (funcall func	 node)))
                                   ^
                                   is the tab here intentional?

> 	      (while (and n (string-match haskell-ts--ignore-types
> 					  (treesit-node-type n)))
> 		(setq n (funcall func n)))
> 	      n)))
> 	 (p-prev-sib
> 	  (lambda (node _ _) (treesit-node-start (funcall p-sib node t))))
> 	 (p-n-prev (lambda (node) (funcall p-sib node t)))
> 	 (parent-first-child (lambda (_ parent _)
> 			       (treesit-node-start (treesit-node-child parent 0)))))
>     `((haskell
>        ((node-is "^cpp$") column-0 0)
>        ((parent-is "^comment$") column-0 0)
>        ((parent-is "^haddock$") column-0 0)
>        ((parent-is "^imports$") column-0 0)
>        ;; Infix
>        ((n-p-gp nil "infix" "infix")
> 	(lambda (_ node _)
> 	  (let ((first-inf nil))
> 	    (while (string= "infix"
> 			    (treesit-node-type
> 			     (setq node (treesit-node-parent node))))
> 	      (setq first-inf node))
> 	    (funcall ,parent-first-child nil first-inf nil)))
> 	0)
>        ((node-is "^infix$") ,parent-first-child 0)
>        
>        ;; Lambda
>        ((parent-is "^lambda\\(_case\\)?$") standalone-parent 2)
>
>        ((parent-is "^class_declarations$") prev-sibling 0)
>
>        ((node-is "^where$") parent 2)
>        
>        ;; in
>        ((node-is "^in$") parent 0)
>        
>        ((parent-is "qualifiers") parent 0)
>        
>        ;; list
>        ((node-is "^]$") parent 0)
>        ((parent-is "^list$") standalone-parent 2)
>        
>        ;; If then else
>        ((node-is "^then$") parent 2)
>        ((node-is "^else$") parent 2)
>
>        ((parent-is "^apply$") haskell-ts--stand-alone-parent 1)
>        ((node-is "^quasiquote$") grand-parent 2)
>        ((parent-is "^quasiquote_body$") (lambda (_ _ c) c) 0)
>        ((lambda (node parent bol)
> 	  (when-let ((n (treesit-node-prev-sibling node)))
> 	    (while (string= "comment" (treesit-node-type n))
> 	      (setq n (treesit-node-prev-sibling n)))
> 	    (string= "do" (treesit-node-type n))))
> 	haskell-ts--stand-alone-parent
> 	3)
>        ((parent-is "^do$") ,p-prev-sib 0)
>
>        ((parent-is "^alternatives$") ,p-prev-sib 0)
>
>        ;; prev-adaptive-prefix is broken sometimes
>        (no-node
> 	(lambda (_ _ _)
> 	  (save-excursion
> 	    (goto-char (line-beginning-position 0))
> 	    (back-to-indentation)
> 	    (point)))
> 	0)
>        
>        ((parent-is "^data_constructors$") parent 0)
>
>        ;; where
>        ((lambda (node _ _)
> 	  (let ((n (treesit-node-prev-sibling node)))
> 	    (while (string= "comment" (treesit-node-type n))
> 	      (setq n (treesit-node-prev-sibling n)))
> 	    (string= "where" (treesit-node-type n))))
> 	
> 	(lambda (_ b _)
> 	  (+ 1 (treesit-node-start (treesit-node-prev-sibling b))))
> 	3)
>        ((parent-is "local_binds\\|instance_declarations") ,p-prev-sib 0)
>        
>        ;; Match
>        ((lambda (node _ _)
> 	  (and (string= "match" (treesit-node-type node))
> 	       (string-match (regexp-opt '("patterns" "variable"))
> 			     (treesit-node-type (funcall ,p-n-prev node)))))
> 	standalone-parent 2)
>        
>        ((node-is "match") ,p-prev-sib 0)
>        ((parent-is "match") standalone-parent 2)
>        
>        ((parent-is "^haskell$") column-0 0)
>        ((parent-is "^declarations$") column-0 0)
>        
>        ((parent-is "^record$") standalone-parent 2)
>
>        ((parent-is "^exports$")
> 	(lambda (_ b _) (treesit-node-start (treesit-node-prev-sibling b)))
> 	0)
>        ((n-p-gp nil "signature" "foreign_import") grand-parent 3)
>        ((parent-is "^case$") standalone-parent 4)
>        ((node-is "^alternatives$")
> 	(lambda (_ b _)
> 	  (treesit-node-start (treesit-node-child b 0)))
> 	2)
>        ((node-is "^comment$")
> 	;; Indenting comments by priorites:
> 	;; 1. next relevent sibling if exists
> 	;; 2. previous relevent sibling if exists
> 	;; 3. parent
> 	;; (relevent means type not it haskell-ts--ignore-types)
> 	(lambda (node parent _)
> 	  (if-let ((next-sib (funcall ,p-sib node nil)))
> 	      (treesit-node-start next-sib)
> 	    (if-let ((prev-sib (funcall ,p-prev-sib node nil nil)))
> 		prev-sib
> 	      (treesit-node-start parent))))

It might be fun to rewrite this using pcase...

> 	0)
>        ;; Backup
>        (catch-all parent 2)))))
>
> ;; Copied from haskell-tng-mode, changed a bit
>
> (defvar haskell-ts-mode-syntax-table
>       (let ((table (make-syntax-table)))
> 	;; The defaults are mostly fine
> 	(mapc
> 	 (lambda (ls)
> 	   (mapc
> 	    (lambda (char)
> 	      (modify-syntax-entry char (car ls) table))
> 	    (cdr ls)))
> 	 '(("_" ?! ?_)
> 	   ("w" ?')
> 	   ;; Haskell has some goofy comment enders like C-q C-l
> 	   (">" 13 10 12 11)
> 	   ("_ 123" ?-)
> 	   ("(}1nb" ?\{)
> 	   ("){4nb" ?\})
> 	   ("<" ?#)
> 	   (">" ?\n)
> 	   ;; Special operaters
> 	   ("." ?\, ?\; ?@)
> 	   ("\"" ?\")
> 	   ("$`"  ?\`)))
> 	table))

Consider wrapping this in a `eval-when-compile' and perhaps re-writing
it with `dolist'.

> (defmacro haskell-ts-imenu-name-function (check-func)
>   `(lambda (node)
>      (let ((nn (treesit-node-child node 0 node)))
> 	 (if (funcall ,check-func node)
> 	 (if (string= (treesit-node-type nn) "infix")
> 	     (treesit-node-text (treesit-node-child nn 1))
> 	     (haskell-ts-defun-name node))
>        nil))))

You should clean up the indentation, you seem to have tabs in the code
made the code intended in a harder to read way on my machine.
>
> (defun haskell-ts-indent-defun (pos)
>   "Indent the current function."
>   (interactive "d")
>   (let ((node (treesit-node-at pos)))
>     (while (not (string-match
> 		 "^declarations$\\|haskell"
> 		 (treesit-node-type (treesit-node-parent node))))
>       (setq node (treesit-node-parent node)))
>     (indent-region (treesit-node-start node) (treesit-node-end node))))

Why is this function necessary, if we already have the general commands
for indenting a defun?  If it is, it should probably be explained in the
docstring.

> (defvar haskell-ts-mode-map
>   (define-keymap
>     "C-c C-c" 'haskell-ts-compile-region-and-go
>     "C-c C-r" 'haskell-ts-run-haskell
>     "C-M-q" 'haskell-ts-indent-defun)
>   "Map for haskell-ts-mode.")

I am guessing this should be a `defvar-keymap'.

>
> ;;;###autoload
> (define-derived-mode haskell-ts-mode prog-mode "haskell ts mode"
>   "Major mode for Haskell files using tree-sitter."
>   (unless (treesit-ready-p 'haskell)
>     (error "Tree-sitter for Haskell is not available"))
>   (treesit-parser-create 'haskell)
>   (setq-local treesit-defun-type-regexp "\\(?:\\(?:function\\|struct\\)_definition\\)")
>   ;; Indent
>   (when haskell-ts-use-indent
>     (setq-local treesit-simple-indent-rules haskell-ts-indent-rules)
>     (setq-local indent-tabs-mode nil))
>   ;; Comment
>   (setq-local comment-start "-- ")
>   (setq-local comment-use-syntax t)
>   (setq-local comment-start-skip "\\(?: \\|^\\)-+")
>   ;; Electric
>   (setq-local electric-pair-pairs
> 	      '((?` . ?`) (?\( . ?\)) (?{ . ?}) (?\" . ?\") (?\[ . ?\])))
>   ;; Navigation
>   (setq-local treesit-defun-name-function 'haskell-ts-defun-name)
>   (setq-local treesit-defun-type-regexp
> 	      ;; Since haskell is strict functional, any 2nd level
> 	      ;; entity is defintion
> 	      (cons ".+"
> 		    (lambda (node)
> 		      (and (not (string-match haskell-ts--ignore-types (treesit-node-type node)))
> 			   (string= "declarations" (treesit-node-type (treesit-node-parent node)))))))
>   (setq-local prettify-symbols-alist haskell-ts-prettify-symbols-alist)
>   ;; Imenu
>   (setq-local treesit-simple-imenu-settings
> 	      `((nil haskell-ts-imenu-func-node-p nil
> 		     ,(haskell-ts-imenu-name-function #'haskell-ts-imenu-func-node-p))
> 		("Signatures.." haskell-ts-imenu-sig-node-p nil
> 		 ,(haskell-ts-imenu-name-function #'haskell-ts-imenu-sig-node-p))
> 		("Data..." haskell-ts-imenu-data-type-p nil
> 		 (lambda (node)
> 		   (treesit-node-text (treesit-node-child node 1))))))
>   ;; font-lock
>   (setq-local treesit-font-lock-level haskell-ts-font-lock-level)
>   (setq-local treesit-font-lock-settings haskell-ts-font-lock)
>   (setq-local treesit-font-lock-feature-list
> 	      haskell-ts-font-lock-feature-list)
>   (treesit-major-mode-setup))
>
> (defun haskell-ts--fontify-arg (node &optional _ _ _)
>   (if (string= "variable" (treesit-node-type node))
>       (put-text-property
>        (treesit-node-start node)
>        (treesit-node-end node)
>        'face font-lock-variable-name-face)
>     (mapc 'haskell-ts--fontify-arg (treesit-node-children node))))
>
> (defun haskell-ts--fontify-type (node &optional _ _ _)
>   (let ((last-child (treesit-node-child node -1)))
>     (if (string= (treesit-node-type last-child) "function")
> 	(haskell-ts--fontify-type last-child)
>       (put-text-property
>        (treesit-node-start last-child)
>        (treesit-node-end last-child)
>        'face font-lock-variable-name-face))))
>
> (defun haskell-ts-imenu-node-p (regex node)
>   (and (string-match-p regex (treesit-node-type node))
>        (string= (treesit-node-type (treesit-node-parent node)) "declarations")))
>
> (defun haskell-ts-imenu-func-node-p (node)
>   (haskell-ts-imenu-node-p "function\\|bind" node))
>
> (defun haskell-ts-imenu-sig-node-p (node)
>   (haskell-ts-imenu-node-p "signature" node))
>
> (defun haskell-ts-imenu-data-type-p (node)
>   (haskell-ts-imenu-node-p "data_type" node))
>
> (defun haskell-ts-defun-name (node)
>   (treesit-node-text (treesit-node-child node 0)))
>
> (defun haskell-ts-compile-region-and-go (start end)
>   "Compile the text from START to END in the haskell proc."
>   (interactive "r")
>   (let ((hs (haskell-ts-haskell-session)))
>     (comint-send-string hs ":{\n")
>     (comint-send-region hs start end)

You should probably do something to ensure that the interval doesn't
contain ":}"?  I assume that this is something ghci specific, right?

>     (comint-send-string hs "\n:}\n")))
>
> (defun haskell-ts-run-haskell()
>   (interactive)
>   (pop-to-buffer-same-window
>    (if (comint-check-proc "*haskell*")
>        "*haskell*"
>      (make-comint "haskell" "ghci" nil buffer-file-name))))

1. Would it make sense to have a user option that allows customising
   this, in case someone uses Cabal, Stack or whatever else?

2. The regular haskell-mode has a `run-haskell' command that creates the
   same buffer name.  Assuming that it is not that unusual for people to
   have both installed, when trying out the one or the other, shouldn't
   you take some precaution to detect that scenario?

> (defun haskell-ts-haskell-session ()
>   (get-buffer-process "*haskell*"))
>
> (when (treesit-ready-p 'haskell)
>   (add-to-list 'auto-mode-alist '("\\.hs\\'" . haskell-ts-mode)))
>
> (provide 'haskell-ts-mode)
>
> ;;; haskell-ts-mode.el ends here