From fe84f62ea68c919bf321ba7b57b059d8d4b2bcd3 Mon Sep 17 00:00:00 2001 From: Troy Brown Date: Sun, 24 Mar 2024 17:39:18 -0400 Subject: [PATCH] Add additional categories for Imenu. Added protected, task, with clauses and type declaration categories. Also added user options to customize the set of categories as well as the names of the categories. --- README.org | 19 ++- ada-ts-mode.el | 192 ++++++++++++++++++++--- doc/ada-ts-mode.texi | 21 ++- test/resources/imenu-categories.erts | 173 ++++++++++++++++++++ test/resources/imenu-category-names.erts | 33 ++++ test/resources/imenu.erts | 83 ++++++++++ 6 files changed, 495 insertions(+), 26 deletions(-) create mode 100644 test/resources/imenu-categories.erts create mode 100644 test/resources/imenu-category-names.erts diff --git a/README.org b/README.org index 31e4381..4677998 100644 --- a/README.org +++ b/README.org @@ -172,7 +172,24 @@ enabled. With the provided Imenu support, additional options are available for ease of navigation within an Ada source file. Imenu supports indexing -of packages and subprograms (declarations, bodies and stubs). +of declarations, bodies and stubs for packages, subprograms, task +units and protected units as well as type declarations and with +clauses. + +- User Option: ada-ts-mode-imenu-categories :: + The set of categories to be used for Imenu. Since there are a + number of different categories supported, it may be a distraction to + display categories that aren't desired. Therefore, the set of + categories can be customized to reduce clutter or to increase + performance. The order in which the categories are listed will be + respected when the Imenu indexing is performed. This is helpful if + specific ordering of categories is desired. + +- User Option: ada-ts-mode-imenu-category-name-alist :: + The mapping between categories and the displayed name for the + category. This customization may be helpful if you are expecting a + specific name for a category, use plural instead of singular nouns, + or want to customize for internationalization. - User Option: ada-ts-mode-imenu-nesting-strategy-function :: Function to use for constructing nested items within the Imenu data diff --git a/ada-ts-mode.el b/ada-ts-mode.el index e0b58b7..64d5e63 100644 --- a/ada-ts-mode.el +++ b/ada-ts-mode.el @@ -4,7 +4,7 @@ ;; Author: Troy Brown ;; Created: February 2023 -;; Version: 0.5.8 +;; Version: 0.6.0 ;; Keywords: ada languages tree-sitter ;; URL: https://github.com/brownts/ada-ts-mode ;; Package-Requires: ((emacs "29.1")) @@ -77,6 +77,39 @@ specified. See `treesit-language-source-alist' for full details." :link '(custom-manual :tag "Grammar Installation" "(ada-ts-mode)Grammar Installation") :package-version "0.5.0") +(defcustom ada-ts-mode-imenu-categories + '(package + subprogram + protected + task + type-declaration + with-clause) + "Configuration of Imenu categories." + :type '(repeat :tag "Categories" + (choice :tag "Category" + (const :tag "Package" package) + (const :tag "Subprogram" subprogram) + (const :tag "Protected" protected) + (const :tag "Task" task) + (const :tag "Type Declaration" type-declaration) + (const :tag "With Clause" with-clause))) + :group 'ada-ts + :link '(custom-manual :tag "Imenu" "(ada-ts-mode)Imenu") + :package-version "0.6.0") + +(defcustom ada-ts-mode-imenu-category-name-alist + '((package . "Package") + (subprogram . "Subprogram") + (protected . "Protected") + (task . "Task") + (type-declaration . "Type Declaration") + (with-clause . "With Clause")) + "Configuration of Imenu category names." + :type '(alist :key-type symbol :value-type string) + :group 'ada-ts + :link '(custom-manual :tag "Imenu" "(ada-ts-mode)Imenu") + :package-version "0.6.0") + (defcustom ada-ts-mode-imenu-nesting-strategy-function #'ada-ts-mode-imenu-nesting-strategy-before "Configuration for Imenu nesting strategy function." @@ -121,14 +154,13 @@ specified. See `treesit-language-source-alist' for full details." (defun ada-ts-mode--syntax-propertize (beg end) "Apply syntax text property to character literals between BEG and END. -This is necessary to suppress interpreting syntactic meaning from -a chararacter literal (e.g., double-quote character incorrectly -interpreted as the beginning or end of a string). The -single-quote character is not defined in the syntax table as a -string since it is also used with attributes. Thus, it is -defined in the syntax table as punctuation and we identify -character literal instances here and apply the string property to -those instances." +This is necessary to suppress interpreting syntactic meaning from a +chararacter literal (e.g., double-quote character incorrectly +interpreted as the beginning or end of a string). The single-quote +character is not defined in the syntax table as a string since it is +also used with attributes. Thus, it is defined in the syntax table as +punctuation and we identify character literal instances here and apply +the string property to those instances." (goto-char beg) (while (re-search-forward (rx "'" anychar "'") end t) (pcase (treesit-node-type @@ -555,6 +587,15 @@ Return nil if there is no name or if NODE is not a defun node." ("subunit" (treesit-node-child-by-field-name node "parent_unit_name"))))) +(defun ada-ts-mode--type-declaration-name (node) + "Return the type declaration name of NODE." + (ada-ts-mode--node-to-name + (car (treesit-filter-child + node + (lambda (n) + (string-equal (treesit-node-type n) + "identifier")))))) + (defun ada-ts-mode--package-p (node) "Determine if NODE is a package declaration, body or stub. Return non-nil to indicate that it is." @@ -599,6 +640,50 @@ Return non-nil to indicate that it is." "subprogram_renaming_declaration") t))) +(defun ada-ts-mode--protected-p (node) + "Determine if NODE is a protected declaration, body, body stub or type." + (pcase (treesit-node-type node) + ((or "protected_body" + "protected_body_stub" + "protected_type_declaration" + "single_protected_declaration") + t))) + +(defun ada-ts-mode--task-p (node) + "Determine if NODE is a task declaration, body, body stub type." + (pcase (treesit-node-type node) + ((or "single_task_declaration" + "task_body" + "task_body_stub" + "task_type_declaration") + t))) + +(defun ada-ts-mode--type-declaration-p (node) + "Determine if NODE is a type declaration." + (pcase (treesit-node-type node) + ((or "formal_complete_type_declaration" + "formal_incomplete_type_declaration" + "incomplete_type_declaration" + "private_extension_declaration" + "private_type_declaration" + "protected_type_declaration" + "task_type_declaration" + "subtype_declaration") + t) + ("full_type_declaration" + (let ((child (treesit-node-type (treesit-node-child node 0)))) + (and (not (string-equal child "task_type_declaration")) + (not (string-equal child "protected_type_declaration"))))))) + +(defun ada-ts-mode--with-clause-name-p (node) + "Determine if NODE is a library unit name within a with clause." + (and (string-equal (treesit-node-type (treesit-node-parent node)) + "with_clause") + (pcase (treesit-node-type node) + ((or "identifier" + "selected_component") + t)))) + (defun ada-ts-mode--defun-p (node) "Determine if NODE is candidate for defun." (let ((type (treesit-node-type node))) @@ -680,21 +765,80 @@ the name of the branch given the branch node." (defun ada-ts-mode--imenu () "Return Imenu alist for the current buffer." (let* ((root (treesit-buffer-root-node)) - (tree (treesit-induce-sparse-tree root #'ada-ts-mode--defun-p)) - (index-package (ada-ts-mode--imenu-index tree - #'ada-ts-mode--package-p - #'ada-ts-mode--defun-p - #'ada-ts-mode--defun-name - #'ada-ts-mode--defun-name)) - (index-subprogram (ada-ts-mode--imenu-index tree - #'ada-ts-mode--subprogram-p - #'ada-ts-mode--defun-p - #'ada-ts-mode--defun-name - #'ada-ts-mode--defun-name))) - (seq-filter (lambda (i) (cdr i)) - (list - (cons "Package" index-package) - (cons "Subprogram" index-subprogram))))) + (defun-tree + (and (seq-intersection '(package subprogram protected task) + ada-ts-mode-imenu-categories) + (treesit-induce-sparse-tree root #'ada-ts-mode--defun-p))) + (index-package + (and (memq 'package ada-ts-mode-imenu-categories) + (ada-ts-mode--imenu-index defun-tree + #'ada-ts-mode--package-p + #'ada-ts-mode--defun-p + #'ada-ts-mode--defun-name + #'ada-ts-mode--defun-name))) + (index-subprogram + (and (memq 'subprogram ada-ts-mode-imenu-categories) + (ada-ts-mode--imenu-index defun-tree + #'ada-ts-mode--subprogram-p + #'ada-ts-mode--defun-p + #'ada-ts-mode--defun-name + #'ada-ts-mode--defun-name))) + (index-protected + (and (memq 'protected ada-ts-mode-imenu-categories) + (ada-ts-mode--imenu-index defun-tree + #'ada-ts-mode--protected-p + #'ada-ts-mode--defun-p + #'ada-ts-mode--defun-name + #'ada-ts-mode--defun-name))) + (index-task + (and (memq 'task ada-ts-mode-imenu-categories) + (ada-ts-mode--imenu-index defun-tree + #'ada-ts-mode--task-p + #'ada-ts-mode--defun-p + #'ada-ts-mode--defun-name + #'ada-ts-mode--defun-name))) + (index-type-declaration + (and (memq 'type-declaration ada-ts-mode-imenu-categories) + (ada-ts-mode--imenu-index + (treesit-induce-sparse-tree + root + (lambda (node) + (or (ada-ts-mode--defun-p node) + (ada-ts-mode--type-declaration-p node)))) + #'ada-ts-mode--type-declaration-p + #'ada-ts-mode--defun-p + #'ada-ts-mode--type-declaration-name + #'ada-ts-mode--defun-name))) + (index-with-clause + (and (memq 'with-clause ada-ts-mode-imenu-categories) + (ada-ts-mode--imenu-index + (treesit-induce-sparse-tree + root + #'ada-ts-mode--with-clause-name-p + nil + 3) ; Limit search depth for speed + #'identity + #'ignore + #'ada-ts-mode--node-to-name + #'ignore))) + (imenu-alist + ;; Respect category ordering in `ada-ts-mode-imenu-categories' + (mapcar (lambda (category) + (let ((name (alist-get category + ada-ts-mode-imenu-category-name-alist)) + (index (pcase category + ('package index-package) + ('subprogram index-subprogram) + ('protected index-protected) + ('task index-task) + ('type-declaration index-type-declaration) + ('with-clause index-with-clause) + (_ (error "Unknown cateogry: %s" category))))) + (cons name index))) + ada-ts-mode-imenu-categories))) + + ;; Remove empty categories + (seq-filter (lambda (i) (cdr i)) imenu-alist))) ;;;###autoload (define-derived-mode ada-ts-mode prog-mode "Ada" diff --git a/doc/ada-ts-mode.texi b/doc/ada-ts-mode.texi index 68cf742..a88173c 100644 --- a/doc/ada-ts-mode.texi +++ b/doc/ada-ts-mode.texi @@ -245,7 +245,26 @@ enabled. With the provided Imenu support, additional options are available for ease of navigation within an Ada source file. Imenu supports indexing -of packages and subprograms (declarations, bodies and stubs). +of declarations, bodies and stubs for packages, subprograms, task +units and protected units as well as type declarations and with +clauses. + +@defopt ada-ts-mode-imenu-categories +The set of categories to be used for Imenu. Since there are a +number of different categories supported, it may be a distraction to +display categories that aren't desired. Therefore, the set of +categories can be customized to reduce clutter or to increase +performance. The order in which the categories are listed will be +respected when the Imenu indexing is performed. This is helpful if +specific ordering of categories is desired. +@end defopt + +@defopt ada-ts-mode-imenu-category-name-alist +The mapping between categories and the displayed name for the +category. This customization may be helpful if you are expecting a +specific name for a category, use plural instead of singular nouns, +or want to customize for internationalization. +@end defopt @defopt ada-ts-mode-imenu-nesting-strategy-function Function to use for constructing nested items within the Imenu data diff --git a/test/resources/imenu-categories.erts b/test/resources/imenu-categories.erts new file mode 100644 index 0000000..9ac9139 --- /dev/null +++ b/test/resources/imenu-categories.erts @@ -0,0 +1,173 @@ +Code: (lambda () (imenu-transform + '(("Subprogram" ("Test" ("Subprogram_Declaration"))) + ("Protected" ("Test" ("Single_Protected_Declaration"))) + ("Task" ("Test" ("Single_Task_Declaration"))) + ("Type Declaration" ("Test" ("Full_Type_Declaration"))) + ("With Clause" ("Ada.Text_IO"))) + (lambda () (setq-local ada-ts-mode-imenu-categories + (seq-filter (lambda (category) (not (eq category 'package))) + ada-ts-mode-imenu-categories))))) + +Name: Without "package" category + +=-= +with Ada.Text_IO; + +package body Test is + + type Full_Type_Declaration is new Integer range 0 .. 255; + + procedure Subprogram_Declaration; + + task Single_Task_Declaration; + + protected Single_Protected_Declaration is + end Single_Protected_Declaration; + +end Test; +=-=-= + +Code: (lambda () (imenu-transform + '(("Package" ("Test")) + ("Protected" ("Test" ("Single_Protected_Declaration"))) + ("Task" ("Test" ("Single_Task_Declaration"))) + ("Type Declaration" ("Test" ("Full_Type_Declaration"))) + ("With Clause" ("Ada.Text_IO"))) + (lambda () (setq-local ada-ts-mode-imenu-categories + (seq-filter (lambda (category) (not (eq category 'subprogram))) + ada-ts-mode-imenu-categories))))) + +Name: Without "subprogram" category + +=-= +with Ada.Text_IO; + +package body Test is + + type Full_Type_Declaration is new Integer range 0 .. 255; + + procedure Subprogram_Declaration; + + task Single_Task_Declaration; + + protected Single_Protected_Declaration is + end Single_Protected_Declaration; + +end Test; +=-=-= + +Code: (lambda () (imenu-transform + '(("Package" ("Test")) + ("Subprogram" ("Test" ("Subprogram_Declaration"))) + ("Task" ("Test" ("Single_Task_Declaration"))) + ("Type Declaration" ("Test" ("Full_Type_Declaration"))) + ("With Clause" ("Ada.Text_IO"))) + (lambda () (setq-local ada-ts-mode-imenu-categories + (seq-filter (lambda (category) (not (eq category 'protected))) + ada-ts-mode-imenu-categories))))) + +Name: Without "protected" category + +=-= +with Ada.Text_IO; + +package body Test is + + type Full_Type_Declaration is new Integer range 0 .. 255; + + procedure Subprogram_Declaration; + + task Single_Task_Declaration; + + protected Single_Protected_Declaration is + end Single_Protected_Declaration; + +end Test; +=-=-= + +Code: (lambda () (imenu-transform + '(("Package" ("Test")) + ("Subprogram" ("Test" ("Subprogram_Declaration"))) + ("Protected" ("Test" ("Single_Protected_Declaration"))) + ("Type Declaration" ("Test" ("Full_Type_Declaration"))) + ("With Clause" ("Ada.Text_IO"))) + (lambda () (setq-local ada-ts-mode-imenu-categories + (seq-filter (lambda (category) (not (eq category 'task))) + ada-ts-mode-imenu-categories))))) + +Name: Without "task" category + +=-= +with Ada.Text_IO; + +package body Test is + + type Full_Type_Declaration is new Integer range 0 .. 255; + + procedure Subprogram_Declaration; + + task Single_Task_Declaration; + + protected Single_Protected_Declaration is + end Single_Protected_Declaration; + +end Test; +=-=-= + +Code: (lambda () (imenu-transform + '(("Package" ("Test")) + ("Subprogram" ("Test" ("Subprogram_Declaration"))) + ("Protected" ("Test" ("Single_Protected_Declaration"))) + ("Task" ("Test" ("Single_Task_Declaration"))) + ("With Clause" ("Ada.Text_IO"))) + (lambda () (setq-local ada-ts-mode-imenu-categories + (seq-filter (lambda (category) (not (eq category 'type-declaration))) + ada-ts-mode-imenu-categories))))) + +Name: Without "type-declaration" category + +=-= +with Ada.Text_IO; + +package body Test is + + type Full_Type_Declaration is new Integer range 0 .. 255; + + procedure Subprogram_Declaration; + + task Single_Task_Declaration; + + protected Single_Protected_Declaration is + end Single_Protected_Declaration; + +end Test; +=-=-= + +Code: (lambda () (imenu-transform + '(("Package" ("Test")) + ("Subprogram" ("Test" ("Subprogram_Declaration"))) + ("Protected" ("Test" ("Single_Protected_Declaration"))) + ("Task" ("Test" ("Single_Task_Declaration"))) + ("Type Declaration" ("Test" ("Full_Type_Declaration")))) + (lambda () (setq-local ada-ts-mode-imenu-categories + (seq-filter (lambda (category) (not (eq category 'with-clause))) + ada-ts-mode-imenu-categories))))) + +Name: Without "with-clause" category + +=-= +with Ada.Text_IO; + +package body Test is + + type Full_Type_Declaration is new Integer range 0 .. 255; + + procedure Subprogram_Declaration; + + task Single_Task_Declaration; + + protected Single_Protected_Declaration is + end Single_Protected_Declaration; + +end Test; +=-=-= diff --git a/test/resources/imenu-category-names.erts b/test/resources/imenu-category-names.erts new file mode 100644 index 0000000..35561c2 --- /dev/null +++ b/test/resources/imenu-category-names.erts @@ -0,0 +1,33 @@ +Code: (lambda () (imenu-transform + '(("*Package*" ("Test")) + ("*Subprogram*" ("Test" ("Subprogram_Declaration"))) + ("*Protected*" ("Test" ("Single_Protected_Declaration"))) + ("*Task*" ("Test" ("Single_Task_Declaration"))) + ("*Type Declaration*" ("Test" ("Full_Type_Declaration"))) + ("*With Clause*" ("Ada.Text_IO"))) + (lambda () (setq-local ada-ts-mode-imenu-category-name-alist + '((package . "*Package*") + (subprogram . "*Subprogram*") + (protected . "*Protected*") + (task . "*Task*") + (type-declaration . "*Type Declaration*") + (with-clause . "*With Clause*")))))) + +Name: Alternative Category Names + +=-= +with Ada.Text_IO; + +package body Test is + + type Full_Type_Declaration is new Integer range 0 .. 255; + + procedure Subprogram_Declaration; + + task Single_Task_Declaration; + + protected Single_Protected_Declaration is + end Single_Protected_Declaration; + +end Test; +=-=-= diff --git a/test/resources/imenu.erts b/test/resources/imenu.erts index 5127e1a..5347d2e 100644 --- a/test/resources/imenu.erts +++ b/test/resources/imenu.erts @@ -119,3 +119,86 @@ package body XYZ is end XYZ; =-=-= + +Name: with_clause + +Code: (lambda () (imenu-transform + '(("With Clause" ("Ada") + ("Ada.Text_IO") + ("Text_IO") + ("ABC") + ("DEF") + ("XYZ.ABC"))))) + +=-= +with Ada, Ada.Text_IO, Text_IO; +with ABC; +with DEF; +with XYZ.ABC; +=-=-= + +Name: Tasks, Protected Units and Types + +Code: (lambda () (imenu-transform + '(("Package" ("Test") + ("Test")) + ("Protected" ("Test" ("Protected_Type_Declaration") + ("Single_Protected_Declaration") + ("Protected_Body") + ("Protected_Body_Stub"))) + ("Task" ("Test" ("Task_Type_Declaration") + ("Single_Task_Declaration") + ("Task_Body") + ("Task_Body_Stub"))) + ("Type Declaration" ("Test" ("Formal_Complete_Type_Declaration") + ("Formal_Incomplete_Type_Declaration")) + ("Test" ("Full_Type_Declaration") + ("Subtype_Declaration") + ("Incomplete_Type_Declaration") + ("Private_Type_Declaration") + ("Private_Extension_Declaration") + ("Task_Type_Declaration") + ("Protected_Type_Declaration")))))) + +=-= +generic + type Formal_Complete_Type_Declaration is private; + type Formal_Incomplete_Type_Declaration; +package Test is +end Test; + +package body Test is + + type Full_Type_Declaration is new Integer range 0 .. 255; + + subtype Subtype_Declaration is Full_Type_Declaration; + + type Incomplete_Type_Declaration; + + type Private_Type_Declaration is private; + + type Private_Extension_Declaration is new Private_Type_Declaration with private; + + task type Task_Type_Declaration; + + protected type Protected_Type_Declaration is + end Protected_Type_Declaration; + + task Single_Task_Declaration; + + protected Single_Protected_Declaration is + end Single_Protected_Declaration; + + task body Task_Body is + begin + null; + end Task_Body; + + protected body Protected_Body is + end Protected_Body; + + task body Task_Body_Stub is separate; + + protected body Protected_Body_Stub is separate; +end Test; +=-=-=