Upstream haskell-ts-mode?

Upstream haskell-ts-mode?

[pranshu sharma]

With tree-sitter, I was able to make a major mode that provided
indentation, font lock and navigation.  Over the last month, I've been
working on it and I can finally say it is fully ready.  I tested the
indent on large haskell programs, such as darcs and ghc, and it was
good, and it did not change the output (since indent matters in haskell
execution).

I'm willing to upstream this to master, as it would be good if emacs had
an inbuilt major mode for haskell. 

Re: Upstream haskell-ts-mode?

[Andrea Corallo]

pranshu sharma <pranshusharma366@gmail.com> writes:

> With tree-sitter, I was able to make a major mode that provided
> indentation, font lock and navigation.  Over the last month, I've been
> working on it and I can finally say it is fully ready.  I tested the
> indent on large haskell programs, such as darcs and ghc, and it was
> good, and it did not change the output (since indent matters in haskell
> execution).
>
> I'm willing to upstream this to master, as it would be good if emacs had
> an inbuilt major mode for haskell. 

Hello pranshu,

I'm in principle okay with having an haskell mode into core in case it's
ready (of course let's hear what other maintainers think about this).
You'll have to submit a patch with that for code review.

Anyway a requirement for upstreaming into Emacs core (and GNU ELPA as
well) is to assign the copyright to FSF, would you be willing to do the
FSF copyright paperwork?  Let me know, in case I'll send you a mail.

Thanks

  Andrea

Re: Upstream haskell-ts-mode?

[Stefan Kangas]

Andrea Corallo <acorallo@gnu.org> writes:

> I'm in principle okay with having an haskell mode into core in case it's
> ready (of course let's hear what other maintainers think about this).

I think it'd be useful to have a mode for Haskell built-in.

Re: Upstream haskell-ts-mode?

[pranshu sharma]

[-- Attachment #1: Type: text/plain, Size: 71 bytes --]


Hello Andrea,

I am willing to do the FSF copyright paperwork.

Code:

[-- Attachment #2: haskell-ts-mode.patch --]
[-- Type: text/x-diff, Size: 17096 bytes --]

diff --git a/lisp/progmodes/haskell-ts-mode.el b/lisp/progmodes/haskell-ts-mode.el
new file mode 100644
index 00000000000..fae70f2a571
--- /dev/null
+++ b/lisp/progmodes/haskell-ts-mode.el
@@ -0,0 +1,461 @@
+;;; 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
+;; 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...
+
+;;; 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)
+
+(defcustom haskell-ts-highlight-signature t
+  "Set to non-nil to enable highlighting of signature names."
+  :type 'boolean
+  :group 'haskell-ts-mode)
+
+(defvar haskell-ts-font-lock-feature-list
+  `(,(funcall
+      (if haskell-ts-highlight-signature
+	  (lambda (ls) (append ls '(type-sig)))
+	'identity)
+      '(comment str pragma parens))
+    (type definition function args)
+    (match keyword)
+    (otherwise signature)))
+
+(defcustom haskell-ts-use-indent t
+  "Set to non-nil to use the indentation provided by haskell-ts-mode"
+  :group 'haskell-ts-mode
+  :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)
+
+(defvar haskell-ts-prettify-symbols-alist
+  '(("\\" . "λ")
+    ("/=" . "≠")
+    ("->" . "→")
+    ("=>" . "⇒")
+    ("<-" . "←")
+    ("<=" . "≥")
+    (">=" . "≤")))
+
+(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))))
+  "A function that returns the treesit font lock 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 (looking-back "^[ \t]*" (line-beginning-position))
+		 (not (seq-some
+		       (lambda (kw) 
+			 (string= type kw))
+		       '("when" "where" "do" "let"))))
+	(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
+  '("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))
+		 (n (funcall func	 node)))
+	     (while (and n (string-match (regexp-opt 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
+       ((parent-is "infix") ,parent-first-child 0)
+       ((node-is "infix") standalone-parent 1)
+       ;; Lambda
+       ((parent-is "lambda") standalone-parent 2)
+
+       ((parent-is "class_declarations") prev-sibling 0)
+       
+       ;; in
+       ((node-is "^in$") 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)
+       ((node-is "^where$") parent 2)
+	
+       ;; Match
+       ((lambda (node _ _)
+	  (and (string= "match" (treesit-node-type node))
+	       (string= "variable" (treesit-node-type (funcall ,p-n-prev node))) ))
+	,parent-first-child 1)
+       ((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))))
+	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)))
+    (map-char-table
+     (lambda (k v)
+       ;; reset the (surprisingly numerous) defaults
+       (let ((class (syntax-class v)))
+         (when (seq-contains-p '(1 4 5 6 9) class)
+           (modify-syntax-entry k "_" table))))
+     (char-table-parent table))
+    ;; whitechar
+    (mapc
+     (lambda (it) (modify-syntax-entry it " " table))
+     (string-to-list "\r\n\f\v \t"))
+    ;; ascSymbol
+    (mapc
+     (lambda (it) (modify-syntax-entry it "_" table))
+     (string-to-list "!#$%&*+./<=>?\\^|-~:"))
+    (modify-syntax-entry ?_ "_" table)
+    ;; some special (treated like punctuation)
+    (mapc
+     (lambda (it) (modify-syntax-entry it "." table))
+     (string-to-list ",;@"))
+    ;; apostrophe as a word, not delimiter
+    (modify-syntax-entry ?\' "w" table)
+    ;; string delimiter
+    (modify-syntax-entry ?\" "\"" table)
+    ;; parens and pairs (infix functions)
+    (modify-syntax-entry ?\( "()" table)
+    (modify-syntax-entry ?\) ")(" table)
+    (modify-syntax-entry ?\[ "(]" table)
+    (modify-syntax-entry ?\] ")[" table)
+    (modify-syntax-entry ?\` "$`" table)
+
+    ;; comments (subsuming pragmas)
+    (modify-syntax-entry ?\{  "(}1nb" table)
+    (modify-syntax-entry ?\}  "){4nb" table)
+    (modify-syntax-entry ?-  "_ 123" table)
+    (mapc
+     (lambda (it) (modify-syntax-entry it ">" table))
+     (string-to-list "\r\n\f\v"))
+    table))
+
+(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))))
+
+(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))))
+
+(defvar haskell-ts-mode-map
+  (let ((km (make-sparse-keymap)))
+    (define-key km (kbd "C-c C-c") 'haskell-ts-compile-region-and-go)
+    (define-key km (kbd "C-c C-r") 'haskell-ts-run-haskell)
+    (define-key km (kbd "C-M-q") 'haskell-ts-indent-defun) ; For those who don't have emacs 30
+    km)
+  "Map for haskell-ts-mode.")
+
+;;;###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 "\\(?: \\|^\\)-+")
+  ;; Elecric
+  (setq-local electric-pair-pairs
+	      '((?` . ?`) (?\( . ?\)) (?{ . ?}) (?\" . ?\") (?\[ . ?\])))
+  ;; Nav
+  (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)
+		      (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-region hs start end)
+    (comint-send-string hs "\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))))
+
+(defun haskell-ts-haskell-session ()
+  (get-buffer-process "*haskell*"))
+
+(defvar eglot-server-programs)
+
+(defun haskell-ts-setup-eglot()
+  (add-to-list 'eglot-server-programs
+	       '(haskell-ts-mode . ("haskell-language-server-wrapper" "--lsp"))))
+
+(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

Re: Upstream haskell-ts-mode?

[Andrea Corallo]

pranshu sharma <pranshusharma366@gmail.com> writes:

> Hello Andrea,
>
> I am willing to do the FSF copyright paperwork.

Mail sent off-list.

Thanks

  Andrea