;;; f90-ts-mode.el --- Tree-sitter based Fortran 90 mode -*- lexical-binding: t; -*-

;; Copyright (C) 2025-2026 Martin Stein

;; Author: Martin Stein <mscfd@gmx.net>
;; Maintainer: Martin Stein <mscfd@gmx.net>
;; URL: https://github.com/mscfd/emacs-f90-ts-mode
;; Keywords: languages, treesitter, fortran
;; Package-Version: 0.2.2
;; Package-Revision: v0.2.2-0-g6c3e40cad1fc
;; Package-Requires: ((emacs "30.1"))

;; This file is NOT part of GNU Emacs.

;; 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, 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; f90-ts-mode is a major mode for editing Fortran 90/2003 (and newer) source
;; files, based on Emacs's built-in tree-sitter support (requires Emacs 30+)
;;
;; Features:
;;   - Syntax highlighting
;;   - Indentation
;;   - Alignment for multiline statements where applicable
;;   - Smart end completion
;;   - Breaking and joining continued lines
;;   - (Un)commenting regions with configurable prefixes
;;   - OpenMP and preprocessor directives
;;   - Region selection based on tree-sitter nodes
;;   - Xref (buffer local)
;;   - Imenu
;;   - Fortran menu and transient keybindings
;;
;; Features can be found by the fortran menu or a transient popup bound
;; to the key C-c C-f.
;;
;; Installation requires the tree-sitter Fortran grammar, which can be found at
;;   https://github.com/stadelmanma/tree-sitter-fortran
;;
;; Basic setup with use-package:
;;
;;   (use-package f90-ts-mode
;;     :mode ("\\.f90\\'" . f90-ts-mode))
;;
;; See the README and MANUAL at https://github.com/mscfd/emacs-f90-ts-mode
;; for full documentation on options, keybindings, etc.
;;
;; Bugs and features:
;;   https://github.com/mscfd/emacs-f90-ts-mode/issues
;;
;; Questions and discussions:
;;   https://fortran-lang.discourse.group/t/tree-sitter-based-f90-mode-for-emacs/10746
;;
;; Note: Emacs must be linked against tree-sitter 0.25.x at runtime.
;; Emacs does not yet support 0.26, though support is in development and this
;; restriction may soon be obsolete.
;; Moreover the grammar should also be compiled against tree-sitter 0.25.x,
;; though it seems that grammar files generated by 0.26 work as well.
;; The pregenerated grammar files in the master branch of
;; https://github.com/mscfd/tree-sitter-fortran are built against 0.25.10
;; and ready to use, if there are problems with the official repository.
;;
;; To verify the setup:
;;   M-: (treesit-library-abi-version)           ; should return 15
;;   M-: (treesit-language-abi-version 'fortran) ; should return 15
;;
;;   in linux:
;;   ldd "emacs" | grep libtree-sitter ; should show libtree-sitter.so.0.25
;;
;;   in macos:
;;   otool -L "emacs" | grep tree-sitter
;;   ; expecting something like: .../tree-sitter/lib/libtree-sitter.0.dylib
;;                               (compatibility version 0.0.0, current version 0.25.0)
;;
;;   in windows: unknown how to check

;;; Code:

(require 'cl-lib)
(require 'treesit)
(require 'xref)
(require 'transient)

;; hl-line is used for the navigation buffer
(require 'hl-line)

;;;-----------------------------------------------------------------------------

(defgroup f90-ts nil
  "Fortran (F90+) major mode using Tree-sitter."
  :group 'languages)


(defgroup f90-ts-font-lock nil
  "Font-locking for Tree-sitter f90-ts mode.
This group defines additional faces used for F90-specific syntax.
Standard font-lock faces are used as well."
  :prefix "f90-ts-"
  :group  'f90-ts)


(defgroup f90-ts-indent nil
  "Indentation for Tree-sitter f90-ts mode."
  :prefix "f90-ts-"
  :group  'f90-ts)


(defgroup f90-ts-nav nil
  "Navigation for Tree-sitter f90-ts mode."
  :prefix "f90-ts-"
  :group  'f90-ts)


(defcustom f90-ts-indent-toplevel 0
  "Extra indentation applied to contain sections at toplevel."
  :type  'integer
  :safe  #'integerp
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-contain 3
  "Extra indentation applied to contain sections."
  :type  'integer
  :safe  #'integerp
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-block 3
  "Extra indentation applied to most blocks.
These are function and subroutine bodies, control statements (do, if,
associate ...) etc."
  :type  'integer
  :safe  #'integerp
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-continued 5
  "Extra indentation applied to continued lines."
  :type  'integer
  :safe  #'integerp
  :group 'f90-ts-indent)


(defconst f90-ts-indent-list-options
  '(("keep if aligned or align to primary column" . keep-or-primary)
    ("keep if aligned or rotate to next column" . keep-or-rotate)
    ("align with primary column" . primary)
    ("indent to first line of statement with offset `f90-ts-indent-continued'" . continued-line)
    ("rotate columns" . rotate))
  "Options for indentation of list like structures on continued lines.")


(defconst f90-ts--indent-list-radio
  `(radio ,@(mapcar (lambda (x)
                      `(const :tag ,(car x) ,(cdr x)))
                    f90-ts-indent-list-options))
  "Prepared options list for defcustoms.")


(defcustom f90-ts-indent-list-region 'keep-or-primary
  "Select indentation column for continued lines in list-like context.
Used as default setting in `indent-region' and similar operations."
  :type  f90-ts--indent-list-radio
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-list-line 'rotate
  "Select indentation column for continued lines in list-like context.
Used as default setting in `indent-for-tab-command' and similar
operations (indentation of a single line)."
  :type  f90-ts--indent-list-radio
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-list-line-2 'continued-line
  "Select indentation column for continued lines in list-like context.
Used as secondary setting in `indent-for-tab-command'.  Can be be bound
to <backtab> (S-<tab>), A-<tab>, C-S-<tab> or other."
  :type  f90-ts--indent-list-radio
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-list-line-3 'primary
  "Select indentation column for continued lines in list-like context.
Used as ternary setting in `indent-for-tab-command'.  Can be be bound
to <backtab> (S-<tab>), A-<tab>, C-S-<tab> or other."
  :type  f90-ts--indent-list-radio
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-paren-default 1
  "Additional offset applied for alignment with opening parenthesis.
The default is for all items except the closing parenthesis.

Example:
   call sub(       arg1, &
            .not.  arg2)
Primary alignment column for the second line column of parenthesis plus
`f90-ts-indent-paren-default'."
  :type  'integer
  :safe  #'integerp
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-paren-close 0
  "Additional offset applied for alignment with opening parenthesis.
This is for the closing parenthesis.

Example:
   x = x + (y + &
            z &
           )

Primary alignment column for the closing parenthesis is column of
opening parenthesis plus `f90-ts-indent-paren-close'."
  :type  'integer
  :safe  #'integerp
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-expr-assign-default 2
  "Additional offset applied for alignment at assignment.
This is applied for alignment with symbol \"=\" for all items
except for associative operators.

Example:
x =      & ! some comment
    some_expression

Primary alignment column for the second line column of assignment plus
`f90-ts-indent-expr-assign-default' for non-operators."
  :type  'integer
  :safe  #'integerp
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-expr-assign-assoc-op 0
  "Additional offset applied for alignment at assignment.
This is applied for alignment with symbol \"=\" for all associative
operators (logical_expression, math_expression).

Example:
x = value1 &
  + some_expression

Primary alignment column for the second line column of assignment plus
`f90-ts-indent-expr-assign-assoc-op' for associative operators."
  :type  'integer
  :safe  #'integerp
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-declaration 3
  "Additional offset applied for alignment with declaration delimiter \"::\".
For declarations without the delimiter offset `f90-ts-indent-declaration'
minus 2 is used (subtracting the length of \"::\").

This is applied in variable declarations.

Example:
integer, parameter :: ! some parameter &
                      param = 0.1234

integer ! offset of \"x\" is end position of type specifier + 3 - 2
        x

Primary alignment column for the second line of a declaration plus
`f90-ts-indent-declaration'."
  :type  'integer
  :safe  #'integerp
  :group 'f90-ts-indent)


(defcustom f90-ts-leading-ampersand-style '(indent . 3)
  "Indentation style for leading ampersands in continued lines.
Value is a list of the form (TYPE VALUE) where TYPE is either:
- `column': place the ampersand at column VALUE (0-based)
- `indent': place the ampersand with offset VALUE relative to first
  line of the continued statement."
  :type '(choice (cons :tag "Fixed column"
                       (const :tag "" :format "" column)
                       (integer :tag "Fixed column number"))
                 (cons :tag "Indent offset"
                       (const :tag "" :format "" indent)
                       (integer :tag "Offset to first line")))
  :group 'f90-ts)


(defcustom f90-ts-stmt-label-column '(left . 0)
  "Column specification for Fortran statement labels.
A cons cell (ADJUSTMENT . COLUMN) where ADJUSTMENT is either
`right-adjusted' or `left-adjusted', and COLUMN is a 0-based column number.
With `right', the label's last digit lands on COLUMN (right-adjusted),
so (right . 4) fills columns 0-4, the classic Fortran label field.
With `left', the label's first digit starts on COLUMN (left-adjusted)."
  :type '(cons
          (choice
           (const :tag "Right-adjusted (last digit at column)" right)
           (const :tag "Left-adjusted  (first digit at column)" left))
          (integer :tag "Column (0-based)"))
  :group 'f90-ts)


;;;-----------------------------------------------------------------------------

(defface f90-ts-font-lock-delimiter-face
  '((t :inherit default))
  "Face used to highlight delimiter symbols (e.g. commas)."
  :group 'f90-ts-font-lock)


(defface f90-ts-font-lock-bracket-face
  '((t :inherit default))
  "Face used to highlight brackets and parenthesis."
  :group 'f90-ts-font-lock)


(defface f90-ts-font-lock-operator-face
  '((t :inherit default))
  "Face used to highlight operators (e.g. +, -, *, /)."
  :group 'f90-ts-font-lock)


(defface f90-ts-font-lock-openmp-face
  '((t :inherit font-lock-preprocessor-face))
  "Face used to highlight OpenMP statements.
Openmp statements are determined by `f90-ts-special-comment-rules'."
  :group 'f90-ts-font-lock)


(defface f90-ts-font-lock-special-var-face
  '((t :inherit font-lock-keyword-face :slant italic))
  "Face used to highlight special variables like \"self\" or \"this\".
Special variables are determined by regexp custom variable
`f90-ts-special-var-regexp'."
  :group 'f90-ts-font-lock)


(defface f90-ts-font-lock-separator-comment-face
  '((t :inherit font-lock-comment-face :weight bold))
  "Face used to highlight separator comments.
Special comments such as separators are determined by rules in
`f90-ts-special-comment-rules'."
  :group 'f90-ts-font-lock)


;;;-----------------------------------------------------------------------------

(defface f90-ts-nav-procedure-face
  '((t :inherit font-lock-function-name-face :weight bold))
  "Face for subroutine, function, and interface entries in navigation buffer."
  :group 'f90-ts-nav)


(defface f90-ts-nav-type-face
  '((t :inherit font-lock-type-face :weight bold))
  "Face for type entries in navigation buffer."
  :group 'f90-ts-nav)


(defface f90-ts-nav-module-face
  '((t :inherit font-lock-function-name-face :weight bold))
  "Face for module, submodule, program entries in navigation buffer."
  :group 'f90-ts-nav)


(defface f90-ts-nav-variable-face
  '((t :inherit default))
  "Face for variable entries in navigation buffer."
  :group 'f90-ts-nav)


(defcustom f90-ts-nav-buffer-auto-sync t
  "If non-nil the point in the nav buffer follows point in the source buffer."
  :type 'boolean
  :group 'f90-ts-nav)


(defcustom f90-ts-nav-buffer-idle-delay 1.0
  "Seconds of idle time before the nav buffer is automatically refreshed."
  :type 'number
  :safe (lambda (x) (and (numberp x) (> x 0)))
  :group 'f90-ts-nav)


(defcustom f90-ts-nav-buffer-width 40
  "Width of navigation buffer."
  :type 'integer
  :safe (lambda (x) (and (integerp x) (> x 0)))
  :group 'f90-ts-nav)


;;;-----------------------------------------------------------------------------
;;; other options

(defcustom f90-ts-smart-end 'blink
  "Determine whether and how to complete an end statement.
If set to blink, perform completion and then jump to the opening clause of the
completed statement.
If set to no-blink perform completion without jumping, but print a message.
If set to no-message just perform completion without jumping and any message.
Value nil turns off smart end completion.

Copied from prog mode `f90-mode'."
  :type  '(choice (const blink) (const no-blink) (const no-message) (const nil))
  :safe  (lambda (value) (memq value '(blink no-blink complete nil)))
  :group 'f90-ts)


;; same as f90-beginning-ampersand in legacy f90 mode
(defcustom f90-ts-leading-ampersand nil
  "Non-nil gives automatic insertion of leading `&' at a continued line."
  :type  'boolean
  :safe  #'booleanp
  :group 'f90-ts)


(defcustom f90-ts-menu-show-navigate t
  "Show navigate submenu in fortran menu if non-nil.
For large source files, the menu might not be useful and reduce performance."
  :type  'boolean
  :safe  #'booleanp
  :group 'f90-ts)


(defcustom f90-ts-special-var-regexp "\\_<\\(self\\|this\\)\\_>"
  "Regular expression for matching special variables.
This is used for syntax highlighting of variables like \"self\" and \"this\".
For matching identifiers the face `f90-ts-font-lock-special-var' is used."
  :type  'regexp
  :safe  #'stringp
  :group 'f90-ts)


(defcustom f90-ts-comment-prefix-regexp "!\\S-*\\(\\s-+\\|$\\)"
  "Regular expression for matching and capturing comment starts.
This is used to extract the comment prefix for `f90-ts-break-line',
`f90-ts-join-line-prev' and `f90-ts-join-line-next' operations.
OpenMP prefix is matched by `f90-ts-openmp-prefix-regexp'.

The variable should also add trailing whitespace characters to
preserve indentation within comments with `f90-ts-break-line'."
  :type  'regexp
  :safe  #'stringp
  :group 'f90-ts)


(defcustom f90-ts-comment-region-prefix "!!$ "
  "Default comment prefix for commenting regions.
Trailing blank(s) are not inserted automatically, but can be provided
in the string."
  :type  'string
  :group 'f90-ts)


(defcustom f90-ts-extra-comment-prefixes '("! " "!$omp " "!$acc " "!!!" "!> " "!< ")
  "List of additional comment prefixes for interactive selection.
Trailing blank(s) are not inserted automatically, but can be provided
in the string."
  :type  '(repeat string)
  :group 'f90-ts)


(defcustom f90-ts-comment-prefix-keep-indent t
  "Keep indentation in commen region operation when inserting comment prefix.
If nil, just insert the prefix.  If non-nil, remove blanks up to length of
prefix before commented command starts.  The preserves the original
indentation."
  :type  'boolean
  :group 'f90-ts)


(defcustom f90-ts-mark-region-reversed nil
  "Mark region operations place point at end of region.
If this option is set, then point is placed at start of region."
  :type  'boolean
  :safe  #'booleanp
  :group 'f90-ts)


(defcustom f90-ts-openmp-prefix-regexp "!\\$\\(?:omp\\)?\\(\\s-+\\|$\\)"
  "Regular expression for matching OpenMP starts.
This is used for line break operations, as openmp statements require
continuation symbols.
The defcustom should also add trailing whitespace characters to preserve
indentation within OpenMP statements."
  :type  'regexp
  :safe  #'stringp
  :group 'f90-ts)


(defcustom f90-ts-comment-keyword-regexp "\\<\\(TODO\\|FIXME\\|Remarks?\\)\\>"
  "Regexp matching keywords within comments to highlight.
The matched part of the comment is highlighted with `font-lock-warning-face'.
Set to nil to disable keyword highlighting in comments."
  :type '(choice (const :tag "Disabled" nil)
                 (regexp :tag "Regexp"))
  :group 'f90-ts)


(defcustom f90-ts-special-comment-rules
  '((:name "openmp simd rule"
     :match "^!\\$omp simd\\b"
     :indent indented
     :face f90-ts-font-lock-openmp-face)
    (:name "general openmp rule"
     :match "^!\\$\\(?:omp\\)?\\b"
     :indent column-0
     :face f90-ts-font-lock-openmp-face)
    (:name "separator comment rule"
     :match "^!={40,}"
     :indent context
     :face f90-ts-font-lock-separator-comment-face)
    (:name "ford documentation"
     :match "^![<>]"
     :indent indented
     :face font-lock-doc-face)
    (:name "comment region prefixes: column-0"
     :match "^!!\\$"
     :indent column-0
     :face font-lock-comment-face)
    (:name "comment region prefixes: context"
     :match "^!!!"
     :indent context
     :face font-lock-comment-face))
  "Rules for special comment node indentation in `f90-ts-mode'.

Each element is a plist with the following keys:

  :name    A string naming the rule for documentation.

  :match   Either a regexp string matched against the comment line
           text, or a predicate function called with one argument
           (the comment node) that returns non-nil for a match.

  :indent  One of the following symbols:
           `column-0'  — always indent to column 0,
           `context'   — indent aligned to enclosing construct,
           `indented'  — indent like normal code and comments.

  :face    face symbol used to highlight matching comments.

Rules are tested in order; the first match determines indentation
and font lock face.
If no rule matches, the comment is indented normally.

Matches are only done at start of comment if the regexp starts with \"^\".
Otherwise matches also succeed if the it matches somewhere within the comment.

Indentation hints of special comment rules are ignored within continued
lines, except for the column-0 option.  The other two options does not
seem to make much sense."
  :type '(repeat
          (list :tag "Rule"
                (const :format "" :value :name)
                (string :tag "Name")
                (const :format "" :value :match)
                (choice :tag "Match"
                        (regexp   :tag "Regexp")
                        (function :tag "Predicate"))
                (const :format "" :value :indent)
                (choice :tag "Indentation"
                        (const :tag "Column 0"                          column-0)
                        (const :tag "Context (parent block)"            context)
                        (const :tag "Indented (like code and comments)" indented))

                (const :format "" :value :face)
                (choice :tag "Face"
                        (const :tag "font-lock-comment-face"
                               font-lock-comment-face)
                        (const :tag "font-lock-doc-face"
                               font-lock-doc-face)
                        (const :tag "f90-ts-font-lock-separator-comment-face"
                               f90-ts-font-lock-separator-comment-face)
                        (const :tag "f90-ts-font-lock-openmp-face"
                               f90-ts-font-lock-openmp-face)
                        (face :tag "other face"))))
  :group 'f90-ts)


;;;-----------------------------------------------------------------------------
;;; syntax table

(defvar f90-ts-mode-syntax-table
  (let ((table (make-syntax-table)))
    ;; --- symbols and words ---
    ;; '_' is a symbol constituent in Fortran
    (modify-syntax-entry ?_ "_" table)

    ;; --- string delimiters ---
    (modify-syntax-entry ?\" "\"" table)
    (modify-syntax-entry ?\' "\"" table)

    ;; --- comments ---
    ;; '!' starts a comment. '<' means start, 'b' means it's a
    ;; "Style B" comment (standard for line-based comments).
    (modify-syntax-entry ?! "< b" table)
    ;; newline ends the comment. '>' means end.
    (modify-syntax-entry ?\n "> b" table)

    ;; delimiters, newline, continuation
    (modify-syntax-entry ?\r " "  table) ; return is whitespace
    (modify-syntax-entry ?&  "."  table) ; continuation line
    (modify-syntax-entry ?%  "."  table) ; component reference

    ;; --- Arithmetic/Logic Punctuation ---
    (modify-syntax-entry ?+ "." table)
    (modify-syntax-entry ?- "." table)
    (modify-syntax-entry ?* "." table)
    (modify-syntax-entry ?/ "." table)
    (modify-syntax-entry ?= "." table)
    (modify-syntax-entry ?< "." table)
    (modify-syntax-entry ?> "." table)
    (modify-syntax-entry ?. "." table)  ; this is difficult, as dot in ".and." for example
                                        ; should belong to the symbol class and not punctuation,
                                        ; but having this as symbol would interfer with for example
                                        ; "this_flag.and.other_flag", appearing as one big symbol,
                                        ; likewise it could be difficult with floating point numbers?

    table)
  "Syntax table for `f90-ts-mode'.")


;;;-----------------------------------------------------------------------------
;;; keymap


;; transient is used instead (but keep it for a while)
;;
;; (define-prefix-command 'f90-ts-prefix-map)
;; ;; indentation
;; (define-key f90-ts-prefix-map (kbd "<tab>") #'f90-ts-indent-and-complete-line)
;; (define-key f90-ts-prefix-map (kbd "s")     #'f90-ts-indent-and-complete-stmt)
;; (define-key f90-ts-prefix-map (kbd "I")     #'f90-ts-indent-and-complete-region)
;; (define-key f90-ts-prefix-map (kbd "E")     #'f90-ts-complete-smart-end-region)

;; ;; line editing
;; (define-key f90-ts-prefix-map (kbd "RET") #'f90-ts-break-line)
;; (define-key f90-ts-prefix-map (kbd "j")   #'f90-ts-join-line-prev)
;; (define-key f90-ts-prefix-map (kbd "J")   #'f90-ts-join-line-next)

;; ;; comment region
;; (define-key f90-ts-prefix-map (kbd "c") #'f90-ts-comment-region-default)
;; (define-key f90-ts-prefix-map (kbd "C") #'f90-ts-comment-region-custom)

;; ;; navigation
;; ;; procedure
;; (define-key f90-ts-prefix-map (kbd "a") #'f90-ts-thing-beginning-of-procedure)
;; (define-key f90-ts-prefix-map (kbd "e") #'f90-ts-thing-end-of-procedure)
;; (define-key f90-ts-prefix-map (kbd "p") #'f90-ts-thing-prev-procedure)
;; (define-key f90-ts-prefix-map (kbd "n") #'f90-ts-thing-next-procedure)

;; ;; type
;; (define-key f90-ts-prefix-map (kbd "M-a") #'f90-ts-thing-beginning-of-type)
;; (define-key f90-ts-prefix-map (kbd "M-e") #'f90-ts-thing-end-of-type)
;; (define-key f90-ts-prefix-map (kbd "M-p") #'f90-ts-thing-prev-type)
;; (define-key f90-ts-prefix-map (kbd "M-n") #'f90-ts-thing-next-type)

;; ;; interface
;; (define-key f90-ts-prefix-map (kbd "C-M-a") #'f90-ts-thing-beginning-of-interface)
;; (define-key f90-ts-prefix-map (kbd "C-M-e") #'f90-ts-thing-end-of-interface)
;; (define-key f90-ts-prefix-map (kbd "C-M-p") #'f90-ts-thing-prev-interface)
;; (define-key f90-ts-prefix-map (kbd "C-M-n") #'f90-ts-thing-next-interface)

;; ;; region
;; (define-key f90-ts-prefix-map (kbd "r") #'f90-ts-enlarge-region)
;; (define-key f90-ts-prefix-map (kbd "0") #'f90-ts-child0-region)
;; (define-key f90-ts-prefix-map (kbd "[") #'f90-ts-prev-region)
;; (define-key f90-ts-prefix-map (kbd "]") #'f90-ts-next-region)

;; ;; xref
;; (define-key f90-ts-prefix-map (kbd ".") #'xref-find-definitions)
;; (define-key f90-ts-prefix-map (kbd ",") #'xref-find-references)
;; (define-key f90-ts-prefix-map (kbd "/") #'xref-find-apropos)

;; ;; navigation side panel
;; (define-key f90-ts-prefix-map (kbd "b")   #'f90-ts-nav-buffer-open)
;; (define-key f90-ts-prefix-map (kbd "f")   #'f90-ts-nav-buffer-focus)

;; ;; transient popup itself (? or C-c C-f C-f / SPC to open)
;; (define-key f90-ts-prefix-map (kbd "?")   #'f90-ts-transient)
;; (define-key f90-ts-prefix-map (kbd "SPC") #'f90-ts-transient)


(defvar f90-ts-mode-map
  (let ((map (make-sparse-keymap)))
    ;; TAB commands
    (define-key map (kbd "C-<tab>")           #'f90-ts-indent-and-complete-stmt)
    (define-key map (kbd "<backtab>")         #'f90-ts-indent-for-tab-command-2) ; S-<tab>
    (define-key map (kbd "C-S-<iso-lefttab>") #'f90-ts-indent-for-tab-command-3) ; Linux
    (define-key map (kbd "C-<backtab>")       #'f90-ts-indent-for-tab-command-3) ; Windows?

    ;; other keybindings inspired by f90-mode
    (define-key map (kbd "C-<return>") #'f90-ts-break-line)
    (define-key map (kbd "C-c ;")      #'f90-ts-comment-region-default)
    (define-key map (kbd "C-c '")      #'f90-ts-comment-region-custom)

    ;; C-c C-f prefix for the transient menu
    (define-key map (kbd "C-c C-f") #'f90-ts-transient)
    map)
  "Keymap for `f90-ts-mode'.")


(transient-define-prefix f90-ts-transient ()
  "F90 Tree-sitter Mode."
  [["Indentation"
    ("TAB" "Indent line"                       f90-ts-indent-and-complete-line)
    ("s"   "Indent & complete statement"       f90-ts-indent-and-complete-stmt)
    ("I"   "Indent & complete region"          f90-ts-indent-and-complete-region)
    ("E"   "Complete end statements"           f90-ts-complete-smart-end-region)]
   ["Line & comments"
    ("b"   "Break line"                        f90-ts-break-line)
    ("j"   "Join with previous line"           f90-ts-join-line-prev)
    ("J"   "Join with next line"               f90-ts-join-line-next)
    ("c"   "Comment region (default)"          f90-ts-comment-region-default)
    ("C"   "Comment region (custom)"           f90-ts-comment-region-custom)]
   ["Region"
    ("r"   "Enlarge region"                    f90-ts-enlarge-region)
    ("0"   "Child-0 region"                    f90-ts-child0-region)
    ("["   "Previous region"                   f90-ts-prev-region)
    ("]"   "Next region"                       f90-ts-next-region)]]
  [["Procedure navigation"
    ("a"   "Beginning"                         f90-ts-thing-beginning-of-procedure)
    ("e"   "End"                               f90-ts-thing-end-of-procedure)
    ("p"   "Previous"                          f90-ts-thing-prev-procedure)
    ("n"   "Next"                              f90-ts-thing-next-procedure)]
   ["Type navigation"
    ("M-a" "Beginning"                         f90-ts-thing-beginning-of-type)
    ("M-e" "End"                               f90-ts-thing-end-of-type)
    ("M-p" "Previous"                          f90-ts-thing-prev-type)
    ("M-n" "Next"                              f90-ts-thing-next-type)]
   ["Interface navigation"
    ("C-M-a" "Beginning"                       f90-ts-thing-beginning-of-interface)
    ("C-M-e" "End"                             f90-ts-thing-end-of-interface)
    ("C-M-p" "Previous"                        f90-ts-thing-prev-interface)
    ("C-M-n" "Next"                            f90-ts-thing-next-interface)]
   ["Xref"
    ("."   "Find definition"                   xref-find-definitions)
    (","   "Find references"                   xref-find-references)
    ("/"   "Find apropos"                      xref-find-apropos)
    ("<"   "Go back"                           xref-go-back)
    (">"   "Go forward"                        xref-go-forward)]
   ["Navigation panel"
    ("b"   "Open nav buffer"                   f90-ts-nav-buffer-open)
    ("f"   "Focus nav buffer"                  f90-ts-nav-buffer-focus)]])


;;;-----------------------------------------------------------------------------

;; defined in simple.el
(defvar blink-matching-delay)


;;;-----------------------------------------------------------------------------
;;; tree-sitter workaround

;; For virtual zero-length nodes, `treesit-node-parent' fails. For
;;
;;    call something(arg1, &
;;                   arg2)
;;
;; the grammar injects a second ampersand of length zero right before "a".
;; `treesit-node-at' at a point before arg2, returns the virtual ampersand node.
;; But his node has no parent, but it has a previous and next sibling. A couple of
;; treesit functions (like treesit-thing-at, used for which-function-mode etc.)
;; using `treesit-node-at' followed by `treesit-parent-until' fail as a consequence.
;; To circumvent this, treesit-node-parent is patched by using previous or next
;; sibling and check, whether those have a proper parent. Which seems always the case.

(define-advice treesit-node-parent (:around (orig node) f90-ts--skip-zero-width-extras)
  "If NODE is zero-width with no parent, walk siblings to find a real parent.

This is required for virtual ampersand continuation line nodes, for which
there is no parent.  Those nodes always have direct proper previous and next
siblings with the correct parent.  So walking is just one step in general."
  (let ((parent (funcall orig node)))
    (cond
     ((null node)
      ;; nothing to do if node is nil (original function returns nil in that case)
      ;; (do not try to query the parser with a nil node)
      nil)
     ((not (eq (treesit-parser-language
                (treesit-node-parser node))
               'fortran))
      ;; always use default function for non-fortran languages
      parent)
     ((or parent
          (< (treesit-node-start node) (treesit-node-end node)))
      ;; just use original function for nodes with a non-zero span
      parent)
     (t
      ;; try previous siblings first, then next siblings as fallback,
      ;; but for the intended case, one step to the prev-sibling resolves the issue
      (or (cl-loop for candidate = (treesit-node-prev-sibling node)
                   then (treesit-node-prev-sibling candidate)
                   while candidate
                   thereis (funcall orig candidate))
          (cl-loop for candidate = (treesit-node-next-sibling node)
                   then (treesit-node-next-sibling candidate)
                   while candidate
                   thereis (funcall orig candidate)))))))


;;;-----------------------------------------------------------------------------
;;; debug: load f90-ts-log if these are required for development or debugging

(defun f90-ts-log-msg (_category _fmt &rest _args)
  "Logging stub.
Load f90-ts-log.el to enable logging.  This function is replaced by the real
implementation when the logging package is loaded.

Set `f90-ts-allow-log' to allow log instruction as no-op without `f90-ts-log'.
This is used by the Makefile to run ert tests during development."
  (unless (bound-and-true-p f90-ts-allow-log)
  (error "Function f90-ts-log-msg not available: load f90-ts-log.el first")))


(defun f90-ts-log-line (_category _msg &optional _pos)
  "Logging stub.
Load f90-ts-log.el to enable logging.  This function is replaced by the real
implementation when the logging package is loaded.

Set `f90-ts-allow-log' to allow log instruction as no-op without `f90-ts-log'.
This is used by the Makefile to run ert tests during development."
  (unless (bound-and-true-p f90-ts-allow-log)
    (error "Function f90-ts-log-line not available: load f90-ts-log.el first")))


(defun f90-ts-log-inspect-node (_category _node _info)
  "Node inspection stub.
Load f90-ts-log.el to enable logging.  This function is replaced by the real
implementation when the logging package is loaded.

Set `f90-ts-allow-log' to allow log instruction as no-op without `f90-ts-log'.
This is used by the Makefile to run ert tests during development."
  (unless (bound-and-true-p f90-ts-allow-log)
    (error "Function f90-ts-log-inspect-node not available: load f90-ts-log.el first")))


(defun f90-ts-log-indent-print-state (_msg)
  "Debug indent rule stub.
Load f90-ts-log.el to enable logging.  This function is replaced by the real
implementation when the logging package is loaded.

Set `f90-ts-allow-log' to allow log instruction as no-op without `f90-ts-log'.
This is used by the Makefile to run ert tests during development."
  (unless (bound-and-true-p f90-ts-allow-log)
    (error "Function f90-ts-log-indent-print-state not available: load f90-ts-log.el first")))


;;;-----------------------------------------------------------------------------
;;; auxiliary predicates

(defun f90-ts--node-type-p (node type)
  "If TYPE is nil, return true and ignore NODE.
If NODE is nil and TYPE is non-nil, return nil.
If TYPE is a string, return true if NODE is non-nil and is of type TYPE.
If TYPE is a list of strings, return true if NODE is non-nil and its
type is among the elements of TYPE."
  (or (not type)
      (and node
           (let ((type-n (treesit-node-type node)))
             (if (stringp type)
                 (string= type-n type)
               (member type-n type))))))


(defun f90-ts--node-type-match-p (node type-rx)
  "If TYPE_RX is nil, return non-nil and ignore NODE.
If NODE is nil and TYPE_RX is non-nil, return nil.
If TYPE-RX and NODE are both non-nil return non-nil if the type of NODE
is matched by TYPE-RX."
  (or (not type-rx)
      (and node
           (let ((type-n (treesit-node-type node)))
             (string-match-p type-rx type-n)))))


(defun f90-ts--comment-prefix (node)
  "Extract the starting character sequence from a comment NODE.
NODE is assumed to be of type comment.  It uses `f90-ts-openmp-prefix-regexp'
and `f90-ts-comment-prefix-regexp' to identify the prefix to extract."
  (cl-assert (f90-ts--node-type-p node "comment")
             nil "comment-prefix: comment node expected")
  ;; first match openmp as comment prefix would just take the initial ! and ignoring
  ;; following $omp part in openmp statements
  (let ((rx-comment (concat "^\\(?:" f90-ts-openmp-prefix-regexp "\\)\\|\\(?:" f90-ts-comment-prefix-regexp "\\)")))
    (when (string-match rx-comment (treesit-node-text node))
      (match-string 0 (treesit-node-text node)))))


(defun f90-ts-special-var-p (node)
  "Check if NODE is an identifier and matches the special variable regexp.
Note that the parse uses identifier not just for variables, but for types etc."
  (when (f90-ts--node-type-p node "identifier")
    ;; we do not prepend or append symbol start or end assertions, as it should also
    ;; work with more general regexps (like highlight all variables with a certain prefix)
    (string-match-p (concat "^"
                            f90-ts-special-var-regexp
                            "$")
                    (treesit-node-text node))))


(defun f90-ts-openmp-node-p (node)
  "Check if NODE is a comment node and has a OpenMP comment prefix."
  (when (f90-ts--node-type-p node "comment")
    (string-match-p (concat "^" f90-ts-openmp-prefix-regexp)
                    (treesit-node-text node))))


(defun f90-ts-preproc-node-p (node)
  "Check if NODE is a preprocessor node and has the '#' prefix."
    (let ((type (treesit-node-type node)))
      (or (string-match "^preproc_" type)
          (string-prefix-p "#" type))))


(defconst f90-ts--builtin-functions
  '(;; integer/real
    "abs" "aimag" "aint" "anint" "ceiling" "conjg" "dble" "dim" "dprod"
    "floor" "hypot" "max" "min" "mod" "modulo" "nearest" "nint" "real"
    "rrspacing" "scale" "sign" "spacing"
    ;; exponential and logarithmic
    "exp" "log" "log10" "log_gamma" "gamma" "sqrt"
    ;; trigonometric (radians)
    "acos" "asin" "atan" "atan2" "cos" "sin" "tan"
    ;; trigonometric (degrees)
    "acosd" "asind" "atand" "atan2d" "cosd" "sind" "tand"
    ;; trigonometric (half-revolutions)
    "acospi" "asinpi" "atanpi" "atan2pi" "cospi" "sinpi" "tanpi"
    ;; hyperbolic
    "acosh" "asinh" "atanh" "cosh" "sinh" "tanh"
    ;; error functions
    "erf" "erfc" "erfc_scaled"
    ;; bessel functions
    "bessel_j0" "bessel_j1" "bessel_jn"
    "bessel_y0" "bessel_y1" "bessel_yn"
    ;; Floating-point model inquiry
    "digits" "epsilon" "exponent" "fraction" "huge" "maxexponent"
    "minexponent" "precision" "radix" "range" "rrspacing" "tiny"
    ;; numeric type conversion
    "cmplx" "int" "logical" "transfer"
    ;; bit operations
    "btest" "iand" "ibclr" "ibits" "ibset" "ieor" "ior"
    "ishft" "ishftc" "leadz" "maskl" "maskr" "merge_bits"
    "mvbits" "not" "popcnt" "poppar" "shifta" "shiftl" "shiftr"
    "trailz" "bit_size"
    ;; array inquiry
    "allocated" "is_contiguous" "lbound" "rank" "shape" "size" "ubound"
    ;; array construction, manipulation and reduction
    "all" "any" "count" "cshift" "dot_product" "eoshift" "iall" "iany"
    "iparity" "matmul" "maxloc" "maxval" "merge" "minloc" "minval" "norm2"
    "pack" "parity" "product" "reduce" "reshape" "spread" "sum"
    "transpose" "unpack"
    ;; array location
    "findloc" "maxloc" "minloc"
    ;; character
    "achar" "char" "iachar" "ichar" "index" "len" "len_trim"
    "new_line" "repeat" "scan" "trim" "verify"
    ;; kind and type inquiry
    "kind" "selected_char_kind" "selected_int_kind"
    "selected_logical_kind" "selected_real_kind" "storage_size"
    "out_of_range"
    ;; type inquiry
    "extends_type_of" "same_type_as"
    ;; pointer and allocation
    "associated" "move_alloc" "null"
    ;; coarray
    "event_post" "event_query" "event_wait"
    "failed_images" "get_team" "image_index" "image_status" "lcobound"
    "num_images" "stopped_images" "team_number" "this_image" "ucobound"
    "co_broadcast" "co_max" "co_min" "co_reduce" "co_sum"
    ;; coarray atomic subroutines
    "atomic_add" "atomic_and" "atomic_cas" "atomic_define"
    "atomic_fetch_add" "atomic_fetch_and" "atomic_fetch_or"
    "atomic_fetch_xor" "atomic_or" "atomic_ref" "atomic_xor"
    ;; random numbers
    "random_init" "random_number" "random_seed"
    ;; system and environment
    "command_argument_count" "cpu_time" "date_and_time"
    "get_command" "get_command_argument" "get_environment_variable"
    "is_iostat_end" "is_iostat_eor" "system_clock"
    ;; miscellaneous
    "present" )
  "List of all builtin keywords for font-lock highlighting.
Used with face `font-lock-builtin-face'.")


(defun f90-ts-builtin-function-p (node)
  "Return non-nil if NODE represents a builtin function.
The function assumes that NODE is an identifier and only checks the text of the
node."
;; Remark: the regexp engine invoked by tree-sitter query command :match is
;; case-sensitive, but the emacs regexp engine itself is case-insensitive.
;; So plugging (:match ,(regexp-opt f90-ts--builtin-functions 'symbols) ...)
;; into the font lock rule, as was originally done, does not work if the
;; function name in the node contains some uppercase letters."
  (cl-assert (f90-ts--node-type-p node "identifier")
             nil "builtin-function-p: identifier expected")
  (let ((text (treesit-node-text node))
        (rx (regexp-opt f90-ts--builtin-functions 'symbols)))
    (string-match-p rx text)))


(defun f90-ts-in-string-p ()
  "Non-nil if point is inside a string."
  (when-let ((node (treesit-node-at (point))))
    (when (f90-ts--node-type-p node "string_literal")
      (let ((start (treesit-node-start node))
            (end (treesit-node-end node))
            (pos (point)))
        ;; start and end position are the quotation characters
        (and (< start pos) (< pos end))))))


(defun f90-ts-in-openmp-p ()
  "Non-nil if point is inside an OpenMP statement.
OpenMP statements are parsed as comment nodes, but always start with !$.
The grammar does not parse OpenMP currently."
  (when-let ((node (treesit-node-at (point))))
    (when (f90-ts-openmp-node-p node)
      (let ((start (treesit-node-start node))
            (pos (point)))
        ;; start position is the comment symbol itself
        (and (< start pos))))))


(defun f90-ts-in-comment-p ()
  "Non-nil if point is after start of comment.
This excludes OpenMP statements, which look like comments and are currently not
parsed by the treesitter grammar."
  (when-let ((node (treesit-node-at (point))))
    (when (and (f90-ts--node-type-p node "comment")
               (not (f90-ts-openmp-node-p node)))
      (let ((start (treesit-node-start node))
            (pos (point)))
        ;; start position is the comment symbol itself
        (and (< start pos))))))


(defun f90-ts--bol-to-point-blank-p ()
  "Return non-nil if only blank characters exist between BOL and point.
Note that in fortran, a continuation symbol shall not be used on blank lines."
  (looking-back "^\\s-*" (line-beginning-position)))


(defun f90-ts--point-on-empty-line-p ()
  "Return non-nil if point is on an empty line, containing at most blanks."
  (save-excursion
    (beginning-of-line)
    (looking-at "[ \t]*$")))


(defun f90-ts--node-not-number-literal-p (node)
  "Return non-nil if NODE is not a number_literal.

This predicate is necessary, as the :pred in queries does not seem to
work with lambda expressions."
  (not (string= (treesit-node-type node) "number_literal")))


(defun f90-ts--node-is-ampersand-p (node)
  "Check whether NODE is continuation symbol &."
  (f90-ts--node-type-p node "&"))


(defun f90-ts--node-not-comment-p (node)
  "Return non-nil if NODE is not of type comment."
  (not (f90-ts--node-type-p node "comment")))


(defun f90-ts--node-not-comment-or-error-p (node)
  "Return non-nil if NODE is not of type comment or error."
  (not (f90-ts--node-type-p node '("comment" "ERROR"))))


(defun f90-ts-node-overlap-region-p (node start end)
  "Return non-nil if NODE overlaps with region START END."
  (and (< (treesit-node-start node) end)
       (> (treesit-node-end node)   start)))


(defconst f90-ts--node-op-expr-types
  '("logical_expression"
    "math_expression"
    "relational_expression"
    "concatenation_expression"
    "unary_expression")
  "Operator expression types for alignment purposes.
These are required to have a field named operator.  Note that logical and math
expression overlap, as user defined operators are always interpreted as math
expression, even if operating on booleans (for example: .imply.  operator).")


(defun f90-ts--node-is-op-expr-p (node)
  "Return non-nil if NODE is of some expression type."
  (member (treesit-node-type node)
          f90-ts--node-op-expr-types))


;;;-----------------------------------------------------------------------------
;;; auxiliary walk and query functions

(defun f90-ts--comment-matching-rule (node)
  "Return the first rule in `f90-ts-special-comment-rules' which matches.
A rule matches if text of NODE matches the regexp or the predicate of the rule.
NODE is assumed to be of type comment."
  (cl-assert (f90-ts--node-type-p node "comment")
             nil "comment-matching-rule: comment node expected")
  (let ((text (treesit-node-text node t)))
    (seq-find
     (lambda (rule)
       (let ((match (plist-get rule :match)))
         (cond
          ((stringp match)   (string-match-p match text))
          ((functionp match) (funcall match node)))))
     f90-ts-special-comment-rules)))


;; currently not used, but might be useful
(defun f90-ts--search-subtree (root pred &optional start end prune reversed)
  "Collect nodes within subtree of ROOT for which PRED shall return non-nil.
ROOT can be any node and is not necessarily the root node of the tree.
If START and END are non-nil, only visit nodes overlapping that region.
If PRUNE is non-nil, do not descend into children of nodes that satisfy PRED.
If REVERSED is non-nil, return in reversed order."
  (let (nodes)
    (cl-labels
        ((traverse (node)
           (when (or (null start)
                     (null end)
                     (f90-ts-node-overlap-region-p node start end))
             (let ((match (funcall pred node)))
               (when match
                 (push node nodes))
               (unless (and match prune)
                 (mapc #'traverse (treesit-node-children node)))))))
      (traverse root))
    (if reversed
        nodes
      (nreverse nodes))))


;; currently not used, but might be useful
(defun f90-ts--statement-at-node (node)
  "Find the most relevant ancestor node starting at the same position as NODE.
This is done by ascending to parent nodes until start position becomes different
or some ERROR or translation_unit node is encountered."
  ;; ascend as long as parent starts at the same position and is not an ERROR node
  (cl-loop
   for current = node then parent
   for parent = (treesit-node-parent current)
   while (and parent
              (= (treesit-node-start parent)
                 (treesit-node-start current))
              (not (f90-ts--node-type-p parent
                                        '("ERROR" "translation_unit"))))
   finally return current))


(defun f90-ts--siblings-between (node1 node2 &optional named)
  "Return sibling between NODE1 and NODE2, including NODE1 and excluding NODE2.
It is assumed that node1 and node2 are sibling (have the same parent.
If NAMED is non-nil, return only named nodes."
  (cl-assert (treesit-node-eq (treesit-node-parent node1)
                              (treesit-node-parent node2))
             nil
             "node1 and node2 are not siblings, node1=%s, node2=%s" node1 node2)

  (let ((parent (treesit-node-parent node1))
        (ix1 (treesit-node-index node1))
        (ix2 (treesit-node-index node2)))
    (cl-loop for i from ix1 below ix2
             for sib = (treesit-node-child parent i)
             when (or (not named)
                      (treesit-node-check sib 'named))
             collect sib)))


(defun f90-ts--prev-sibling-predicate (node predicate)
  "Find previous sibling of NODE satisfying PREDICATE.
Repeat `treesit-node-prev-sibling' until a suitable sibling is found,
or return nil."
  (cl-loop
   for sibling = (treesit-node-prev-sibling node)
            then (treesit-node-prev-sibling sibling)
   while sibling
   when (funcall predicate sibling) return sibling))


(defun f90-ts--prev-sibling-proper (node)
  "Determine previous \"proper\" sibling of NODE.
Nodes of type comments and ampersand are not considered \"proper\"."
  (f90-ts--prev-sibling-predicate
   node
   (lambda (n)
     (not (f90-ts--node-type-p n '("comment" "&"))))))


(defun f90-ts--previous-stmt-keyword-by-first (first)
  "Return keyword of previous statement.
Use node FIRST which provides the very first leaf node of previous statement.
Auxiliary function for `f90-ts--previous-stmt-keyword' or when
first statement is known."
  ;; block structure statements like if, do, associate etc. can start
  ;; with a label, if a (optional) label is present, skip it and extract
  ;; the keyword node;
  ;; in general, the AST looks like:
  ;;
  ;; (do_loop
  ;;  (block_label_start_expression
  ;;   'label'
  ;;   :)
  ;;  (do_statement do
  ;;  ...))
  ;;
  ;; but if label is a reserved keyword, it becomes
  ;;
  ;; (do_loop
  ;;  (block_label_start_expression
  ;;   'label'
  ;;    keyword
  ;;   :)
  ;;  (do_statement do
  ;;  ...))
  ;;
  ;; in both cases 'label' is an anonymous node;
  ;; in the second case, it has a child,
  ;;
  ;; we want to extract the anonymous node "do" of the statement
  ;; following the block_label_start expression,
  ;; so first check we are within a block_label_start_expression
  (let* ((parent (and first (treesit-node-parent first)))
         (grandparent (and parent (treesit-node-parent parent)))
         (block-label (cond
                       ((and (f90-ts--node-type-p first "label")
                             (f90-ts--node-type-p parent
                                                  "block_label_start_expression"))
                        parent)
                       ((and (f90-ts--node-type-p parent "label")
                             (f90-ts--node-type-p grandparent
                                                  "block_label_start_expression"))
                      grandparent)
                       (t nil))))
    (if block-label
	    (let ((fp-next (treesit-node-next-sibling block-label)))
          ;; next sibling is a statement label, we descend to find
          ;; first leaf
          (cl-loop
           for n = fp-next then child
           for child = (treesit-node-child n 0)
           while child
           finally return n))
      ;; not a label expression, just return first
      first)))


(defun f90-ts--previous-stmt-keyword (node parent)
  "Return the previous statement leaf node.
Use NODE and PARENT to deteremine previous statement or start of
statement in a multiline statement.
Usually some keyword like if, elseif, do, etc. for `f90-ts-prev-stmt-first'.
In case of a block label the first leaf node is the label, not the keyword.
For use as anchor, the label is required.  For use as matcher, we need the
keyword.
Keyword nodes become relevant for incomplete code with ERROR nodes."
  ;; if the statement starts with a block label, then first is unnamed
  ;; node label, and its parent is block_label_start_expression. Its
  ;; next sibling is a keyword like if or do
  (let ((first (f90-ts--previous-stmt-first node parent)))
    (f90-ts--previous-stmt-keyword-by-first first)))


(defun f90-ts--previous-stmt-first (node parent)
  "Return previous statement determined by NODE and PARENT.
First search for any reasonable (leaf) node, which is before current
line, and then go to start of line.  If on a continued line, follow it
to the start of the statement.
If current point is within a continued line, then previous leaf node
belongs to the continued line as well, and previous-stmt return the
node at the start of the continued line.

In order to find the most previous leaf node start at node and ascend
the tree until a previous sibling on a previous line can be found.  Just
taking a sibling of node is not possible, as node might be nil (empty
line), or node is part of an expression tree with deep nesting or
similar.  We really want to go to previous line with a proper node on
it.  Once we have a proper node, descend the previous sibling to further
narrow it down among its children.
Finally return the leaf node at the start of the line.  Follow continued
lines to first line of continued statement.

Ignore nodes which do not satisfy the predicate
`f90-ts--node-not-comment-or-error-p' during ascend or descend,
for example comment nodes."
  (let* ((cur-line (f90-ts--line-number-at-node-or-pos node))
         (predicate #'f90-ts--node-not-comment-or-error-p)
         ;; ascend until a previous ancestor is found
         (prev-sib-of-anc
          (cl-loop for ancestor = (or node parent) then (treesit-node-parent ancestor)
                   while ancestor
                   for relative = (f90-ts--before-child ancestor cur-line predicate)
                   when relative return relative))
         ;; descend prev-sib-of-anc to find the deepest node still before current line
         (prev-descend
          (and prev-sib-of-anc
               (cl-loop for sib = prev-sib-of-anc then next
                        for next = (and (> (treesit-node-child-count sib) 0)
                                        (f90-ts--before-child sib cur-line predicate))
                        ;; if there is a next, continue and shift next to sib
                        ;; with for sib=next in the first line
                        while next
                        finally return sib))))
    ;; take continuation lines into account and go to beginning of statement
    (and prev-descend
         (f90-ts--first-node-of-stmt prev-descend))))


(defun f90-ts--prev-sib-by-parent (parent)
  "Previous sibling based on position of point and PARENT.
Especially for empty line, it often happens that node=nil, but parent is some
relevant node, whose children, which are kind of siblings to nil-node-position,
can be used to determine things like indentation.
For the first sibling itself, we do not exclude ERROR nodes.  Then the
ERROR node is descended (usually just one step) to find a node with relevant
structure type, like subroutine_statement or similar.
Comment nodes and ampersand are ignored"
  (let* ((cur-line (line-number-at-pos))
         (predicate #'f90-ts--node-not-comment-p)
         (psib (f90-ts--before-child parent cur-line predicate)))
    ;; if psib=nil, just return nil
    ;; if psib=ERROR node, descend and try to find some non-error node
    (cl-loop
     for current = psib then child
     for child = (and current (treesit-node-child current 0 t))
     while (and child
                (f90-ts--node-type-p current "ERROR"))
     finally return current)))


(defun f90-ts--nodes-on-prev-lines (nodes cur-line &optional predicate)
  "Filter NODES by PREDICATE and line number.
Accept only NODES which are on a line prior to CUR-LINE.
If PREDICATE is provided, additionally filter by predicate.
For empty NODES, return an empty list."
  (seq-filter
   (lambda (node)
     (and (or (not predicate)
              (funcall predicate node))
          (< (f90-ts--node-line node)
             cur-line)))
   nodes))


(defun f90-ts--before-child (node line predicate)
  "Return child of NODE, which is on a previous LINE and satisfies PREDICATE.
Take the last of all children satisfying this condition."
  (when-let* ((children (treesit-node-children node))
              (children-prev (f90-ts--nodes-on-prev-lines children line predicate)))
    (car (last children-prev))))


(defun f90-ts--first-node-on-line (pos)
  "Return the first node on the line at POS.
Take virtual ampersand nodes into account, these are not returned by
`treesit-node-at' and require extra work.  If the line is empty, return nil."
  (save-excursion
    (goto-char pos)
    (back-to-indentation)
    (let* ((line (line-number-at-pos))
           (on-node (treesit-node-on (point) (point)))
           (at-node (treesit-node-at (point))))
      (cond
       ((and on-node
             (= (point) (treesit-node-start on-node)))
        ;; in some cases, there might be other virtual nodes,
        ;; or treesit-node-on returns a proper node starting at (point),
        ;; walk back as long as start of node does not change
        (cl-loop for node = on-node
                 then (treesit-node-prev-sibling node)
                 while (and node
                            (= (treesit-node-start node) (point)))
                 for last = node ; updates only if while condition is true
                 finally return last))

       ((and at-node
             (= line (f90-ts--node-line at-node)))
        at-node)))))


(defun f90-ts--last-node-on-line (pos)
  "Go to end of line of POS and obtain the node at this end of line position."
  (save-excursion
    (goto-char pos)
    (end-of-line)
    (skip-chars-backward " \t")
    (unless (bolp)
      (when-let ((node (treesit-node-at (point))))
        (when (= (line-number-at-pos pos)
                 (f90-ts--node-line node))
          node)))))


(defun f90-ts--find-first-ampersand (first)
  "Find the first ampersand if at a ampersand-comment*-ampersand sequence.
In continued lines, continuation symbol ampersands appears in
sequences like &, (comment)*, &.  This routines checks whether node
FIRST is any of those ampersand or comment nodes, and returns the first
ampersand node of this sequence.  FIRST is assumed to be the first node
on its line!"
  (when-let ((nprev
              (cond
               ((f90-ts--node-is-ampersand-p first)
                ;; go one step back to first ampersand or sequence
                ;; of comments
                (treesit-node-prev-sibling first))

               ((f90-ts--node-type-p first "comment")
                first)

               (t
                ;; in all other cases, we are not on a continued line
                nil))))
    ;; if necessary skip comments (but only comments) to find the first ampersand,
    ;; if we are in a sequence of comments not being part of a continued line,
    ;; then the final non-comment node is not an ampersand and we return nil
    (cl-loop for node = nprev then (treesit-node-prev-sibling node)
             while (f90-ts--node-type-p node "comment")
             finally return (and (f90-ts--node-is-ampersand-p node)
                                 node))))


(defun f90-ts--line-continued-at-end-p (last pos)
  "Check whether line at POS is continued.
It usually ends in &, but might be followed by a comment.  First check that
there is a next line after current line.
LAST is expected to be the last node on the line, and can be obtained
by `f90-ts--last-node-line'"
  ;; if there is an ampersand (or ampersand (comment)) at end of line but
  ;; no other sibling follows, we are probably at end of file
  (when (treesit-node-next-sibling last)
    (cond
     ((f90-ts--node-is-ampersand-p last)
      t)

     ((f90-ts--node-type-p last "comment")
      ;; if last comment is node, check whether previous one is an ampersand,
      ;; but it must be on the same line
      (let ((prev (treesit-node-prev-sibling last)))
        (and prev
             (f90-ts--node-is-ampersand-p prev)
             (= (line-number-at-pos pos)
                (f90-ts--node-line prev)))))

     (t
      ;; in all other cases, we are not on a continued line
      nil))))


(defun f90-ts--first-line-of-continued-stmt-p (pos)
  "Check whether POS is on the first line of a continued statement.
To this end, check that it does not start with and ampersand, but
is continued at end."
  (when-let ((first-node (f90-ts--first-node-on-line pos))
             (last-node (f90-ts--last-node-on-line pos)))
    (and (not (f90-ts--node-type-p first-node "&"))
         (f90-ts--line-continued-at-end-p last-node pos))))


(defun f90-ts--subsequent-line-of-continued-stmt-p (pos)
  "Check whether line at POS is within a subsequent continued line.
Return nil for the first line of a continued statement or if the
statement is not continued.
Such a subsequent line either has a node \"&\" at start of line, is a comment,
or an empty line. If it is an empty line, it is necessary to look backwards and
forwards and check, whether an ampersand can be found."
  ;; if line is empty, n-first is nil and n-next is on some subsequent
  ;; line; if the line is after some continuation ampersand
  ;; then n-start is either a comment or the second ampersand,
  ;; from which we can go backwards
  (let* ((first-node (f90-ts--first-node-on-line pos))
         (next-node (treesit-node-at pos))
         (start-node (or first-node next-node)))
    (when start-node
      (f90-ts--find-first-ampersand start-node))))


(defun f90-ts--pos-within-continued-stmt-p (pos)
  "Check whether POS is on some line of a continued statement.
This needs to check forward or backward, as first and last line
must also match."
  (or (f90-ts--subsequent-line-of-continued-stmt-p pos)
      (when-let ((last (f90-ts--last-node-on-line pos)))
        (f90-ts--line-continued-at-end-p last pos))))


(defun f90-ts--first-node-of-stmt (node)
  "Return the first node of the statement at which NODE is placed.
Use `f90-ts--first-node-on-line', check for continuation symbol and
if present, further go back, skipping comments and empty lines until
beginning of statement is found."
  (cl-loop
   for namp = node then next-namp
   for first = (progn
                 (f90-ts--first-node-on-line
                  (treesit-node-start namp)))
   for next-namp = (f90-ts--find-first-ampersand first)
   while next-namp
   finally return first))


(defun f90-ts--after-stmt-line1-p (node pos)
  "Check whether position POS is on the next line after NODE.
NODE is assumed to being part of a statement possibly spread over several lines.
Empty lines are automatically skipped as those are not present in the tree."
  ;; strategy: get last node on the same line as NODE, check whether it is &,
  ;; goto next node, which is & on next line and compare with line number at pos;
  ;; note that if "&" is at end of line, then there is always a second "&"
  ;; at beginning of the next non-empty/non-comment line or at EOF,
  ;; hence (treesit-next-sibling last) below can always be executed.
  (when-let* ((cur-line (line-number-at-pos pos))
              (pos-node (treesit-node-start node))
              (last (f90-ts--last-node-on-line pos-node)))
    (when (f90-ts--line-continued-at-end-p last pos-node)
      (let ((nsib (treesit-node-next-sibling last)))
        (and nsib
             (not (< (f90-ts--node-line nsib) cur-line)))))))


(defun f90-ts--indent-pos-at-node (node)
  "Determine indentation position of line where start of NODE is located.
Besides blanks, skip leading ampersands as well.

Note: this can be used as anchor in indentation even within
`treesit-indent-region', which uses buffering of computed (anchor offset)."
  (save-excursion
    (goto-char (treesit-node-start node))
    (beginning-of-line)
    (skip-chars-forward "& \t")
    (point)))


(defun f90-ts--node-at-indent-pos (pos)
  "Determine node at indentation position of line determined by POS."
  (save-excursion
    (goto-char pos)
    (back-to-indentation)
    (treesit-node-at (point))))


(defun f90-ts--node-line (node)
  "Determine line number of start position of NODE."
  (line-number-at-pos (treesit-node-start node)))


(defun f90-ts--node-column (node)
  "Determine column number of start position of NODE."
  (f90-ts--column-number-at-pos (treesit-node-start node)))


(defun f90-ts--column-number-at-pos (pos)
  "Compute column at position POS."
  (save-excursion
    (goto-char pos)
    (current-column)))


(defun f90-ts--indentation-at-pos (pos)
  "Compute indentation of line at POS."
  (save-excursion
    (goto-char pos)
    (current-indentation)))


(defun f90-ts--line-number-at-node-or-pos (node)
  "Return line number of NODE or point.
If NODE is non-nil, return line number at which start position is
located, otherwise return line number of current point position."
  (or (and node (f90-ts--node-line node))
      (line-number-at-pos)))


;;;-----------------------------------------------------------------------------
;;; Font-locking: auxiliary

(defun f90-ts--fontify-comment (node override _start _end &rest _)
  "Fontify NODE assumed to be a comment.
Check whether NODE satisfies a special comment rule, and if it does,
use the face provided by the first matching rule.
If no rule matches, use `font-lock-comment-face'.

Keyword matches from `f90-ts-comment-keyword-regexp' are additionally
highlighted with `font-lock-warning-face' on top of the base face.

Argument OVERRIDE is passed to `treesit-fontify-with-override' for the comment
rule but not for matched keywords, which are enforced with override=t."
  (cl-assert (f90-ts--node-type-p node "comment")
             nil "fontify-comment: comment node expected")
  (let* ((rule (f90-ts--comment-matching-rule node))
         (face (or (and rule (plist-get rule :face))
                   'font-lock-comment-face))
         (start (treesit-node-start node))
         (end   (treesit-node-end node)))

    ;; apply base face to the whole comment node
    (treesit-fontify-with-override start end face override)

    ;; overlay keyword matches on top
    (when f90-ts-comment-keyword-regexp
      (save-excursion
        (goto-char start)
        (cl-loop while (re-search-forward f90-ts-comment-keyword-regexp end t)
                 do (treesit-fontify-with-override
                       (match-beginning 0) (match-end 0)
                       'font-lock-warning-face t))))))


;;;-----------------------------------------------------------------------------
;;; Font-locking: treesitter rules

(defun f90-ts--font-lock-rules-comment ()
  "Font-lock rules for comments."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'comment
   '(;; default comments as well as special comments and openmp
     ;; statements, declared by `f90-ts-special-comment-rules'
     ((comment) @f90-ts--fontify-comment))))


(defun f90-ts--font-lock-rules-intrinsic ()
  "Font-lock rules for Fortran intrinsic functions."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'builtin
   :language 'fortran
   :feature 'builtin
   `((call_expression
      (identifier) @font-lock-builtin-face
      (:pred f90-ts-builtin-function-p @font-lock-builtin-face))
     (subroutine_call
      "call"
      subroutine: (identifier) @font-lock-builtin-face
      (:pred f90-ts-builtin-function-p @font-lock-builtin-face)))))


(defun f90-ts--font-lock-rules-keyword ()
  "Font-lock rules for Fortran keywords."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'keyword
   ;; match type qualifiers/attributes
   '((type_qualifier) @font-lock-keyword-face)

   :language 'fortran
   :feature 'keyword
   '(;; match keywords in select case statements
     ;; (which are not covered by simple keywords below
     (case_statement
      "case"    @font-lock-keyword-face
      (default) @font-lock-keyword-face)
     ;; match keywords in select type statements
     ;; (which are not covered by simple keywords below
     (type_statement
      (default) @font-lock-keyword-face)
     ;; match keywords in select rank statements
     ;; (which are not covered by simple keywords below
     (rank_statement
      (default) @font-lock-keyword-face))

   :language 'fortran
   :feature 'keyword
   ;; "none" is a named node in "implicit none", but an anonymous node
   ;; in "do concurrent(...) default(none)"
   '((implicit_statement
      (none) @font-lock-keyword-face))

   :language 'fortran
   :feature 'keyword
   ;; match keywords exposed by the grammar
   ;; note that this matches anonymous nodes representing the keyword,
   ;; not the keyword text itself, and these nodes are always stored lower-case
   ;; (hence no need to match case insensitive as is necessary with builtins)
   '((["program" "module" "submodule"
       "function" "subroutine" "procedure" "interface"
       "bind" "result" "end" "call"
       "public" "private" "protected" "contains"
       "use" "include" "only" "import"
       "implicit" "none" "external" "intrinsic" "non_intrinsic"
       "pure" "impure" "elemental" "recursive" ; "non_recursive" not yet included in grammar
       "type" "class" "is" "typeof" "classof"
       "if" "then" "else" "elseif" "endif"
       "do" "while"
       "cycle" "exit" "error" "stop" "return" "entry"
       "associate" "block" "critical"
       "enum" "enumeration" "enumerator"
       "where" "elsewhere" "forall" "concurrent"
       "select" "case" "rank" "default"
       "shared" "local" "local_init" "reduce"
       "extends" "abstract"
       "pass" "nopass" "deferred" "non_overridable"
       "operator" "assignment" "generic" "final"
       "allocatable"
       "intent" "in" "out" "inout" "optional"
       "parameter" "save" "target" "pointer" "value"
       "dimension" "codimension" "contiguous" "volatile" "asynchronous"
       "open" "close" "print" "read" "write" "format"
       "inquire" "wait" "backspace" "endfile" "rewind" "flush"
       "nullify" "allocate" "deallocate"
       "sync" "all" "images" "memory"
       "form" "team" "change"
       "lock" "unlock"
       "fail" "image"]
      @font-lock-keyword-face))))


(defun f90-ts--font-lock-rules-preproc ()
  "Font-lock rules for preprocessor directives."
  (treesit-font-lock-rules
;   :language 'fortran
;   :feature 'preproc
;   ;; preprocessor directive keywords as tokens (not entire nodes)
;   '((["#include" "#define" "#if" "#ifdef" "#ifndef" "#endif" "#else" "#elif" "#elifdef"]) @font-lock-preprocessor-face)

   :language 'fortran
   :feature 'preproc
   ;; highlight macro names in definitions
   '((preproc_include
      "#include"             @font-lock-preprocessor-face
      path: (string_literal) @font-lock-string-face)
     (preproc_def
      "#define"            @font-lock-preprocessor-face
      name: (identifier)   @font-lock-constant-face)
     (preproc_function_def
      "#define"            @font-lock-preprocessor-face
      name: (identifier)   @font-lock-function-name-face)
     (preproc_if
      "#if"                @font-lock-preprocessor-face
      "#endif"             @font-lock-preprocessor-face)
     (preproc_ifdef
      "#ifdef"             @font-lock-preprocessor-face
      name: (identifier)   @font-lock-constant-face
      "#endif"             @font-lock-preprocessor-face)
     (preproc_ifdef
      "#ifndef"            @font-lock-preprocessor-face
      name: (identifier)   @font-lock-constant-face
      "#endif"             @font-lock-preprocessor-face)
     (preproc_elif
      "#elif"              @font-lock-preprocessor-face)
     (preproc_elifdef
      "#elifdef"           @font-lock-preprocessor-face
      name: (identifier)   @font-lock-constant-face)
     (preproc_else
      "#else"              @font-lock-preprocessor-face))))


(defun f90-ts--font-lock-rules-prog-mod ()
  "Font-lock rules for program and (sub)modules."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'function
   '((program_statement
      "program"
      (name)                  @font-lock-function-name-face)
     (module_statement
      "module"
      (name)                  @font-lock-function-name-face)
     (submodule_statement
      "submodule"
      ancestor: (module_name
                 (name)       @font-lock-function-name-face)
      (name)                  @font-lock-function-name-face))))


(defun f90-ts--font-lock-rules-type ()
  "Font-lock rules for type declarations."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'type
   ;; match type keywords
   '(["integer"
      "real" "complex" "double" "precision"
      "logical"
      "character"] @font-lock-type-face)

   :language 'fortran
   :feature 'type
   ;; match type keywords
   '(((type_name)                @font-lock-type-face)
     ((derived_type_statement
       base: (base_type_specifier
              (identifier)       @font-lock-type-face)))

     (import_statement
      "import"
      (identifier)               @font-lock-type-face)

     (end_type_statement
      (name)                     @font-lock-type-face)

   ;; special declarations (e.g. within allocate statements)
   ;; TODO: should the grammar use type_name instead of identifier as done elsewhere?
   ((allocate_statement
      type: (identifier)         @font-lock-type-face))
     (type_statement
      type: (identifier)         @font-lock-type-face))))


(defun f90-ts--font-lock-rules-function ()
  "Font-lock rules for functions and subroutines."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'function
   '((subroutine_statement
      name: (name)                 @font-lock-function-name-face)
     (function_statement
      name: (name)                 @font-lock-function-name-face)
     (module_procedure_statement
      name: (name)                 @font-lock-function-name-face)
     (function_result
      (identifier)                 @default)
     (subroutine_call
      subroutine: [
                   ((identifier)   @font-lock-function-name-face)
                   ((derived_type_member_expression
                    [(identifier)
                     (derived_type_member_expression)]
                    "%"
                    (type_member)  @font-lock-function-name-face))
                   ])

     ;; within derived type declarations
     (variable_declaration
      type: (procedure
             "procedure"
             (procedure_interface)        @font-lock-function-name-face)
      ;; is this always a pointer to a procedure?
      declarator: (identifier)            @font-lock-function-name-face)
     (procedure_statement
      declarator: [
                   ((method_name)         @font-lock-function-name-face)
                   ((binding
                     (binding_name
                      [
                       ((identifier)      @font-lock-function-name-face)
                       ((operator
                         (operator_name)  @f90-ts-font-lock-operator-face))
                       ((assignment "="   @f90-ts-font-lock-operator-face))
                       ])
                     (method_name)        @font-lock-function-name-face))
                   ])
     (generic_statement
      declarator: (binding_list
                    (binding_name
                     [
                      ((identifier)      @font-lock-function-name-face)
                      ((operator
                        (operator_name)  @f90-ts-font-lock-operator-face))
                      ((assignment "="   @f90-ts-font-lock-operator-face))
                      ])
                    (method_name)        @font-lock-function-name-face))
     (final_statement
      declarator: (method_name)          @font-lock-function-name-face))))


(defun f90-ts--font-lock-rules-interface ()
  "Font-lock rules for interface blocks."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'function
   '((interface_statement
      "interface"
      (name)                      @font-lock-function-name-face)
     (procedure_statement
      declarator: (method_name)   @font-lock-function-name-face))))


(defun f90-ts--font-lock-rules-end ()
  "Apply font-lock rules for end statements of structures."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'function
   '((end_program_statement
      "end"
      "program"
      (name)       @font-lock-function-name-face)

     (end_module_statement
      "end"
      "module"
      (name)       @font-lock-function-name-face)

     (end_submodule_statement
      "end"
      "submodule"
      (name)       @font-lock-function-name-face)

     (end_function_statement
      "end"
      "function"
      (name)       @font-lock-function-name-face)

     (end_subroutine_statement
      "end"
      "subroutine"
      (name)       @font-lock-function-name-face)

     (end_module_procedure_statement
      "end"
      "procedure"
      (name)       @font-lock-function-name-face)

     (end_interface_statement
      "end"
      "interface"
      (name)       @font-lock-function-name-face))))


(defun f90-ts--font-lock-rules-variable ()
  "Font-lock rules for variables."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'variable
   '(
     ((identifier) @f90-ts-font-lock-special-var-face
      (:pred f90-ts-special-var-p @f90-ts-font-lock-special-var-face)))))


(defun f90-ts--font-lock-rules-value ()
  "Font-lock rules for numbers, strings, booleans etc."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'string
   '(((string_literal) @font-lock-string-face)
     (preproc_include path: (string_literal) @font-lock-string-face))

   :language 'fortran
   :feature 'number
   '(((number_literal) @font-lock-number-face)
     ((complex_literal) @font-lock-number-face))

   :language 'fortran
   :feature 'constant
   '(((boolean_literal) @font-lock-constant-face)
     ((null_literal) @font-lock-constant-face)
     (statement_label) @font-lock-constant-face)))


(defun f90-ts--font-lock-rules-delimiter ()
  "Font-lock rules for brackets and delimiters."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'bracket
   '(["(" ")" "[" "]" "(/" "/)"] @f90-ts-font-lock-bracket-face)

   :language 'fortran
   :feature 'delimiter
   '(["," ":" ";" "::" "=>" "&"] @f90-ts-font-lock-delimiter-face)))


(defun f90-ts--font-lock-rules-operator ()
  "Font-lock rules for operators."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'operator
   '((logical_expression       operator: _  @f90-ts-font-lock-operator-face)
     (math_expression          operator: _  @f90-ts-font-lock-operator-face)
     (relational_expression    operator: _  @f90-ts-font-lock-operator-face)
     (concatenation_expression operator: _  @f90-ts-font-lock-operator-face)
     ("="                                   @f90-ts-font-lock-operator-face)
     ("%"                                   @f90-ts-font-lock-operator-face)
     ;; unary: only match user_defined_operator nodes with a non-number_literal argument
     ;; (note: :pred does not seem to accept lambda expressions)
     (unary_expression
      operator: (user_defined_operator) @f90-ts-font-lock-operator-face)
     ((unary_expression
      operator: _ @f90-ts-font-lock-operator-face
      argument: (_) @_unary_arg
      (:pred f90-ts--node-not-number-literal-p @_unary_arg))))))


(defvar f90-ts-font-lock-rules
  (list
   (f90-ts--font-lock-rules-comment)
   (f90-ts--font-lock-rules-intrinsic)
   (f90-ts--font-lock-rules-keyword)
   (f90-ts--font-lock-rules-preproc)
   (f90-ts--font-lock-rules-prog-mod)
   (f90-ts--font-lock-rules-type)
   (f90-ts--font-lock-rules-function)
   (f90-ts--font-lock-rules-interface)
   (f90-ts--font-lock-rules-end)
   (f90-ts--font-lock-rules-operator)
   (f90-ts--font-lock-rules-variable)
   (f90-ts--font-lock-rules-value)
   (f90-ts--font-lock-rules-delimiter))
  "List of font-lock rules.")


;;;-----------------------------------------------------------------------------
;;; Xref backend

(defconst f90-ts--xref-def-query
  "(program (program_statement (name) @def))
   (module (module_statement (name) @def))
   (submodule (submodule_statement (name) @def))
   (subroutine (subroutine_statement name: (name) @def))
   (function (function_statement name: (name) @def))
   (module_procedure_statement name: (name) @def)
   (interface_statement (name) @def)
   (interface_statement (operator (operator_name) @def))
   (interface_statement (assignment \"=\" @def))
   (derived_type_definition (derived_type_statement (type_name) @def))
   (preproc_def name: (identifier) @def)
   (preproc_function_def name: (identifier) @def)"
  "Query for xref for finding definitions of symbol captured as @def.

Each clause matches a syntactic construct that introduces a named
entity (e.g. subroutine, function, module, derived type, or macro)
and binds the relevant node to the capture name @def.

The resulting captures are consumed by
`f90-ts--xref-find-definitions' to locate definition positions.")

(defconst f90-ts--xref-ref-query
  "[(identifier)
    (name)
    (type_name)
    (type_member)
    (method_name)
    (operator_name)
    (user_defined_operator)
    (procedure_interface)
   ] @ref"
  "Query for xref for finding references of symbols captured by @ref.

The query is very general and might find incorrect references.  There is
also no consideration for the scope of a symbol.")

(defun f90-ts--xref-find-definitions (identifier)
  "Find all definitions of IDENTIFIER in the current buffer.

IDENTIFIER is a string representing the symbol to search for.
The search is case-insensitive, reflecting Fortran's
case-insensitive semantics.

This function:
1. Executes `f90-ts--xref-def-query' against the current buffer's tree-sitter
   syntax tree.
2. Filters captured nodes whose text matches IDENTIFIER.
3. Converts matching nodes into xref-item objects.

Returns a list of xref-item instances suitable for consumption by
`xref-backend-definitions'."
  (let* ((id-lowcase (downcase identifier))
         (scope (treesit-buffer-root-node))
         (id-nodes (treesit-query-capture scope
                                          f90-ts--xref-def-query
                                          nil nil t)))
    (cl-loop for node in id-nodes
             when (string= (downcase (treesit-node-text node t)) id-lowcase)
             collect (f90-ts--xref-make-item node))))


(defun f90-ts--xref-find-references (identifier)
  "Find all references to IDENTIFIER in the current buffer.

IDENTIFIER is a string naming the symbol to search for.
The search is case-insensitive.

This function performs a broad tree-sitter query that captures all
identifier nodes, then filters them by textual equality with
IDENTIFIER.

Note that this approach is purely syntactic and does not account
for scope, shadowing, or semantic resolution.

Returns a list of xref-item instances suitable for
`xref-backend-references'."
  (let* ((id-lowcase (downcase identifier))
         (scope (treesit-buffer-root-node))
         (id-nodes (treesit-query-capture scope
                                          f90-ts--xref-ref-query
                                          nil nil t)))
    (cl-loop for node in id-nodes
             when (string= (downcase (treesit-node-text node t)) id-lowcase)
             collect (f90-ts--xref-make-item node))))


(defun f90-ts--xref-make-item (node)
  "Construct an xref-item from a tree-sitter NODE.

NODE is expected to represent an identifier or definition site.
The function extracts:

- A human-readable display string consisting of the full line containing NODE.
- A buffer location corresponding to the start of NODE.

The resulting xref-item can be used by xref commands to display and navigate
search results."
  (let ((start (treesit-node-start node)))
    (xref-make
     (save-excursion
       (goto-char start)
       (string-trim (buffer-substring-no-properties
                     (line-beginning-position)
                     (line-end-position))))
     (xref-make-buffer-location (current-buffer) start))))


(cl-defmethod xref-backend-identifier-at-point ((_backend (eql f90-ts)))
  "Return the identifier at point for the f90-ts backend.

This method is invoked by xref to determine the default symbol
under the cursor when performing operations like
`xref-find-definitions'.

It uses `thing-at-point' with the symbol type and returns the
result as a string, or nil if no symbol is found."
  (thing-at-point 'symbol t))


(cl-defmethod xref-backend-identifier-completion-table ((_backend (eql f90-ts)))
  "Return a completion table of identifiers in the current buffer.

This method provides candidates for identifier completion in xref commands.
It collects all identifier nodes from the tree-sitter syntax tree and returns
their textual representations.
Currently only named nodes with type \"identifier\" are captured.

Duplicates are not explicitly removed, so callers may wish to handle
deduplication if necessary."
  (let ((id-nodes (treesit-query-capture
                   (treesit-buffer-root-node)
                   '((identifier) @id)
                   nil nil t)))
    (cl-loop for node in id-nodes
             collect (treesit-node-text node t))))


(cl-defmethod xref-backend-definitions ((_backend (eql f90-ts)) identifier)
  "Return definition locations for IDENTIFIER using the f90-ts backend.

Uses `f90-ts--xref-find-definitions', which performs a buffer-local search for
matching definition nodes."
  (f90-ts--xref-find-definitions identifier))


(cl-defmethod xref-backend-references ((_backend (eql f90-ts)) identifier)
  "Return reference locations for IDENTIFIER using the f90-ts backend.

Uses `f90-ts--xref-find-references', which performs a syntactic search over
identifier nodes in the current buffer."
  (f90-ts--xref-find-references identifier))


(cl-defmethod xref-backend-apropos ((_backend (eql f90-ts)) pattern)
  "Return all identifiers matching regexp PATTERN in the current buffer.

This implementation performs a tree-sitter query over all identifier
nodes and returns those whose textual representation matches PATTERN.

The match is case-insensitive, following Fortran conventions."
  (let ((case-fold-search t))
    (cl-loop for node
             in (treesit-query-capture (treesit-buffer-root-node)
                                       '((identifier) @id)
                                       nil nil t)
             for text = (buffer-substring-no-properties
                         (treesit-node-start node)
                         (treesit-node-end node))
             when (string-match-p pattern text)
             collect (f90-ts--xref-make-item node))))


(defun f90-ts-xref-backend ()
  "Return the symbol identifying the f90-ts xref backend.
Return f90-ts backend unless a higher-level backend is active.

This function is intended to be added to
`xref-backend-functions'.  When invoked by xref's backend
discovery mechanism, it signals that the current buffer should
use the f90-ts backend by returning the symbol f90-ts.

Because this function is typically installed buffer-locally, it
activates the backend only for buffers using `f90-ts-mode'."
  (cond
   ;; prefer LSP and eglot if active
   ((bound-and-true-p lsp-mode) nil)
   ((bound-and-true-p eglot--managed-mode) nil)

   ;; prefer etags if TAGS table exists
   ((and tags-file-name (file-exists-p tags-file-name)) nil)

   ;; otherwise use the backend provided here
   (t 'f90-ts)))


;;;-----------------------------------------------------------------------------
;;; Indentation

(defvar-local f90-ts--align-continued-variant-tab nil
  "Current variant for indentation.
If nil use region variant, otherwise use stored tab variant.
This is also used for deciding whether `treesit-indent-region' is at work,
in which case computed (anchor offset) pairs need to be cached for continued
lines, see `f90-ts--continued-line-cache'.")


(defvar-local f90-ts--indent-cache nil
  "Current indent cache vector:
[node parent child0 psibp pstmt-1 pstmt-k].
Slots 2+ are lazily filled.
Value `unset' means not yet computed.
Value nil means that this node does not exist.  For example, on empty
lines, the node itself is nil.")


(defconst f90-ts--indent-cache-size 8
  "Fixed size for `f90-ts--indent-cache'.")


;; slot indices of indent cache
;; nodes
(defconst f90-ts--indent-slot-node               0)
(defconst f90-ts--indent-slot-parent             1)
(defconst f90-ts--indent-slot-child0             2)
(defconst f90-ts--indent-slot-prev-sib-by-parent 3)
(defconst f90-ts--indent-slot-prev-stmt-first    4)
(defconst f90-ts--indent-slot-prev-stmt-keyword  5)
;; anchor and/or offset data
;; note: matcher or anchor can sometimes determine anchor/offset
;; in more complex rules, like for continued lines, and it is not
;; possible to pass any results from matcher to anchor to offset
;; in simple indent rules machinery
(defconst f90-ts--indent-slot-anchor             6)
(defconst f90-ts--indent-slot-offset             7)


(defmacro f90-ts--indent-with-cache (slot query)
  "Return cache value at SLOT if value is present.
If SLOT is not populated, compute value using QUERY, store the result and
return it."
  `(let ((val (aref f90-ts--indent-cache ,slot)))
     (if (eq val 'unset)
         (let ((result ,query))
           (aset f90-ts--indent-cache ,slot result)
           result)
       val)))


(defun f90-ts--indent-cached-node ()
  "Return cached node at index 0."
  (and f90-ts--indent-cache
       (aref f90-ts--indent-cache f90-ts--indent-slot-node)))


(defun f90-ts--indent-cached-parent ()
  "Return cached parent at index 0."
  (and f90-ts--indent-cache
       (aref f90-ts--indent-cache f90-ts--indent-slot-parent)))


(defun f90-ts--indent-create-cache (node parent)
  "Create cache for NODE and PARENT for indentation rules."
  (setq f90-ts--indent-cache (make-vector f90-ts--indent-cache-size 'unset))
  (aset f90-ts--indent-cache f90-ts--indent-slot-node   node)
  (aset f90-ts--indent-cache f90-ts--indent-slot-parent parent)
  f90-ts--indent-cache)


(defun f90-ts--indent-child0 ()
  "Return first named child of node.
Use cached value or compute using cached node."
  (f90-ts--indent-with-cache
   f90-ts--indent-slot-child0
   (let ((node (f90-ts--indent-cached-node)))
     (and node (treesit-node-child node 0 t)))))


(defun f90-ts--indent-prev-sib-by-parent ()
  "Return result of `f90-ts--prev-sib-by-parent' for cached node and parent.
Use cached value or compute using cached parent."
  (f90-ts--indent-with-cache
   f90-ts--indent-slot-prev-sib-by-parent
   (let ((parent (aref f90-ts--indent-cache f90-ts--indent-slot-parent)))
     (and parent
          (f90-ts--prev-sib-by-parent parent)))))


(defun f90-ts--indent-prev-stmt-first ()
  "Return result of `f90-ts--previous-stmt-first' for cached node and parent.
Use cached value or compute using cached node and parent."
  (f90-ts--indent-with-cache
   f90-ts--indent-slot-prev-stmt-first
   (let ((node   (f90-ts--indent-cached-node))
         (parent (f90-ts--indent-cached-parent)))
     (f90-ts--previous-stmt-first node parent))))


(defun f90-ts--indent-prev-stmt-keyword ()
  "Return result of `f90-ts--previous-stmt-keyword' for cached node and parent.
Use cached value or compute using cached node and parent."
  (f90-ts--indent-with-cache
   f90-ts--indent-slot-prev-stmt-keyword
   (let ((pstmt-1 (f90-ts--indent-prev-stmt-first)))
     (f90-ts--previous-stmt-keyword-by-first pstmt-1))))


(defun f90-ts--indent-anchor-cache (anchor)
  "Store ANCHOR in cache."
  (aset f90-ts--indent-cache
        f90-ts--indent-slot-anchor
        anchor))


(defun f90-ts--indent-offset-cache (offset)
  "Store OFFSET in cache."
  (aset f90-ts--indent-cache
        f90-ts--indent-slot-offset
        offset))


(defun f90-ts--indent-cached-anchor ()
  "Return cached anchor."
  (and f90-ts--indent-cache
       (aref f90-ts--indent-cache
             f90-ts--indent-slot-anchor)))


(defun f90-ts--indent-cached-offset ()
  "Return cached offset."
  (and f90-ts--indent-cache
       (aref f90-ts--indent-cache
             f90-ts--indent-slot-offset)))


;;++++++++++++++

(defvar-local f90-ts--continued-line-cache nil
  "Cache for continued-line anchor indentation.
The cache is an alist with entries (LINE . (BOL-COL DELTA))
for already indented lines of a continued statement.

For alignment operations, we need node column numbers of nodes on
previously (already indented) lines to select the proper one.
The cache is required for `indent-region' operations, which work in a
batch mode.  If a previous line has not already been flushed, which is
the default case, we need to compute the column number ourselves after
not-yet-applied indentation.  To this end, we store the computed delta
in the cache.
Moreover, we also store BOL-COL to detect, whether internal indentation
buffer of `treesit-indent-region' has already been flushed for a line.
Except for the first line, we can compute the indentation delta and
cache it.  For the first line, the delta is not known and initially
stored as DELTA=0. Once we detect a flush using cached column at bol,
we can compute the delta and add to all cached lines.  This is necessary
to have consistent indentation across all previous lines

As mentioned above, the cache is an alist (LINE . (BOL-COL DELTA)),
mapping buffer LINE numbers to BOL-COL and DELTA, where:
  BOL-COL: indentation column at cache time, used as flush detector:
           if current indentation at line == BOL-COL, line is not yet
           flushed
  DELTA:   delta of original to new indentation, if line is not
           flushed, then the column after applying indentation is
           column number of node + DELTA,
           and if the line has been flushed, it is just current node
           column

The first line of the statement initially is stored with DELTA=0 and
current BOL-COL.  For each new line, the current indentation of the
first line is checked and if a buffer flush is detected, the applied
delta is computed and added to the delta of all subsequent cached
lines.

The state of `f90-ts--align-continued-variant-tab' is used to decide
whether `indent-region' or a line variant is in use.  The cache is
required only if `indent-region' with buffering is done.")


(defun f90-ts--continued-line-cache-reset ()
  "Reset the continued-line indentation cache."
  (setq f90-ts--continued-line-cache nil))


(defun f90-ts--continued-line-cache-put-first (bol)
  "Store a cache entry for the first line of a continued statement.
BOL is the beginning of that line.  Always store DELTA=0.
If a flush is detected (actual BOL is different from cached BOL),
the DELTA is computed and added to all other cached line."
  (f90-ts--continued-line-cache-reset)
  (unless f90-ts--align-continued-variant-tab
    (let* ((bol-col (save-excursion
                      (goto-char bol)
                      (current-indentation)))
           (line (line-number-at-pos bol)))
      (setq f90-ts--continued-line-cache
            (list (cons line (list bol-col 0)))))))


(defun f90-ts--continued-line-cache-put-subsequent (bol anchor offset)
  "Compute and store the indent delta for a subsequent line at BOL.
ANCHOR is the anchor position returned by the anchor function.
OFFSET is the offset from that anchor.
Resolves delta via the anchor's cache entry:
  delta = delta-at-anchor-line + OFFSET"
  (unless f90-ts--align-continued-variant-tab
    (let* ((anchor-line (line-number-at-pos anchor))
           (anchor-col (f90-ts--column-number-at-pos anchor))
           (anchor-entry (cdr (assq anchor-line f90-ts--continued-line-cache)))
           (anchor-delta (if anchor-entry (cadr anchor-entry) 0))
           (bol-current  (f90-ts--indentation-at-pos bol))
           (bol-new (+ anchor-col anchor-delta offset))
           (delta (- bol-new bol-current))
           (line (line-number-at-pos bol)))
      (push (cons line (list bol-current delta))
            f90-ts--continued-line-cache))))


(defun f90-ts--continued-line-cache-get-first ()
  "Find entry for first line (smallest line number) in the cache.
Cache is reverese ordered, so we can simply return the last entry."
  ;; cache is constructed by push, the last entry is the first line
  (car (last f90-ts--continued-line-cache)))
  ;; (cl-loop for line-entry in f90-ts--continued-line-cache
  ;;          for line-min = line-entry then (if (< (car line-entry) (car line-min))
  ;;                                             line-entry
  ;;                                           line-min)
  ;;          finally return line-min)


(defun f90-ts--continued-line-cache-update (first-pos)
  "Check whether first line at FIRST-POS has been flush.
This is the case if current bol and cached bol are different.
If it has, update the entry and apply delta to all other cached lines.
Argument FIRST-POS is used to jump to this line efficiently (jumping
to a line is more expensive)."
  (unless f90-ts--align-continued-variant-tab
    (let* ((first (f90-ts--continued-line-cache-get-first))
           (first-line (car first))
           (first-bol-col (cadr first))
           (first-bol-current (f90-ts--indentation-at-pos first-pos))
           (first-delta (- first-bol-current first-bol-col)))
      ;; indentation of first line has been flushed, add delta to all
      ;; other lines
      (when (/= first-bol-col first-bol-current)
        (setq f90-ts--continued-line-cache
              (seq-map (lambda (entry)
                         (let ((line (car entry))
                               (bol-col (cadr entry))
                               (delta (caddr entry)))
                           (cons line
                                 (if (= line first-line)
                                     (list first-bol-current 0)
                                   (list bol-col (+ delta first-delta))))))
                       f90-ts--continued-line-cache))))))


(defun f90-ts--continued-line-cache-get-col (node)
  "Return the final column of NODE in a continued statement.
NODE is a potential anchor on some previous line, for which indentation
has already been computed.
Lookup the cache for the line node is placed on.  If current and cached
indentation is equal, then apply cached delta to current column,
otherwise return column as is."
  (let* ((pos (treesit-node-start node))
         (col (f90-ts--column-number-at-pos pos)))
    (if f90-ts--align-continued-variant-tab
        ;; line based indentation, no caching
        col
      (let* ((line (f90-ts--node-line node))
             (entry (cdr (assq line f90-ts--continued-line-cache)))
             (delta (cadr entry))
             (bol-col (car entry))
             (bol-current (f90-ts--indentation-at-pos pos)))

        ;;(f90-ts-log-msg :cachecol "line, entry, delta = %s, %s, %s" line entry delta)
        ;;(f90-ts-log-msg :cachecol "bol col, current = %s, %s" bol-col bol-current)

        (cl-assert entry nil "no entry for line in cache, line=%s, cache=%s" line f90-ts--continued-line-cache)
        (if (= bol-col bol-current)
            ;; not yet flushed
            (+ col delta)
          col)))))


;;++++++++++++++
;; matchers

(defun f90-ts--populate-cache (node parent _bol &rest _)
  "Always fail, but prepare the indent cache.
This dummy matcher should be the very first rule to be executed to reset the
cache for a new indentation run.
The cache stores NODE and PARENT and prepares further internal values."
  (f90-ts--indent-create-cache node parent)
  nil)


(defun f90-ts--continued-line-cache-start (node _parent bol &rest _)
  "Always fail, but prepare the continued line cache.
This dummy matcher is used for continued lines and required in `indent-region'
operations to take internal buffering in `treesit-indent-region' into account.
It uses NODE and BOL to determine whether it is on the first line of a
continued statement."
  (when (and node
             (f90-ts--first-line-of-continued-stmt-p bol))
    (f90-ts--continued-line-cache-put-first bol))
  ;; always fail
  nil)


(defun f90-ts--continued-subsequent-line-is (node parent bol &rest _)
  "Succeed if on some continued statement line.
NODE, PARENT and BOL are used to determine, whether position is at a continued
line.  The first statement line itself is not matched."
  (cond
   (node
    ;; if node is not nil, then there are nodes on the line
    (f90-ts--subsequent-line-of-continued-stmt-p bol))

   (parent
    ;; node=nil but parent is a proper node, then we are probably on an empty line
    (when-let ((psibp (f90-ts--indent-prev-sib-by-parent)))
      ;; prev-sib-by-parent already excludes comment node, hence we can directly
      ;; check whether there is an ampersand
      (f90-ts--node-type-p psibp "&")))))


(defun f90-ts--openmp-comment-is (node _parent _bol &rest _)
  "Succeed if NODE is an OpenMP comment."
  (and (f90-ts--node-type-p node "comment")
       (f90-ts-openmp-node-p node)))


(defun f90-ts--preproc-node-is (node _parent _bol &rest _)
  "Succeed if NODE a fortran preprocessor statement."
  (and node (f90-ts-preproc-node-p node)))


(defun f90-ts--preproc-at-toplevel-is (_node parent _bol &rest _)
  "Succeed if PARENT is a toplevel preprocessor node.
It is a toplevel node if its first non-preprocessor ancestor is a toplevel
node (like program, module, etc.)."
  ;; Content inside preprocessor:
  ;; - Search up the tree for the first "Ancestor" that is NOT a
  ;;   preprocessor node.
  ;; - If that ancestor is a module or program -> toplevel indent
  (and parent
       (f90-ts-preproc-node-p parent)
       (let ((ancestor (treesit-parent-until
                        parent
                        (lambda (n)
                          (not (f90-ts-preproc-node-p n))))))
         (and ancestor
              (string-match-p "module\\|program"
                              (treesit-node-type ancestor))))))


(defun f90-ts--cache-anchor-offset (node parent bol anchor offset)
  "Cache ANCHOR and OFFSET.
Always cache these vaues in the indent cache.
If the line is also within a continued statement, then cache the anchor-offset
pair in the continued line cache as well.  Use NODE PARENT and BOL to
determine, whether this is a continued line."
  (f90-ts--indent-anchor-cache anchor)
  (f90-ts--indent-offset-cache offset)
  ;; when within continued line statement, then cache anchor offset
  (when (f90-ts--continued-subsequent-line-is node parent bol)
    (f90-ts--continued-line-cache-put-subsequent
     bol anchor offset)))


(defun f90-ts--special-comment-is (node parent bol &rest _)
  "Matcher for special comment indentation.
If NODE matches a rule in `f90-ts-special-comment-rules' with a
non-indented indent style, cache the anchor and offset and return
non-nil to signal a match.
If indent style is column-0, use BOL to determine column-0 anchor.
If indent style is context, use PARENT as anchor.
If indent styoe is indented, indent like code.  Do not match here,
but instead let other rules handle it."

  ;; Note: if this matcher signals match and is within a continued
  ;; line, then indentation (anchor offset) needs to be cached in the
  ;; continued line cache as well, using:
  ;;
  ;;(when (f90-ts--continued-subsequent-line-is node parent bol)
  ;;  (f90-ts--continued-line-cache-put-subsequent
  ;;   bol anchor 0))

  (when (f90-ts--node-type-p node "comment")
    (when-let* ((rule (f90-ts--comment-matching-rule node))
                (indent (plist-get rule :indent)))
      ;; indented variant is handled like normal code
      (pcase indent
        ('column-0
         (let ((anchor (save-excursion
                         (goto-char bol)
                         (line-beginning-position))))
           (f90-ts--cache-anchor-offset node parent bol anchor 0)
           ;; signal match
           t))

        ('context
         ;; special comment indentation within continued lines does not seem
         ;; to make much sense except for column-0
         (unless (f90-ts--continued-subsequent-line-is node parent bol)
           (let ((anchor (treesit-node-start parent)))
             (f90-ts--indent-anchor-cache anchor)
             (f90-ts--indent-offset-cache 0))
           ;; signal match
           t))

        (_
         ;; signal no match
         nil)))))


(defun f90-ts--comment-region-is (node parent bol &rest _)
  "Succeed if NODE is a comment following another comment of the same kind.
Comments are classified by rules in `f90-ts-special-comment-rules' (including
both matching none=default comment).  The operation requires PARENT and BOL
for possible caching of anchor and offset values."
  (when (f90-ts--node-type-p node "comment")
    (when-let* ((prev-sib (treesit-node-prev-sibling node))
                (prev-line (f90-ts--first-node-on-line
                            (treesit-node-start prev-sib))))
      (when (and (f90-ts--node-type-p prev-line "comment")
                 (eq (f90-ts--comment-matching-rule node)
                     (f90-ts--comment-matching-rule prev-line)))
        (let ((anchor (treesit-node-start prev-line)))
          (f90-ts--cache-anchor-offset node parent bol anchor 0)
          ;; signal match
          t)))))


(defun f90-ts--n-p-pstmtk (type-n type-p type-pstmtk)
  "Succeed if types of nodes match provided types.
TYPE-N, TYPE-P and TYPE-PSTMTK are expected to be regular expressions
or nil.  If nil, everything is matched, hence the type of the corresponding
node is ignored.
TYPE-N is matched against type of (cached) node,
TYPE-P is matched against type of (cached) parent and
TYPE-PSTMTK is matched against type of (cached) pstmtk, which is
the previous statement keyword node."
  (lambda (node parent _bol &rest _)
    (let ((pstmt-k (f90-ts--indent-prev-stmt-keyword)))
      (and (f90-ts--node-type-match-p node type-n)
           (f90-ts--node-type-match-p parent type-p)
           (f90-ts--node-type-match-p pstmt-k type-pstmtk)))))


(defun f90-ts--n-p-ch-psibp (type-n type-p type-ch type-psibp)
  "Succeed if types of nodes match provided types.
TYPE-N, TYPE-P TYPE-CH and TYPE-PSIBP are expected to be regular expressions
or nil.  If nil, everything is matched, hence the type of the corresponding
node is ignored.
TYPE-N is matched against type of (cached) node,
TYPE-P is matched against type of (cached) parent,
TYPE-CH is matched against type of (cached) first child of node and
TYPE-PSIBP is matched against type of (cached) previous sibling by parent."
  (lambda (node parent _bol &rest _)
    (let ((child0 (f90-ts--indent-child0))
          (psibp (f90-ts--indent-prev-sib-by-parent)))
      (and (f90-ts--node-type-match-p node type-n)
           (f90-ts--node-type-match-p parent type-p)
           (f90-ts--node-type-match-p child0 type-ch)
           (f90-ts--node-type-match-p psibp type-psibp)))))


;;++++++++++++++
;; anchors

(defun f90-ts--previous-stmt-anchor (_node _parent bol &rest _rest)
  "Return anchor at previous statements indentation or BOL.
If no previous statement can be found (for example at start of buffer),
then BOL is returned as anchor position."
  (if-let ((pstmt-1 (f90-ts--indent-prev-stmt-first)))
      (f90-ts--indent-pos-at-node pstmt-1)
    bol))


(defun f90-ts--catch-all-anchor (node parent bol &rest _rest)
  "Provide a fallback anchor for the catch-all case.
Use NODE and PARENT to select a relevant node to align.  Use BOL if no relevant
node was found.
This applies if some rule is missing, but also if we just want to indent
with the previous relevant line."
  ;; node is nil if on an empty line, thus we should use parent to
  ;; find a meaningful previous "sibling" of node
  (let* ((psibp (f90-ts--indent-prev-sib-by-parent))
         (pstmt-1 (f90-ts--indent-prev-stmt-first))
         (node-sel (or pstmt-1
                       psibp
                       parent
                       node)))
    (if node-sel
        (f90-ts--indent-pos-at-node node-sel)
      bol)))


(defun f90-ts--cached-anchor (_node _parent _bol &rest _rest)
  "Return previously determined cached anchor.
This function requires that the succeeding matcher has computed and stored the
anchor (and possibly offset)."
  (f90-ts--indent-cached-anchor))


;;++++++++++++++
;; offset functions: general

;; We cannot directly write (defun f90-ts--minus-offset (offset) ...)
;; and use it in indent rules with the desired offset value like
;; f90-ts-indent-block, as this bakes the current value into the rule,
;; and makes it immune to later changes.
(defun f90-ts--minus-block-offset (_node _parent _bol &rest _rest)
  "Return the offset value minus `f90-ts-indent-block' unconditionally."
  (- f90-ts-indent-block))


(defun f90-ts--toplevel-offset (_node parent _bol &rest _rest)
  "Return offset for stuff right below top level nodes.
If inside module, submodule or program then return `f90-ts-indent-toplevel',
otherwise return `f90-ts-indent-contain'.
Deciding which of the two cases is present requires to access grandparent as
well as grand-grandparent, which are obtained via PARENT."
  (let* ((grandparent (treesit-node-parent parent))
         (ggparent    (and grandparent (treesit-node-parent grandparent))))
    ;; before 'contains' statement, grandparent is translation_unit,
    ;; after 'contains' it is module or program
    (if (or (f90-ts--node-type-p grandparent '("module" "submodule" "program" "translation_unit"))
            (and (f90-ts--node-type-p grandparent "ERROR")
                 (f90-ts--node-type-p ggparent "translation_unit")))
        f90-ts-indent-toplevel
      f90-ts-indent-contain)))


(defun f90-ts--cached-offset (_node _parent _bol &rest _rest)
  "Return previously computed cached offset.
This function requires that the offset was computed and stored by the
succeeding matcher or the corresponding anchor."
  (f90-ts--indent-cached-offset))


;;++++++++++++++
;; lists on continued lines: auxiliary functions

(defun f90-ts--align-node-symbol (node)
  "Return a symbol for NODE to group and select nodes for alignment selection.
Nodes for alignment are mostly selected among nodes with the same symbol.
If NODE is nil return nil."
  (when node
    (cond
     ((f90-ts--node-type-p node "ERROR")
      'error)

     ((f90-ts--node-type-p node "comment")
      'comment)

     ((f90-ts--node-type-p node "unary_expression")
      ;; is this the right approach and symbol?
      ;; (not that of unary expressions, node is not the operator
      ;; but the unary_expression node itself)
      'operator-unary)

     ((string= (treesit-node-field-name node) "operator")
      (let* ((parent (treesit-node-parent node))
             (type (and parent (treesit-node-type parent))))
      (pcase type
        ("logical_expression"        'operator-logical)
        ("math_expression"           'operator-math)
        ("relational_expression"     'operator-relation)
        ;; map concatenation to math_expression, as user defined
        ;; operators are also handled by that way
        ("concatentation_expression" 'operator-math)
        ;("unary_expression"          'operator-unary) ; can this happen here
        (_                           'operator) ; anything still missing?
        )))

     ((f90-ts--node-type-p node "&")
      ;; text is not always "&" (like virtual ampersand at beginning of line)
      'ampersand)

     (t
      (let ((text (treesit-node-text node)))
        (pcase text
          ((or "(" ")" "[" "]" "(/" "/)")
           'parenthesis)
          (","  'comma)
          ("&"  'ampersand)
          ("=>" 'associate)
          ("="  'assignment)
          ;; default: argument for anything else (this is probably a named node
          ;; of type identifier, number_literal, call_expression etc.
          (_    'named)))))))


(defun f90-ts--align-list-location (node)
  "Determine position related values for node.
These are position (start of node or point), column at position, line number
and symbol type at point (for deciding where to align).  If NODE is nil,
then no relevant node is at point and point position is used instead.
This is important for handling empty lines.
The data is returned as an alist with keys `node', `pos', `col', `line'
and `nsym'."
  (if node
      (list (cons 'node node)
            (cons 'pos  (treesit-node-start node))
            (cons 'col  (f90-ts--node-column node))
            (cons 'line (f90-ts--node-line node))
            ;; decide which kind of (named or anonymous) nodes to filter
            ;; (argument, parentheses, comma, ampersend, etc)
            (cons 'nsym (f90-ts--align-node-symbol node)))
    (list (cons 'node nil)
          (cons 'pos  (point))
          (cons 'col  (f90-ts--column-number-at-pos (point)))
          (cons 'line (line-number-at-pos))
          (cons 'nsym nil))))


(defun f90-ts--node-op-expr-chain-root (node)
  "Return the topmost ancestor of NODE in a chain of operator expression nodes.
Relevant type are listed in `f90-ts--node-op-expr-types'.

Intended for associative expressions represented as binarized trees,
where repeated nesting of the same node type encodes a chain.  For
example, for a logical/math/relational etc. expression chain like
   (binary_expression
    left:
     (unary_expression
     argument:
      (binary_expression
       left:
        (binary_expression
         left: ...
         right: ...
        )
       right: ...
      ))
    right: ...)
the function returns the outermost expression node."
  (treesit-parent-while
   node
   #'f90-ts--node-is-op-expr-p))


;;++++++++++++++
;; list context: association_list

(defun f90-ts--align-list-expand-assoc (nodes)
  "Replace association nodes in list NODES by their first two children.
These are field \"name\" and \"=>\".  There is no handling of the selector
part currently.  Skip continuation symbols, which might be between
\"name\" and arrow \"=>\"."
  (seq-mapcat
   (lambda (node)
     (if (f90-ts--node-type-p node "association")
         (let* ((children (treesit-node-children node))
                (first (car children))
                (arrow (seq-find (lambda (n) (f90-ts--node-type-p n "=>"))
                                 children)))
           (list first arrow))
       (list node)))
   nodes))


(defun f90-ts--align-list-items-assocation (context _loc)
  "Determine relevant childrens of \"association_list\" context.
The list context is provided as car of CONTEXT."
  (let ((list-context (car context)))
    (cl-assert (f90-ts--node-type-p list-context "association_list")
               nil "expected list context: association_list, got '%s'" list-context)
    ;; expand it, as it contains a list of nodes, whose children are required,
    ;; drop the first node, which is the opening parenthesis
    (when-let ((children (treesit-node-children list-context))
               (assocs (seq-drop children 1)))
      (f90-ts--align-list-expand-assoc assocs))))


;;++++++++++++++
;; list context: operator expressions

(defun f90-ts--align-list-expand-op-expr (node)
  "Recursively compute relevant children of a logical expression tree NODE.
An expression like (A and B and C) is represented as
logical_expression(logical_expression(A and B) and C).
The routine returns the five children A, and, B, and, C.
It does not descend into parenthesized_expressions."
  (if (f90-ts--node-is-op-expr-p node)
      (mapcan #'f90-ts--align-list-expand-op-expr
              (treesit-node-children node))
    (list node)))


(defun f90-ts--align-list-items-op-expr (context _loc)
  "Determine relevant children of CONTEXT being some operator expression.
Check and include any assignment or parentheses directly prior to list-context.
The expression node is provided as car of CONTEXT, and the assignment or
parenthesis node if present as cdr of CONTEXT."
  (let ((list-context (car context))
        (aux-context (cdr context)))
    (cl-assert (f90-ts--node-is-op-expr-p list-context)
               nil
               "expected list context: some expression node, got list-context=%s"
               list-context)
    ;; assert that we are already at the root of an op-expr chain
    (cl-assert (eq list-context
                   (f90-ts--node-op-expr-chain-root list-context))
               nil
               "list context not root of chain of op-expr, list-context=%s"
               list-context)

    ;; assert that auxiliary context is nil or assignment or opening parenthesis
    (cl-assert (or (null aux-context)
                   (f90-ts--node-type-p aux-context '("=" "(" ",")))
               "invalid aux context in op-expr, list-context=%, aux-context=%s"
               list-context aux-context)

    (let* ((items-expr (f90-ts--align-list-expand-op-expr list-context))
           (items-aux (and aux-context
                           (f90-ts--siblings-between aux-context list-context))))
      (append items-aux items-expr))))


;;++++++++++++++
;; list context: parenthesized expressions, arguments, array, parameters

(defun f90-ts--align-list-items-children (context _loc)
  "Return all children of CONTEXT.
This is used for a context where all direct children are relevant,
which are \"parenthesized_expression\", \"argument_list\",
\"array_literal\" and \"parameters\"."
  (let ((list-context (car context)))
    (cl-assert (f90-ts--node-type-p list-context
                                    '("parenthesized_expression"
                                      "argument_list"
                                      "array_literal"
                                      "parameters"))
               nil "align-list-items-children: wrong context, got '%s'" list-context)
    ;; drop parenthesis, as these are dealt with directly
    (seq-filter
     (lambda (n)
       (not (eq (f90-ts--align-node-symbol n) 'parenthesis)))
     (treesit-node-children list-context))))


;;++++++++++++++
;; list context: variable_declarations

(defun f90-ts--align-list-items-var-decl (context loc)
  "Determine relevant children of CONTEXT = \"variable_declaration\".
Use LOC to determine whether attribute or declarator items are relevant (those
before and after \"::\")."
  (let ((list-context (car context)))
    (cl-assert (f90-ts--node-type-p list-context "variable_declaration")
               nil "expected list context: variable_declaration, got '%s'" list-context)
    (when-let ((children (treesit-node-children list-context)))
      (let* ((pos (alist-get 'pos loc))
             (attr-children (seq-filter (lambda (n)
                                          (string= (treesit-node-field-name n) "attribute"))
                                        children))
             (decl-children (seq-filter (lambda (n)
                                          (string= (treesit-node-field-name n) "declarator"))
                                        children))

             ;;(attr-end (seq-max (seq-map (lambda (child) (treesit-node-end child))
             ;;                            attr-children)))
             (decl-start (seq-min (seq-map (lambda (child) (treesit-node-start child))
                                           decl-children))))
        (if (< pos decl-start)
            attr-children
          ;; for init declarator children, add assignment nodes as well
          (cl-mapcan (lambda (n)
                       (cons n (when (f90-ts--node-type-p n "init_declarator")
                                 (cl-remove-if-not
                                  (lambda (c) (f90-ts--node-type-p c "="))
                                  (treesit-node-children n)))))
                     decl-children))))))


;;++++++++++++++
;; list context: import statement

(defun f90-ts--align-list-items-children1 (context _loc)
  "Determine relevant children of CONTEXT by dropping first child.
This is used for nodes of type \"import_statement\"."
  (let ((list-context (car context)))
    (cl-assert (f90-ts--node-type-p list-context "import_statement")
               nil "expected list context: import_statement, got '%s'" list-context)
    (when-let ((children (treesit-node-children list-context)))
      ;; drop the "import" keyword
      (seq-drop children 1))))


;;++++++++++++++
;; list context: binding_list, final_statement

(defun f90-ts--align-list-items-children2 (context _loc)
  "Determine relevant children of CONTEXT by dropping first two children.
This is used for nodes of type \"binding_list\" or \"final_statement\".
Both occur in the contains part of a derived type definition."
  (let ((list-context (car context)))
    (cl-assert (or (f90-ts--node-type-p list-context "binding_list")
                   (f90-ts--node-type-p list-context "final_statement"))
               nil "expected list context: binding_list or final_statement, got '%s'" list-context)
    (when-let ((children (treesit-node-children list-context)))
      ;; drop the (binding_name ...) part, and the => binding symbol
      (seq-drop children 2))))


;;++++++++++++++
;; additional anchor for aligned lists:

(defmacro f90-ts--collecting-anoff (&rest body)
  "Execute BODY with `collect' available to accumulate (anchor offset) pairs.
Pairs can be collected either by executing \"(collect anchor offset)\"
 or \"(collect anoff-pair)\".

The first collected entry is used as primary anoff position.  However, if a
later entry should be collected as primary instead,
\"(as-primary anchor offset)\" and \"(as-primary anoff-pair)\" can be used.
The as-primary, which is executed last, wins.

In this context, anchor must be a buffer position and offset an integer offset.
Collecting nodes instead of their start position is not supported here.

The macro deals with nil as pair input as well, so using it like
\"(collect (pair-or-nil ...))\" is valid.

Current state of collected anoff items can be queries
by \"(anything-collected-p)\", which return nil if nothing has been collected
so far.

Within BODY, \"(merge-items ITEMS)\" can be used to merge a previously
collected anoff items list (as returned by another `f90-ts--collecting-anoff'
form).  The list is reversed before merging so that the collect/as-primary
ordering semantics are preserved.  In particular, this means that the primary
from ITEMS becomes the new primary."
  (let ((acc (gensym "acc")))
    `(let ((,acc nil))
       (cl-flet ((collect (arg1 &optional arg2)
                   (when arg1
                     (push (if arg2 (list arg1 arg2) arg1)
                           ,acc)))
                 (as-primary (arg1 &optional arg2)
                   (when arg1
                     (setq ,acc (append ,acc (list (if arg2 (list arg1 arg2) arg1))))))
                 (merge-items (items)
                   (when items
                     (setq ,acc (append ,acc (reverse items)))))
                 (anything-collected-p ()
                   ,acc))
         ,@body
         ;; reverse order, the first item collected is used as primary,
         ;; it must be the first in the final list
         (nreverse ,acc)))))


(defun f90-ts--align-list-pstmt1-anoff ()
  "Return the standard continued line indentation.
This is start position of pstmt-1 as anchor and `f90-ts-indent-continued'
as offset."
  (let ((pstmt-1 (f90-ts--indent-prev-stmt-first)))
    (list (treesit-node-start pstmt-1)
          f90-ts-indent-continued)))


(defun f90-ts--align-list-smallest-anoff (items)
  "Return the item with the smallest column number in a list of ITEMS.
ITEMS is not asssumed to be sorted by their column.
Currently an item must be a node.  It is assumed that anchor is a node (in
general it is a node or a buffer position) and offset is 0.
Pairs anoff=(anchor offset) are not yet implemented so far."
  (car (seq-sort-by #'f90-ts--continued-line-cache-get-col
                    #'<
                    items)))


(defun f90-ts--align-list-smallest-column (items)
  "Return the smallest column number found in a list of ITEMS.
ITEMS is not asssumed to be sorted.
Currently an item must be a node.  It is assumed that anchor is a node (in
general it is a node or a buffer position) and offset is 0.
Pairs anoff=(anchor offset) are not yet implemented so far."
  ;;(f90-ts-log-msg :smallcol "cache = %s" f90-ts--continued-line-cache)
  ;;(cl-loop
  ;; for node in items
  ;; do (f90-ts-log-msg :smallcol "node col = %s, %s" node (f90-ts--continued-line-cache-get-col node)))
  (cl-loop
   for node in items
   minimize (f90-ts--continued-line-cache-get-col node)))


(defun f90-ts--align-list-other-epilog (items-plist has-items)
  "Return a list of standard primary positions (anchors offset).

If ITEMS-SYM in ITEMS-PLIST is non-empty, then use smallest column position
as primary.
If HAS-ITEMS is nil (signalling that no items have been collected so far),
then standard continued line indentation is a fallback primary.

This function should be called as an epilog."
  (let ((items-sym (plist-get items-plist :sym)))
    (f90-ts--collecting-anoff
     (when items-sym
       (as-primary (f90-ts--align-list-smallest-anoff items-sym)))
     (unless (or has-items (anything-collected-p))
       (as-primary (f90-ts--align-list-pstmt1-anoff))))))


(defun f90-ts--align-list-other-default (_context _loc items-plist)
  "Return a list of default/fallback alignment positions (anchors offset).
The first entry of the returned \"other\" list is used as primary anchor.

Use the standard epilog to provide other anoff items.
In particular, if ITEMS-SYM in ITEMS-PLIST has entries, then use the item
with the smallest column as primary anoff."
  (f90-ts--align-list-other-epilog items-plist nil))


(defun f90-ts--align-list-other-paren-expr-core
    (node-sym node-lead start-lead offset-lead indent-at-lead items-plist)
  "Core collecting logic shared by paren and op-expr other items functions.
NODE-SYM is the nsym from loc.
NODE-LEAD is the lead node, whose type and column are relevant in some cases.
START-LEAD is the buffer position of the lead node (e.g. opening paren or
assignment symbol before an expression).  OFFSET-LEAD is the anchor offset
applied to the anchor.
INDENT-AT-LEAD is the indentation of the line on which the lead node sits.
ITEMS-PLIST is the plist collection of items lists."
  (let* ((items-head (plist-get items-plist :head))
         (items-tail (plist-get items-plist :tail))
         (col-min    (f90-ts--align-list-smallest-column items-tail))
         (col-lead   (f90-ts--continued-line-cache-get-col node-lead)))
    (f90-ts--collecting-anoff
     (if (eq node-sym 'parenthesis)
         ;; closing parenthesis: align relative to indentation if any prior
         ;; item is to the left of the context column, otherwise use anchor
         (if (and col-min (< col-min col-lead))
             (as-primary indent-at-lead f90-ts-indent-continued)
           (as-primary start-lead offset-lead))

       ;; if there are items on the head line of context or all items on tail lines
       ;; have column at least as large as column of context node, use position
       ;; relative to lead node as primary
       (if (or items-head
               (and col-min
                    (>= col-min col-lead)))
           (as-primary start-lead offset-lead)

         ;; both indent-at-lead+continued and start-lead+offset are
         ;; potentially relevant; pick the smaller column as primary
         (cl-assert (= (line-number-at-pos start-lead)
                       (line-number-at-pos indent-at-lead))
                    nil
                    "start-lead and indent-at-lead must be on the same line, got lines %s and %s"
                    (line-number-at-pos start-lead)
                    (line-number-at-pos indent-at-lead))
         (if (< (+ indent-at-lead f90-ts-indent-continued)
                (+ start-lead offset-lead))
             (progn
               (as-primary indent-at-lead f90-ts-indent-continued)
               (collect  start-lead offset-lead))
           (collect  indent-at-lead f90-ts-indent-continued)
           (as-primary start-lead offset-lead)))

       ;; ensure both positions are always present in the result list
       (collect start-lead   offset-lead)
       (collect indent-at-lead f90-ts-indent-continued)))))


(defun f90-ts--align-list-other-paren (context loc items-plist)
  "Return alignment anchors for parenthesized list contexts.
See `f90-ts--align-list-other-paren-expr-core' for the shared logic.

CONTEXT, LOC and ITEMS-PLIST are as described in the calling convention of
the align-list-other family."
  (cl-assert (f90-ts--node-type-p (car context)
                                  '("parenthesized_expression"
                                    "argument_list"
                                    "array_literal"
                                    "parameters"))
             nil
             "align-list-other-paren: wrong context, got '%s'"
             (car context))
  (let* ((list-context    (car context))
         (node-sym        (alist-get 'nsym loc))
         (open-paren      (treesit-node-at (treesit-node-start list-context)))
         (indent-at-paren (f90-ts--indent-pos-at-node open-paren))
         (start-paren     (treesit-node-start open-paren))
         (offset-paren    (+ (1- (length (treesit-node-text open-paren)))
                             (if (eq node-sym 'parenthesis)
                                 f90-ts-indent-paren-close
                               f90-ts-indent-paren-default))))
    (f90-ts--collecting-anoff
     (merge-items (f90-ts--align-list-other-paren-expr-core
                   node-sym list-context start-paren offset-paren indent-at-paren items-plist))
     (merge-items (f90-ts--align-list-other-epilog
                   items-plist (anything-collected-p))))))


(defun f90-ts--align-list-other-op-expr (context loc items-plist)
  "Return alignment anchors for operator-expression contexts.
See `f90-ts--align-list-other-paren-expr-core' for the shared logic.

CONTEXT, LOC and ITEMS-PLIST are as described in the calling convention of
the align-list-other family."
  (cl-assert (f90-ts--node-is-op-expr-p (car context))
             nil
             "align-list-other-op-expr: wrong context, expected some op-expr, got '%s'"
             (car context))

  (let* ((aux-context (cdr context)))
    (f90-ts--collecting-anoff
     (when aux-context
       (let* ((list-context  (car context))
              (node-sym      (alist-get 'nsym loc))
              (psib-context  (f90-ts--prev-sibling-proper list-context))
              (psib-type     (and psib-context (treesit-node-type psib-context)))
              (start-aux     (treesit-node-start aux-context))
              (indent-at-aux (f90-ts--indent-pos-at-node aux-context))
              (offset-aux    (pcase psib-type
                               ("("
                                (if (eq node-sym 'parenthesis)
                                    f90-ts-indent-paren-close
                                  f90-ts-indent-paren-default))
                               ((or "=" ",")
                                (if (member node-sym '(operator-logical operator-math))
                                    f90-ts-indent-expr-assign-assoc-op
                                  f90-ts-indent-expr-assign-default)))))
         (merge-items (f90-ts--align-list-other-paren-expr-core
                       node-sym aux-context start-aux offset-aux indent-at-aux items-plist))))

     (merge-items (f90-ts--align-list-other-epilog
                   items-plist (anything-collected-p))))))


(defun f90-ts--align-list-other-association (context loc items-plist)
  "Return a list of default positions (anchors offset) for association nodes.
The first entry of the returned \"other\" list is used as primary anchor.
For assocation lists these anchors depend on CONTEXT, node-sym (nsym in
LOC), ITEMS-SYM and ITEMS-PLIST.

For association lists (associate(x => y, ...)), a default and fallback
position is to align with the initial opening parenthesis plus some offset.
However, if node is the =>, then apply indent with
`f90-ts-indent-continued' relative to opening parenthesis.
This primary position is returned as first element of the list."
  ;; for argument_list, there should always be the opening parenthesis
  (let* ((list-context (car context))
         (nsym (alist-get 'nsym loc))
         (child-paren (treesit-node-child list-context 0 nil)))
    (cl-assert (f90-ts--node-type-p list-context "association_list")
               nil
               "align-list-other-association: wrong context, got '%s'"
               list-context)

    (f90-ts--collecting-anoff
     (cl-assert (f90-ts--node-type-p child-paren "(")
                nil
                "expected opening parenthesis as child-0, got '%s'"
                child-paren)
     (collect (treesit-node-start child-paren)
              (pcase nsym
                ('associate   f90-ts-indent-continued)     ; indents "=>"
                ('parenthesis f90-ts-indent-paren-close)   ; indents ")"
                (_            f90-ts-indent-paren-default) ; all other kind of nodes
                ))
     (merge-items (f90-ts--align-list-other-epilog
                   items-plist (anything-collected-p))))))


(defun f90-ts--align-list-other-var-decl (context loc items-plist)
  "Return a list of default/fallback alignment positions (anchors offset).
The first entry of the returned \"other\" list is used as primary anchor.
For variable declarations these anchors depend on CONTEXT, node-sym (nsym
in LOC) and ITEMS-PLIST.

Car of CONTEXT is a variable_declaration.  For this, the continued line
position is always added.
If ITEMS-SYM in ITEMS=(ITEMS-PREV ITEMS-SYM) has entries, then return the
entry with the smallest column as primary anchor.
Always return position of pstmt-1 with offset `f90-ts-indent-continued'
for default continued line indentation."
  (let* ((list-context (car context))
         (items-sym  (plist-get items-plist :sym))
         (items-head (plist-get items-plist :head))
         (node-colons (treesit-search-subtree list-context
                                             "::"
                                             nil ; search forward
                                             t   ; include anonymous nodes
                                             1   ; maximal depth of 1, search only children
                                             ))
         (node-type-attr (unless node-colons
                           (treesit-search-subtree list-context
                                                   (lambda (n) (member (treesit-node-field-name n)
                                                                       '("type" "attribute")))
                                                   t   ; search backward to find last attribute node
                                                   t   ; only named nodes
                                                   1   ; maximal depth of 1, search only children
                                                   ))))
    (f90-ts--collecting-anoff
     (cond
      (node-colons
       ;; start of "::" plus f90-ts-indent-declaration
       (collect (treesit-node-start node-colons)
                f90-ts-indent-declaration))
      (node-type-attr
       ;; no colons, take last node (type or attribute, and add to end position of that node
       ;; f90-ts-indent-declaration minus 2 (subtracting length of "::")
       (collect (treesit-node-end node-type-attr)
                (- f90-ts-indent-declaration 2))))

     ;; the following conditions should be mutually exclusive
     (cond
      ((eq (alist-get 'nsym loc) 'assignment)
       ;; if within init_declarator and node is "=", then most often default continued
       ;; offset is primary column
       (as-primary (f90-ts--align-list-pstmt1-anoff)))
      (items-sym
       ;; if we have matching prior items, take smallest as primary
       (as-primary (f90-ts--align-list-smallest-anoff items-sym)))
      ((null items-head)
       ;; no items on head line at all
       (as-primary (f90-ts--align-list-pstmt1-anoff))))

     (unless (anything-collected-p)
       (as-primary (f90-ts--align-list-pstmt1-anoff))))))


;;++++++++++++++
;; list context: items and columns

(defun f90-ts--align-list-filter-items (items node-sym)
  "From a list ITEMS of node items select compatible nodes.
Currently these are nodes with the same NODE-SYM."
  (when node-sym
    (let ((pred-node-sym
           (lambda (n) (eq (f90-ts--align-node-symbol n)
                           node-sym))))
      (seq-filter pred-node-sym
                  items))))


(defun f90-ts--align-list-map-col-pos (anchor)
  "Map an ANCHOR to a triple (column position offset).
ANCHOR is either a node or an otherwise obtained pair (position offset), .
For a node, position is start of node and offset is zero."
  (cl-assert
   (or (treesit-node-p anchor)
       (and (integerp (car anchor))
            (integerp (cadr anchor))))
   nil
   "anchor is not a node or a pair of integers, got %s" anchor)

  (if (treesit-node-p anchor)
      (list
       ;; some node, compute column number and buffer position, offset=0
       (f90-ts--continued-line-cache-get-col anchor)
       (treesit-node-start anchor)
       0)
    ;; a pair (buffer position, offset) add column
    ;; compute column at position and then add offset
    ;; (do not compute column at position + offset, this might not be valid)
    (cons
     (+ (f90-ts--column-number-at-pos (car anchor)) (cadr anchor))
     anchor)))


(defun f90-ts--align-list-cp-sort (cp-alist)
  "Make CP-ALIST of (column position offset) triples unique by column position.
For several entries with same column number, take the element with the largest
buffer position."
  (let ((cp-alist-unique
         (seq-map (lambda (group)
                    ;; elements produced by seq-group-by are:
                    ;; group = (col (col pos1 offset1) (col pos2 offset2) ...)
                    ;; ((cdr group) gets rid of initial col)
                    (cl-reduce (lambda (cp1 cp2)
                                 (if (> (cadr cp1) (cadr cp2)) cp1 cp2))
                               (cdr group)))
                  (seq-group-by #'car cp-alist))))
    (seq-sort (lambda (a b) (< (car a) (car b))) cp-alist-unique)))


(defun f90-ts--align-list-select (variant cur-col primary items)
  "Select (anchor offset) from PRIMARY and ITEMS.
Depending on VARIANT and current column CUR-COL, select the relevant
anchor and offset.

PRIMARY is a default/fallback anchor (position offset).  Depending on
VARIANT (like keep-or-primary) and current alignment, PRIMARY is
selected."
  ;; note that entries in col-pos are triples
  ;; cp = (column, buffer position, offset),
  ;; where buffer position must be start of a previous node to ensure
  ;; that treesitter buffering in indent-region works as expected,
  (let* ((col-pos-unsorted (seq-map #'f90-ts--align-list-map-col-pos items))
         (col-pos (f90-ts--align-list-cp-sort col-pos-unsorted))
         (aligned-at (seq-find (lambda (cp) (= cur-col (car cp)))
                               col-pos))
         (primary-col-pos (f90-ts--align-list-map-col-pos primary)))
    ;; :get-other-fn should always return some fallback position
    ;; (like pstmt-1+default indent for continued lines), and thus
    ;; there must always be some anchors in col-pos
    (cl-assert col-pos nil "no relevant columns found")

    ;; the selection process selects a triple, drops the column and returns
    ;; the two remaining elements (buffer position, offset)
    (cond
     ;; special case (e.g. after inserting newline by <return> or f90-line-break)
     ;; check whether we are before first entry in col-pos,
     ;; if this is the case we go to primary, not to first entry in col-pos
     ((< cur-col (caar col-pos))
      (cdr primary-col-pos))

     ;; cases: (aligned, rotate), (not-aligned, rotate),
     ;;        (not-aligned,keep-or-rotate)
     ((or (eq variant 'rotate)
          (and (not aligned-at)
               (eq variant 'keep-or-rotate)))
      ;; go to next column or wrap around,
      ;; recall that col-pos is sorted by columns
      (let ((aligned-next (seq-find (lambda (cp) (< cur-col (car cp)))
                                    col-pos)))
        ;; next if there is a next, otherwise first entry (not necessarily primary)
        (or (cdr aligned-next)
            (cdar col-pos))))

     ;; cases: (not-aligned, keep-or-primary),
     ;;        (aligned, primary), (not-aligned, primary)
     ((or (not aligned-at)
          (eq variant 'primary))
      (cdr primary-col-pos))

     ;; cases: (aligned, keep-or-primary)
     ;;        (aligned, keep-or-rotate)
     ((and aligned-at
           (member variant '(keep-or-primary
                             keep-or-rotate)))
      ;; aligned, keep current column, but use proper element from col-pos
      ;; as anchor, otherwise indent-region does not take indentation of anchor
      ;; position into account
      (cdr aligned-at))

     (t
      ;; all eight cases plus node before minimal column are covered above
      (cl-assert col-pos nil "cond logic not complete")
      (cdr primary-col-pos)))))


(defun f90-ts--align-list-anoff-items (loc context)
  "Filter relevant alignment anchors from CONTEXT.
Return all list context items before location specified by LOC, and
additionally further filtered by node symbol type.

LOC is an alist which provides the node and further location data.

Note: for anchor-offset pairs extracted from CONTEXT nodes directly,
the offset is assumed to be 0."
  (let* ((get-items (f90-ts--get-list-context-prop :get-items-fn context))
         (items-all (funcall get-items context loc))
         (cur-line (alist-get 'line loc))
         (cntxt-line (f90-ts--node-line (or (cdr context) (car context))))
         (items-prev (seq-filter
                      ;; filter by line number, use only items on some previous line,
                      ;; also drop continuation symbols, as these are not relevant for alignment
                      (lambda (n) (and (< (f90-ts--node-line n)
                                          cur-line)
                                       (not (f90-ts--node-type-p n "&"))))
                      items-all))
         (items-head (seq-filter
                      ;; determine nodes on first context line (head line),
                      ;; but drop comments, assignment and parenthesis on this line, as items-head
                      ;; is used to verify whether proper items are present on this line
                      (lambda (n) (and (= (f90-ts--node-line n)
                                          cntxt-line)
                                       (not (f90-ts--node-type-p n '("comment" "=" "(" ",")))))
                       items-prev))
         (items-tail (seq-filter
                      ;; all items-prev, which are not on the context line (first line) itself
                      (lambda (n) (< cntxt-line
                                     (f90-ts--node-line n)))
                      items-prev))
         (items-sym  (f90-ts--align-list-filter-items items-prev
                                                      (alist-get 'nsym loc))))
    ;; further filter by symbol type node-sym of current node at point
    (list :sym  items-sym
          :prev items-prev
          :head items-head
          :tail items-tail)))


(defun f90-ts--align-list-anoff-other (loc anoff-items-plist context)
  "Return other relevant anchor-offset pairs for alignment in CONTEXT.
ANOFF-ITEMS-PLIST are some items lists of node items already obtained by
`f90-ts--align-list-anoff-items'.
These lists might be necessary to determine which primary and alternative
alignment positions to select.
LOC provides node and location data."
  (let ((get-other (or (f90-ts--get-list-context-prop :get-other-fn context)
                       #'f90-ts--align-list-other-default)))
    (funcall get-other
             context loc anoff-items-plist)))


(defun f90-ts--align-list-anchor-offset (variant loc context)
  "Determine a pair (anchor offset) for alignment of a node in a list context.
Location data is given as an alist LOC containing node, column, line number and
node symbol.
To this end items on continued lines in the provided CONTEXT are
determined.  Additionally further anchors (like the first node of previous
statement by pstmt-1) are considered.
Finally use VARIANT to select one pair to align with."
  (let* ((anoff-items-plist (f90-ts--align-list-anoff-items loc
                                                            context))
         (anoff-items-sym (plist-get anoff-items-plist :sym))
         ;;(_ (progn
         ;;     (f90-ts-log-msg :anoff "items-sym = %s"  (plist-get anoff-items-plist :sym))
         ;;     (f90-ts-log-msg :anoff "items-prev = %s" (plist-get anoff-items-plist :prev))
         ;;     (f90-ts-log-msg :anoff "items-head = %s" (plist-get anoff-items-plist :head))
         ;;     (f90-ts-log-msg :anoff "items-tail = %s" (plist-get anoff-items-plist :tail))))
         (anoff-other (f90-ts--align-list-anoff-other loc
                                                      anoff-items-plist
                                                      context))
         ;; always add default continued offset position as anchor
         (anoff-extra (f90-ts--align-list-pstmt1-anoff))
         ;; anoff-primary is used as 'primary' in keep-or-primary, primary etc.
         ;; if anoff-other is empty (should not happen), then use anoff-extra as fallback
         (anoff-primary (or (car anoff-other)
                            anoff-extra))
         ;; final list of anchors (which are nodes or pairs (position offset))
         (anoff-final (append (and anoff-extra (list anoff-extra))
                              anoff-other
                              anoff-items-sym)))
    ;;(f90-ts-log-msg :anoff "items-other = %s" anoff-other)
    ;;(f90-ts-log-msg :anoff "item-primary = %s" anoff-primary)
    (f90-ts--align-list-select variant
                               (alist-get 'col loc)
                               anoff-primary
                               anoff-final)))


;;++++++++++++++
;; anchor functions: continued lines
;; determine whether list or standard case

;; get-items: function to determine node items in the list context
;;            relevant for alignment
;; get-other: other columns for alignment (default and fallback values),
;;            must return a non-empty list of anchors, the primary anchor
;;            in the list is used as primary/fallback position (for example
;;            in keep-or-primary option);
;;            if not provided, `f90-ts--align-list-other-default' is used
(defconst f90-ts--align-list-context-properties
  (let ((expr-prop  '(:get-items-fn f90-ts--align-list-items-op-expr
                      :get-other-fn f90-ts--align-list-other-op-expr))
        (paren-prop '(:get-items-fn f90-ts--align-list-items-children
                      :get-other-fn f90-ts--align-list-other-paren))
        (bind-prop  '(:get-items-fn f90-ts--align-list-items-children2)))
     (list
      (cons "logical_expression"       expr-prop)
      (cons "math_expression"          expr-prop)
      (cons "relational_expression"    expr-prop)
      (cons "concatenation_expression" expr-prop)
      (cons "unary_expression"         expr-prop)
      (cons "binding_list"             bind-prop)
      (cons "final_statement"          bind-prop)
      (cons "parenthesized_expression" paren-prop)
      (cons "argument_list"            paren-prop)
      (cons "array_literal"            paren-prop)
      (cons "parameters"               paren-prop)
      (cons "association_list"
            '(:get-items-fn f90-ts--align-list-items-assocation
              :get-other-fn f90-ts--align-list-other-association))
      (cons "variable_declaration"
            '(:get-items-fn f90-ts--align-list-items-var-decl
              :get-other-fn f90-ts--align-list-other-var-decl))
      (cons "import_statement"
            '(:get-items-fn f90-ts--align-list-items-children1))))
  "List of tree-sitter node types presenting some kind of list context.
A list context is a node with children which are suitable for alignment if
spread over several lines in a continued line statement.
The value of the alist provides properties to deal with such list contexts,
in particular for how to extract relevant alignment positions.")


(defun f90-ts--get-list-context-prop (pkey context)
  "Lookup CONTEXT and return the property value for PKEY.
Lookup is done in alist `f90-ts--align-list-context-properties'."
  (let* ((list-context (car context))
         (properties (alist-get (treesit-node-type list-context)
                                f90-ts--align-list-context-properties
                                nil
                                nil
                                #'string=)))
    (plist-get properties pkey)))


(defun f90-ts--align-list-context-max (loc)
  "Determine maximal subtree related to node representing a list-context.
Node location data is given by LOC.
This is the maximal node for any further subtree searches."
  (let* ((pos (alist-get 'pos loc))
         (line (alist-get 'line loc))
         (ps-key (f90-ts--indent-prev-stmt-keyword))
         (stmt-root (treesit-node-on (treesit-node-start ps-key)
                                     pos)))
    (treesit-search-subtree
     stmt-root
     (lambda (n)
       (and (<= (f90-ts--node-line n) line)
            (<= line (line-number-at-pos (treesit-node-end n)))
            (assoc (treesit-node-type n)
                   f90-ts--align-list-context-properties))))))


(defun f90-ts--align-list-context-op-expr (loc parent)
  "Determine, whether LOC is in an operator expression list context.
For expressions, we need to check node in LOC or PARENT (node might be
nil).  But we do not need to ascend further."
  (let* ((node (alist-get 'node loc))
         (line (alist-get 'line loc))
         (stmt-min
          (or (and (f90-ts--node-is-op-expr-p node)
                   node)
              (and (f90-ts--node-is-op-expr-p parent)
                   parent)))
         ;; find root of expression
         (root-expr (and stmt-min (f90-ts--node-op-expr-chain-root stmt-min)))
         ;; if we are on the same line as the root, we might need to check
         ;; the previous item (assignment "=", parenthesis "(" or separator ",")
         ;; will be included, but there is no proper list-context node to include this)
         (psib-expr (and root-expr
                         (f90-ts--prev-sibling-proper root-expr))))
    (cond
     ((and psib-expr
           (< (f90-ts--node-line psib-expr) line)
           (f90-ts--node-type-p psib-expr '("=" "(")))
      (cons root-expr psib-expr))

     ((and (< (f90-ts--node-line root-expr) line)
           psib-expr
           (< (f90-ts--node-line psib-expr) line)
           (f90-ts--node-type-p psib-expr ","))
      ;; if root-expr is on the same line, there must be a more appropriate
      ;; list context the commata belongs to, use commata as head
      (cons root-expr psib-expr))

     ((and root-expr
           (< (f90-ts--node-line root-expr) line))
      (cons root-expr nil)))))


(defun f90-ts--align-list-context-other (loc parent)
  "If LOC is in a list-context, other than expressions, return that context.
Use node from LOC or PARENT to start the search, which might require to
ascend a few steps.
This function return nil as second auxiliary context node."
  (let* ((node (or (alist-get 'node loc)
                   parent))
         (line (alist-get 'line loc))
         (list-context (treesit-parent-until
                        node
                        (lambda (n)
                          (and (< (f90-ts--node-line n) line)
                               (assoc (treesit-node-type n)
                                      f90-ts--align-list-context-properties)))
                        t ; include node in search
                        )))
    ;; list-context might be of some operator expression type, but
    ;; neither node nor parent are (already excluded), so we are at
    ;; some other kind of node like a call_expression or
    ;; parenthesized_expression, which are allowed within expressions,
    ;; but this is another context
    (when (and list-context
               (not (f90-ts--node-is-op-expr-p list-context)))
      (cons list-context nil))))


(defun f90-ts--align-list-context (loc parent)
  "Check whether LOC and PARENT are within a list context and return it.
A context is a cons pair of the list-context itself (root node of the
context) and optionally a second auxiliary node.

Often the list context is PARENT, but sometimes a related node like
grandparent, etc.

The smallest such context, starting on a previous line is returned.
Return value nil signals that position is not within a list context.

Only expressions return an auxiliary node, which is assignment \"=\"
or parenthesis \"(\".  It is required but not part of the list context node."
  (let ((stmt-max (f90-ts--align-list-context-max loc)))
    (when stmt-max
      (or (f90-ts--align-list-context-op-expr loc parent)
          (f90-ts--align-list-context-other loc parent)))))


(defun f90-ts--continued-line-anchor-offset (variant pstmt-1 loc parent)
  "Compute the anchor-offset for a continued line, or nil to use the default.
VARIANT controls alignment behavior.  PSTMT-1 is the previous statement first
node.  LOC is an list contain location data.  PARENT is the parent node.
It returns a pair (anchor offset), or nil if no proper list context could
be determined or variant prescribes the default continued line indentation."
  (unless (or (eq variant 'continued-line)
              (not pstmt-1))
    (when-let ((context (f90-ts--align-list-context loc parent)))
      ;;(f90-ts-log-msg :anoff "loc = %s" loc)
      ;;(f90-ts-log-msg :anoff "context=%s" context)
      ;;(f90-ts-log-msg :anoff "parent = %s" parent)
      (cl-assert (< (f90-ts--node-line (or (cdr context)
                                           (car context)))
                    (alist-get 'line loc))
                 nil
                 "context not on some previous line: context=%s, loc-line=%s"
                 context
                 (alist-get 'line loc))
      (f90-ts--align-list-anchor-offset variant
                                        loc
                                        context))))


(defun f90-ts--continued-line-anchor (node parent bol &rest _)
  "Determine anchor for a continued line given by NODE, PARENT and BOL.
If the current position is within a list like context, try to align with
list items like arguments in a procedure call or other related columns like
those of parenthesis.  Otherwise determine standard indentation for
continued lines.

Exact behaviour is determined by custom variables
`f90-ts-indent-list-line' and `f90-ts-indent-list-region'.

This anchor requires a matcher which succeeds only if on a subsequent continued
line.  The first statement line where the statement starts must not catched by
the continued line matcher."
  (let ((variant (or f90-ts--align-continued-variant-tab
                     f90-ts-indent-list-region))
        (pstmt-1 (f90-ts--indent-prev-stmt-first)))
    (cl-assert pstmt-1 nil
               "continued subsequent line must have a pstmt-1 node")
    (f90-ts--continued-line-cache-update
     (treesit-node-start pstmt-1))
    (let* ((loc (f90-ts--align-list-location node))
           (default-anchor-offset (if pstmt-1
                                     (list (treesit-node-start pstmt-1)
                                           f90-ts-indent-continued)
                                   (list bol 0)))
           (anchor-offset (or (f90-ts--continued-line-anchor-offset variant
                                                                    pstmt-1
                                                                    loc
                                                                    parent)
                              default-anchor-offset)))
      ;; there are two caches:
      ;;  * cache anchor and offset for offset function for the
      ;;    current line
      ;;  * cache computed offset for indentation of subsequent lines
      (let ((anchor (car anchor-offset))
            (offset (cadr anchor-offset)))
        ;; (strictly, anchor does not need to be cached)
        (f90-ts--indent-anchor-cache anchor)
        (f90-ts--indent-offset-cache offset)
        (f90-ts--continued-line-cache-put-subsequent bol anchor offset)
        anchor))))


;;++++++++++++++
;; simple indentation rules: expansion with f90-ts-- prefix

(defmacro f90-ts--map-rule (matcher anchor offset)
  "Map an indent rule triple with f90-ts-- prefix prepended were applicable.
MATCHER is either a bare symbol (direct matcher function) or a list
whose car is a constructor name.  ANCHOR and OFFSET are bare symbols or
literals.  Any symbol present in an internal list are prefixed, the rest is
passed through unchanged."
  (let ((prefix-syms '(;; matcher constructor
                       n-p-pstmtk
                       n-p-ch-psibp
                       ;; dummy matcher (always fail, but do preparations)
                       populate-cache
                       continued-line-cache-start
                       ;; direct matcher
                       continued-subsequent-line-is
                       openmp-comment-is
                       preproc-node-is
                       preproc-at-toplevel-is
                       special-comment-is
                       comment-region-is
                       ;; anchor
                       continued-line-anchor
                       previous-stmt-anchor
                       catch-all-anchor
                       cached-anchor
                       ;; offset
                       minus-block-offset
                       toplevel-offset
                       cached-offset)))
    (cl-flet ((mp (sym)
                (if (memq sym prefix-syms)
                    (intern (concat "f90-ts--" (symbol-name sym)))
                  sym)))
      (let* ((m (cond
                  ((and (listp matcher) matcher)
                   `'(,(mp (car matcher)) ,@(cdr matcher)))
                  ((symbolp matcher)
                   `',(mp matcher))
                  (t `',matcher)))
             (a (if (symbolp anchor) `',(mp anchor) anchor))
             (o (cond ((symbolp offset) `',(mp offset))
                      (t offset))))
        `(list ,m ,a ,o)))))


(defmacro f90-ts--with-map-rules (&rest triples)
  "Build a list of treesit indent rule triples.
Each element of TRIPLES is a (MATCHER ANCHOR OFFSET) form as accepted
by `f90-ts--map-rule'.  Returns a list of all expanded triples suitable for
use as the body of a `defvar' ruleset.
As a special case, (log-state MSG) is expanded to the
triple ((f90-ts-log-indent-print-state MSG) parent 0) directly."
  `(list ,@(mapcar (lambda (triple)
                     (if (eq (car triple) 'log-state)
                         `(list '(f90-ts-log-indent-print-state ,(nth 1 triple)) 'parent 0)
                       `(f90-ts--map-rule ,(nth 0 triple)
                                          ,(nth 1 triple)
                                          ,(nth 2 triple))))
                   triples)))


;;++++++++++++++
;; simple indentation rules

(defvar f90-ts-indent-rules-start
  (f90-ts--with-map-rules
   ;; populate cache and then always fail
   (populate-cache parent 0)
   ;; info rules needs populated cache
   ;;(log-state "start")
   )
  "Indentation rules executed at start.
The main purpose is to fill the indentation cache for a new run.")


(defvar f90-ts-indent-rules-comments
  (f90-ts--with-map-rules
   ;; there are special comments in `f90-ts-special-comment-rules',
   ;; distinguish between default and these special comments
   ;; (including openmp lines as well)
   ;;
   ;; default comments as well as special comments with property
   ;; `indented' are indented like code, these are not handled here
   ;; other comments are matched and anchor and offset caches are
   ;; loaded, according the the rule properties in
   ;; `f90-ts-special-comment-rules'
   ;;
   ;; if a comment follows another comment of the same kind (same
   ;; special rule), then alignment is with respect to the previous
   ;; comment in this comment region, the values are determined by the
   ;; matcher and saved in the cache
   (comment-region-is cached-anchor cached-offset)
   ;; indent separator comments like their parent nodes
   ;; this check is after the region check, hence previous sibling
   ;; is not a comment of same kind
   (special-comment-is cached-anchor cached-offset))
  "Indentation rules for comments (excluding OpenMP statements).")


(defvar f90-ts-indent-rules-preproc
  (f90-ts--with-map-rules
   ;; indent preprocessor directive.
   ;; directive itself: no indent
   (preproc-node-is column-0 0)
   ;; directive with preproc parent at toplevel
   (preproc-at-toplevel-is grand-parent f90-ts-indent-toplevel)
   ;; other
   ((n-p-gp nil "preproc_.*" nil) grand-parent f90-ts-indent-block))
  "Indentation rules for preprocessor directives.")


(defvar f90-ts-indent-rules-continued
  (f90-ts--with-map-rules
   ;; handle continued lines
   ;; if on first line of a continued statement, reset the continued-line cache
   ;; but always fail;
   ;; (the cache stores offsets on previous lines, this is necessary in
   ;; indent-region operations with buffering)
   (continued-line-cache-start parent 0)

   ;; continued strings need special care, the ampersands do not appear as
   ;; separate nodes, (treesit-node-at pos) at indentation position returns
   ;; the string_literal, which starts at some previous line
   ((n-p-gp nil "string_literal" nil) parent 0)

   ;; it is easy to see whether we are on a continued line (not the first line
   ;; of a multiline statement, only subsequent lines), but handling specific
   ;; cases is not possible with just some simple n-p-gp pattern,
   (continued-subsequent-line-is f90-ts--continued-line-anchor cached-offset))
  "Indentation rules for continued lines.")


(defvar f90-ts-indent-rules-internal-proc
  (f90-ts--with-map-rules
   ;; contains statements in modules, programs, subroutines or functions,
   ;; no indentation for contains
   ((node-is    "internal_procedures")         parent 0)
   ((parent-is  "internal_procedures")         parent toplevel-offset)
   ((n-p-gp nil "ERROR" "internal_procedures") parent toplevel-offset))
  "Indentation rules for internal_proc node.
This node occurs in conjunction with \"contain\" statements.")


(defvar f90-ts-indent-rules-prog-mod
  (f90-ts--with-map-rules
   ;; program or module interface part (before contains) and end statement
   ;; in all cases: first match node with end_xyz_statement, and then only
   ;; whether parent is xyz, as parent is xyz in both cases
   ((node-is    "end_program_statement")        parent 0)
   ((parent-is      "program\\(_statement\\)?") parent toplevel-offset)
   ((n-p-pstmtk nil "ERROR" "program")          parent toplevel-offset)

   ;; parent-is uses regexp matching, thus use "^module" to avoid that it
   ;; matches "submodule"
   ((node-is        "end_module_statement")      parent 0)
   ((parent-is      "^module\\(_statement\\)?$") parent toplevel-offset)
   ((n-p-pstmtk nil "ERROR" "^module$")          parent toplevel-offset)

   ((node-is        "end_submodule_statement")      parent 0)
   ((parent-is      "^submodule\\(_statement\\)?$") parent toplevel-offset)
   ((n-p-pstmtk nil "ERROR" "^submodule$")          parent toplevel-offset))
  "Indentation rules for program and module nodes.")


(defvar f90-ts-indent-rules-function
  (f90-ts--with-map-rules
   ;; functions and subroutine bodies
   ((node-is    "end_subroutine_statement")       parent 0)
   ((node-is    "end_function_statement")         parent 0)
   ((node-is    "end_module_procedure_statement") parent 0)
   ((parent-is  "subroutine")                     parent f90-ts-indent-block)
   ((parent-is  "function")                       parent f90-ts-indent-block)
   ((parent-is  "module_procedure")               parent f90-ts-indent-block)
   ((n-p-pstmtk nil nil "subroutine")             parent f90-ts-indent-block)
   ((n-p-pstmtk nil nil "function")               parent f90-ts-indent-block)
   ((n-p-pstmtk nil nil "module_procedure")       parent f90-ts-indent-block))
  "Indentation rules for functions and subroutines.")


(defvar f90-ts-indent-rules-translation-unit
  (f90-ts--with-map-rules
   ;; statements related to toplevel subroutine or function statements,
   ;; and ERROR cases (might or might not be toplevel)
   ((n-p-ch-psibp nil "translation_unit" nil "subroutine_statement") parent f90-ts-indent-block)
   ((n-p-ch-psibp nil "ERROR"            nil "subroutine_statement") parent f90-ts-indent-block)
   ((n-p-ch-psibp nil "translation_unit" nil "function_statement") parent f90-ts-indent-block)
   ((n-p-ch-psibp nil "ERROR"            nil "function_statement") parent f90-ts-indent-block)
   ;; rule for translation_unit and module_procedure_statement does not seem possible,
   ;; as module procedure statements are only allowed within contains section
   ((n-p-ch-psibp nil "ERROR"            nil "module_procedure_statement") parent f90-ts-indent-block)
   ((parent-is "translation_unit") column-0 0))
  "Indentation rules related to root node translation_unit.
These occur for functions and subroutines not within a \"contains\" section,
and in case of ERROR nodes with incomplete code.")


(defvar f90-ts-indent-rules-interface
  (f90-ts--with-map-rules
   ;; (abstract) interface bodies
   ((node-is    "end_interface_statement") parent 0)
   ((parent-is  "interface")               parent f90-ts-indent-block)
   ((n-p-pstmtk nil "ERROR" "interface")   parent f90-ts-indent-block))
  "Indentation rules for interface blocks.")


(defvar f90-ts-indent-rules-dtype-enum
  (f90-ts--with-map-rules
   ;; derived type definitions
   ((n-p-gp       "end_type_statement"      "derived_type_definition" nil)                      parent 0)
   ((n-p-ch-psibp "derived_type_procedures" "derived_type_definition" "contains_statement" nil) parent 0)
   ((n-p-ch-psibp "ERROR"                   "derived_type_definition" "contains_statement" nil) parent 0)
   ((parent-is    "derived_type_procedures") parent f90-ts-indent-block)
   ((parent-is    "derived_type_definition") parent f90-ts-indent-block)

   ;; enumeration types: enum and enumeration
   ((node-is    "end_enum_statement")                    parent 0)
   ((node-is    "end_enumeration_type_statement")        parent 0)
   ((parent-is  "^enum\\(eration_type\\)?$")             parent f90-ts-indent-block)
   ((n-p-pstmtk nil "ERROR" "^enum\\(eration_type\\)?$") parent f90-ts-indent-block))
  "Indentation rules for derived type and enumeration type statements.")


(defvar f90-ts-indent-rules-if
  (f90-ts--with-map-rules
   ;; if-then-else statements
   ;; this must be first, as its parent is an if-statement
   ;; but node=nil/something and parent=if_statement is possible (some line after if)
   ((n-p-gp     "end_if_statement" "if_statement"  nil)         parent 0)
   ((n-p-gp     "elseif_clause"    "if_statement"  nil)         parent 0)
   ((n-p-gp     "else_clause"      "if_statement"  nil)         parent 0)
   ((n-p-pstmtk nil                "if_statement"  "^if$")      parent f90-ts-indent-block) ; line right after if
   ((n-p-pstmtk nil                "if_statement"  "^else$")    parent f90-ts-indent-block) ; line right after else, with empty else block
   ((n-p-pstmtk nil                "if_statement"  "^elseif$")  parent f90-ts-indent-block) ; line right after elseif, with empty elseif block
   ((n-p-pstmtk nil                "else_clause"   "^else$")    parent f90-ts-indent-block) ; line after else, with non-empty else block
   ((n-p-pstmtk nil                "elseif_clause" "^elseif$")  parent f90-ts-indent-block) ; line right after "elseif"
   ((n-p-pstmtk nil                "elseif_clause" "^else$")    parent f90-ts-indent-block) ; line right after "else if"

   ((n-p-pstmtk "elseif_clause"    "ERROR" "^if$") previous-stmt-anchor 0)
   ((n-p-pstmtk "elseif"           "ERROR" "^if$") previous-stmt-anchor 0)
   ((n-p-gp     "elseif_clause"    "ERROR" nil)    previous-stmt-anchor minus-block-offset) ; at elseif line, incomplete

   ((n-p-pstmtk "else_clause"      "ERROR" "^if$")     previous-stmt-anchor 0)
   ((n-p-pstmtk "else_clause"      "ERROR" "^elseif$") previous-stmt-anchor 0)
   ((n-p-gp     "else_clause"      "ERROR" nil)        previous-stmt-anchor minus-block-offset) ; at else line, incomplete
   ((n-p-pstmtk "^else$"           "ERROR" "^if$")     previous-stmt-anchor 0)
   ((n-p-gp     "^else$"           "ERROR" nil)        previous-stmt-anchor minus-block-offset)

   ((n-p-pstmtk nil                "ERROR" "^if$")     previous-stmt-anchor f90-ts-indent-block) ; empty line after if
   ((n-p-pstmtk nil                "ERROR" "^elseif$") previous-stmt-anchor f90-ts-indent-block) ; empty line after elseif
   ((n-p-pstmtk nil                "ERROR" "^else$")   previous-stmt-anchor f90-ts-indent-block) ; empty line after else
   )
  "Indentation rules for if-then-else statements.")


(defvar f90-ts-indent-rules-where
  (f90-ts--with-map-rules
   ;; where-elsewhere statements
   ((n-p-gp     "end_where_statement" "where_statement"  nil)         parent 0)
   ((n-p-gp     "elsewhere_clause"    "where_statement"  nil)         parent 0)
   ((n-p-gp     "else_clause"         "where_statement"  nil)         parent 0)
   ((n-p-pstmtk nil                   "where_statement"  "where")     parent f90-ts-indent-block) ; line right after where
   ((n-p-pstmtk nil                   "where_statement"  "elsewhere") parent f90-ts-indent-block) ; line right after elsewhere
   ((n-p-pstmtk nil                   "elsewhere_clause" "elsewhere") parent f90-ts-indent-block) ; line after else, with non-empty else block

   ((n-p-pstmtk "elsewhere_clause"    "ERROR" "where") previous-stmt-anchor 0)
   ((n-p-pstmtk "elsewhere"           "ERROR" "where") previous-stmt-anchor 0)
   ((n-p-gp     "elsewhere_clause"    "ERROR" nil)     previous-stmt-anchor minus-block-offset) ; at elsewhere line, incomplete
   ((n-p-gp     "elsewhere"           "ERROR" nil)     previous-stmt-anchor minus-block-offset)

   ((n-p-pstmtk nil                "ERROR" "where")     previous-stmt-anchor f90-ts-indent-block) ; empty line after where
   ((n-p-pstmtk nil                "ERROR" "elsewhere") previous-stmt-anchor f90-ts-indent-block) ; empty line after elsewhere
   )
  "Indentation rules for else-elsewhere statements.")


(defvar f90-ts-indent-rules-single-region
  (f90-ts--with-map-rules
   ;; structures with a single region block and linear execution
   ((n-p-gp     "end_do_loop" "do_loop" nil)  parent 0)
   ((n-p-pstmtk nil           "do_loop" "do") parent f90-ts-indent-block)  ;; proper do block (with or without while)
   ((n-p-pstmtk nil           "ERROR"   "do") previous-stmt-anchor f90-ts-indent-block)

   ((n-p-gp     "end_block_construct_statement" "block_construct" nil)     parent 0)
   ((n-p-pstmtk nil                             "block_construct" "block") parent f90-ts-indent-block)
   ((n-p-pstmtk nil                             "ERROR"           "block") previous-stmt-anchor f90-ts-indent-block)

   ((n-p-gp "end_associate_statement" "associate_statement" nil)         parent 0)
   ((n-p-pstmtk nil                       "association"         "associate") parent f90-ts-indent-block)
   ((n-p-pstmtk nil                       "associate_statement" "associate") parent f90-ts-indent-block)
   ((n-p-pstmtk nil                       "ERROR"               "associate") previous-stmt-anchor f90-ts-indent-block)

   ((n-p-gp "end_forall_statement"        "forall_statement" nil)      parent               0)
   ((n-p-pstmtk nil                       "forall_statement" "forall") parent               f90-ts-indent-block)
   ((n-p-pstmtk nil                       "ERROR"            "forall") previous-stmt-anchor f90-ts-indent-block))
  "Indentation rules for single region structures.
These are do loops, block statements, associate construct and forall statements.")


(defvar f90-ts-indent-rules-select
  (f90-ts--with-map-rules
   ;; control statements
   ((n-p-gp     "end_select_statement" "select_case_statement" nil)              parent 0)
   ((n-p-pstmtk "case_statement"       "select_case_statement" nil)              parent 0)
   ((n-p-pstmtk nil                    "select_case_statement" "case")           parent f90-ts-indent-block)
   ((n-p-pstmtk nil                    "case_statement"        "case")           parent f90-ts-indent-block)
   ((n-p-gp     "ERROR"                "select_case_statement" nil)              parent f90-ts-indent-block)
   ((n-p-gp     nil                    "ERROR"                 "case_statement") grand-parent f90-ts-indent-block)
   ((parent-is                         "select_case_statement")                  parent 0)

   ((n-p-gp     "end_select_statement" "select_type_statement" nil)              parent 0)
   ((n-p-pstmtk "type_statement"       "select_type_statement" nil)              parent 0)
   ((n-p-pstmtk nil                    "select_type_statement" "type")           parent f90-ts-indent-block)
   ((n-p-pstmtk nil                    "select_type_statement" "class")          parent f90-ts-indent-block)
   ((n-p-pstmtk nil                    "type_statement"        "type")           parent f90-ts-indent-block)
   ((n-p-pstmtk nil                    "type_statement"        "class")          parent f90-ts-indent-block)
   ((n-p-gp     "ERROR"                "select_type_statement" nil)              parent f90-ts-indent-block)
   ((n-p-gp     nil                    "ERROR"                 "type_statement") grand-parent f90-ts-indent-block)
   ((parent-is                         "select_type_statement")                  parent 0)

   ((n-p-gp     "end_select_statement" "select_rank_statement" nil)              parent 0)
   ((n-p-pstmtk "rank_statement"       "select_rank_statement" nil)              parent 0)
   ((n-p-pstmtk nil                    "select_rank_statement" "rank")           parent f90-ts-indent-block)
   ((n-p-pstmtk nil                    "rank_statement"        "rank")           parent f90-ts-indent-block)
   ((n-p-gp     "ERROR"                "select_rank_statement" nil)              parent f90-ts-indent-block)
   ((n-p-gp     nil                    "ERROR"                 "rank_statement") grand-parent f90-ts-indent-block)
   ((parent-is                         "select_rank_statement")                  parent 0))
  "Indentation rules for select statements (case and type).")


(defvar f90-ts-indent-rules-coarray
  (f90-ts--with-map-rules
   ;; structures with a single region block and linear execution
   ((n-p-gp     "end_coarray_critical_statement" "coarray_critical_statement" nil)        parent 0)
   ((n-p-pstmtk nil                              "coarray_critical_statement" "critical") parent f90-ts-indent-block)
   ((n-p-pstmtk nil                              "ERROR"                      "critical") previous-stmt-anchor f90-ts-indent-block)

   ((n-p-gp     "end_coarray_team_statement" "coarray_team_statement" nil)        parent 0)
   ((n-p-pstmtk nil                          "coarray_team_statement" "change") parent f90-ts-indent-block)
   ((n-p-pstmtk nil                          "ERROR"                  "change") previous-stmt-anchor f90-ts-indent-block))
  "Indentation rules for coarray statements.")


(defvar f90-ts-indent-rules-catch-all
  (f90-ts--with-map-rules
   ;; final catch-all rule
   ;;(log-state "catch all")
   (catch-all catch-all-anchor 0))
  "Final indentation rule to handle unmatched cases.")


(defvar f90-ts-indent-rules
  `((fortran
     ,@f90-ts-indent-rules-start
     ,@f90-ts-indent-rules-preproc
     ,@f90-ts-indent-rules-comments
     ,@f90-ts-indent-rules-continued
     ,@f90-ts-indent-rules-internal-proc
     ,@f90-ts-indent-rules-prog-mod
     ,@f90-ts-indent-rules-function
     ,@f90-ts-indent-rules-translation-unit
     ,@f90-ts-indent-rules-interface
     ,@f90-ts-indent-rules-dtype-enum
     ,@f90-ts-indent-rules-if
     ,@f90-ts-indent-rules-where
     ,@f90-ts-indent-rules-single-region
     ,@f90-ts-indent-rules-select
     ,@f90-ts-indent-rules-coarray
     ,@f90-ts-indent-rules-catch-all))
  "List of all indentation rules in its proper sequence.")


;;;-----------------------------------------------------------------------------
;;; Smart end completion

(defvar-local f90-ts--indent-modified-outside-line nil
  "Non-nil if a line operation modified text outside the current line.
Set by operations like `f90-ts--complete-smart-end-indent' that indent
a whole block.  Checked by `f90-ts--with-check-modified-line' to prevent
incorrectly restoring the buffer-modified flag.

This assumes that a line operation using `f90-ts--with-check-modified-line'
might call a region based operation, but not the other way around.")


(defconst f90-ts--complete-end-structs
  '("end_program_statement"
    "end_module_statement"
    "end_submodule_statement"
    ;;"end_block_data_statement"
    "end_subroutine_statement"
    "end_function_statement"
    "end_module_procedure_statement"
    "end_type_statement"
    "end_interface_statement"
    ;;"end_do_label_loop_statement"
    "end_do_loop_statement"
    "end_if_statement"
    "end_where_statement"
    "end_forall_statement"
    "end_select_statement"
    "end_block_construct_statement"
    "end_associate_statement"
    "end_enum_statement"
    "end_enumeration_type_statement"
    "end_coarray_team_statement"
    "end_coarray_critical_statement")
    "List of type names used for end struct statements.
The parent of such a node represents the structure itself.
This list is used to find nodes elligible for smart end completion.
Statements not yet supported are commented out.")


(defun f90-ts--complete-replace-if-changed (beg end completion)
  "Replace text in region BEG...END with COMPLETION.
Replace only if completion is different than current text.
Return non-nil if something was changed and text actually replaced."
  (let* ((original (buffer-substring-no-properties beg end))
         (is-equal (string= original completion)))
    (if is-equal
        (goto-char end)
      (progn
        (delete-region beg end)
        (goto-char beg)
        (insert completion)))
    (not is-equal)))



(defconst f90-ts--complete-smart-end-query
  `(("program"                 . "(program (program_statement \"program\" @construct (_) * (name) @name))")
    ("module"                  . "(module (module_statement \"module\" @construct (_) * (name) @name))")
    ("submodule"               . "(submodule (submodule_statement \"submodule\" @construct (_) * (name) @name))")
    ("subroutine"              . "(subroutine (subroutine_statement \"subroutine\" @construct name: (_) @name))")
    ("function"                . "(function (function_statement \"function\" @construct name: (_) @name))")
    ("module_procedure"        . "(module_procedure (module_procedure_statement \"procedure\" @construct name: (_) @name))")
    ("interface"               . ,(concat "(interface (interface_statement (abstract_specifier)?"
                                          " \"interface\" @construct"
                                          " [((name) @name)"
                                          " ((operator) @name)"
                                          " ((assignment) @name)]?"
                                          "))"))
    ("derived_type_definition" . "(derived_type_definition (derived_type_statement \"type\" @construct (_) * (type_name) @name))")
    ("if_statement"            . "(if_statement (block_label_start_expression _ @name \":\")? \"if\" @construct)")
    ("where_statement"         . "(where_statement (block_label_start_expression _ @name \":\")? \"where\" @construct)")
    ("do_loop"                 . "(do_loop (block_label_start_expression _ @name \":\")? (do_statement \"do\" @construct))")
    ("block_construct"         . "(block_construct (block_label_start_expression _ @name \":\")? \"block\" @construct)")
    ("associate_statement"     . "(associate_statement (block_label_start_expression _ @name \":\")? \"associate\" @construct)")
    ("forall_statement"        . "(forall_statement (block_label_start_expression _ @name \":\")? \"forall\" @construct)")
    ("select_case_statement"   . "(select_case_statement (block_label_start_expression _ @name \":\")? \"select\" @construct)")
    ("select_type_statement"   . "(select_type_statement (block_label_start_expression _ @name \":\")? \"select\" @construct)")
    ("select_rank_statement"   . "(select_rank_statement (block_label_start_expression _ @name \":\")? \"select\" @construct)")
    ("enum"                    . "(enum (enum_statement \"enum\" @construct))")
    ("enumeration_type"        . ,(concat "(enumeration_type (enumeration_type_statement"
                                          " \"enumeration\" @construct \"type\" @construct2"
                                          " (_) *"
                                          " (type_name) @name"
                                          "))"))
    ("coarray_critical_statement" . "(coarray_critical_statement (block_label_start_expression _ @name \":\")? \"critical\" @construct)")
    ("coarray_team_statement"     . "(coarray_team_statement (block_label_start_expression _ @name \":\")? \"change\" @construct \"team\" @construct2)"))
  "Treesitter queries to extract relevant nodes for smart end completion.")


(defun f90-ts--complete-smart-end-extract (node capture)
  "Extract relevant nodes from CAPTURE obtain by a treesitter query.

Somehow documented anchoring at NODE does not work, and it needs to be done by
hand.  First search for root=NODE.  Then extract subsequent matches, some of
which are optional and possibly not present or in different order."
  (cl-loop
   for (cap_sym . n) in capture
   with collecting = nil
   until (and collecting (eq cap_sym 'root))
   when (and (not collecting)
             (eq cap_sym 'root)
             (treesit-node-eq n node))
      do (setq collecting t)
   when (and collecting (not (eq cap_sym 'root)))
      collect (cons cap_sym n)))


(defun f90-ts--complete-smart-end-name (node)
  "Extract construct type and name from NODE.
Return a list containing name, construct type and second construct type if
present or nil.  For example, for \"end enumeration type xyz\", return
the list (\"xyz\" \"enumeration\" \"type\".
Depending on type of NODE, extraction is different, as subtrees are built
differently.  The construct type itself is fixed, but lower/upper/title case
and the related start of the structure are also required for completion."
  (when-let* ((query (alist-get (treesit-node-type node)
                                f90-ts--complete-smart-end-query
                                nil
                                nil
                                #'string=))
              (query-root (concat query " @root"))
              (capture-all (treesit-query-capture node query-root))
              (capture     (f90-ts--complete-smart-end-extract node capture-all)))
    ;; @root is added in order to also get the root node of the captured subtree,
    ;; capture result is an alist (('root, root), ('construct, construct) ('name, name),
    ;; ('root, root), ('construct, construct) ('name, name), ...),
    ;; where root and name are the captured nodes,
    ;; we need to make sure that root=node, which might not be the case in nested block structure
    ;; (where the inner loop, if etc. also matches),
    ;; this could be done with the :anchor pattern, but it is rejected... syntax not valid?
    (let* ((construct-node (alist-get 'construct capture))
           (construct2-node (alist-get 'construct2 capture))
           (name-node (alist-get 'name capture)))
      (cl-assert construct-node
                 nil
                 "complete-smart-end: no construct node found")
      ;; in general there is no second construct name, exception: "enumeration type"
      (list
       (and name-node (treesit-node-text name-node t))
       (and construct-node (treesit-node-text construct-node t))
       (and construct2-node (treesit-node-text construct2-node t))))))


(defun f90-ts--complete-smart-end-compose (node)
  "Create an \"end construct name\" completion from NODE if applicable.
NODE is assumed to be the structure node (parent of the end structure node).
Construct is a string like \"subroutine\", \"function\", \"module\",
\"do\", \"block\" etc.
Return nil if construct name could not be recovered.  In general, this should
not happen, as `f90-ts--complete-end-structs' lists all supported structures."
  (when-let ((construct-name (f90-ts--complete-smart-end-name node)))
    (cl-assert construct-name
               nil
               "complete-smart-end: structure query failed")
    (let* ((name (car construct-name))
           (construct (cadr construct-name))
           (construct2 (caddr construct-name))
           (c0 (substring construct 0 1))
           (end
            (cond
             ((string= construct (upcase construct))
              "END")
             ((string= c0 (upcase c0))
              "End")
             (t
              "end"))))
    (string-join (delq nil (list end construct construct2 name))
                 " "))))


(defun f90-ts--complete-smart-end-show (node-struct)
  "Show the completion for root NODE-STRUCT of a structure statement.
Either jump to the start of the structure or show opening statement in the
message buffer.  Which action to perform depends on position and whether
`blink' is set."
  (unless (eq f90-ts-smart-end 'no-message)
    (let ((top-of-window (window-start))
          (start-struct (treesit-node-start node-struct)))
      (save-excursion
        (goto-char start-struct)
        (if (or (eq f90-ts-smart-end 'no-blink)
                (< start-struct top-of-window))
            (message "matches %s: %s"
                     (what-line)
                     (buffer-substring
                      (line-beginning-position)
                      (line-end-position)))
          (sit-for blink-matching-delay))))))


(defun f90-ts--complete-smart-end-end (node)
  "Find the end position of the end structure statement of NODE.
Together with the start position of the end structure statement it marks the
region to be replaced.
It should include trailing white space characters, but only if no comments or
commands (after a \";\") are present, in which case the original spacing should
be kept.  Moreover, incompletely typed text like in \"end subr_out\" should be
handled as well."
  (save-excursion
    (goto-char (treesit-node-end node))
    (skip-chars-forward "^;!\n")
    (let ((c (char-after)))
      (unless (or (eq c ?\n)
                  (null c))
        ;; this finally trims trailing white spaces if nothing else
        ;; is on the line
        (skip-chars-backward " \t")))
    (point)))


(defun f90-ts--complete-smart-end-node (node)
  "If NODE is an end struct statement, construct the completion.
It looks for structure type and name or label.

Example: complete \"end\" closing a subroutine of name mysub by
\"end subroutine mysub\".
After the changes, NODE will become stale.  The function returns the new
statement node representing the whole block.  This is used for the blink
option or statement indentation."
  ;; the region check ensures that end statements on continued lines are left alone
  (let ((type (treesit-node-type node))
        (beg (treesit-node-start node))
        (end (f90-ts--complete-smart-end-end node))
        (text (treesit-node-text node)))
    ;; make sure that we are looking at and end statement, the parser might add
    ;; and end_xyz_statement node in error recovery mode (e.g. at end of file)
    (when (and (= (line-number-at-pos beg) (line-number-at-pos end))
               (and text (string-match-p "^end" text))
               (member type f90-ts--complete-end-structs))
      (let ((node-struct (treesit-node-parent node))
            node-struct-new)
        (when-let ((completion (f90-ts--complete-smart-end-compose node-struct)))
          (let (beg-marker
                end-marker)
            (unwind-protect
                (progn
                  ;; beg marker should move with inserted/deleted text
                  ;; to stay at start of node
                  (setq beg-marker (copy-marker (treesit-node-start node-struct) t))
                  (setq end-marker (copy-marker (treesit-node-end node-struct) t))
                  ;; returns true if text was changed
                  (f90-ts--complete-replace-if-changed beg end completion)
                  (when (treesit-node-check node-struct 'outdated)
                    (setq node-struct-new (treesit-node-on (marker-position beg-marker)
                                                          (marker-position end-marker)))))
              (when beg-marker (set-marker beg-marker nil))
              (when end-marker (set-marker end-marker nil)))))
        ;; if nothing has changed new node is nil, return the original one
        (or node-struct-new node-struct)))))


(defun f90-ts--complete-smart-end-indent (node-struct)
  "Indent block represented by NODE-STRUCT.
This can be optionally invoked after smart end completion to indent the whole
block.  If indentation changes something, the tree is updated and node-struct
becomes stale.  In this case, the function return the node-struct-new,
otherwise nil."
  (let ((variant-saved f90-ts--align-continued-variant-tab)
        (beg (treesit-node-start node-struct))
        ;; end position of node-struct sometimes reaches into next line
        ;; (including the eos token)
        (end (save-excursion
               (goto-char (treesit-node-end node-struct))
               (if (bolp)
                   (1- (point))
                 (point))))
        beg-marker
        end-marker
        node-struct-new)
    (unwind-protect
        (progn
          ;; use region variant for indentation (no rotation of list
          ;; items on continued lines)
          (setq f90-ts--align-continued-variant-tab nil)
          (setq beg-marker (copy-marker beg t))
          (setq end-marker (copy-marker end t))
          (f90-ts--indent-and-complete-region-aux beg-marker end-marker)

          ;; if something was modified, then treesit-node-on forces a reparse
          ;; and node-probe /= node-struct, in this case set node-struct-new to node-probe
          ;; otherwise leave node-struct-new at nil, signalling that the old node is still valid
          (let ((node-probe (treesit-node-on (marker-position beg-marker)
                                             (marker-position end-marker))))

            (unless (treesit-node-eq node-struct node-probe)
              (setq node-struct-new node-probe)
              ;; signal that the region has been modified in case it was invoked
              ;; by some line operation which wants to keep track of modifications
              (setq f90-ts--indent-modified-outside-line t))))
      ;; revert to saved tab variant
      (setq f90-ts--align-continued-variant-tab variant-saved)
      (when beg-marker (set-marker beg-marker nil))
      (when end-marker (set-marker end-marker nil)))
    node-struct-new))


;; The idea for smart end completion is taken from the classic f90-mode.
(defun f90-ts--complete-smart-tab (indent-struct)
  "Provide context-aware completion using tree-sitter after indentation by tab.
Currently it handles end statements.

If INDENT-STRUCT is true, then indent the whole block with `indent-region'."
  (when f90-ts-smart-end
    (when-let* ((indent-node (f90-ts--node-at-indent-pos (point)))
                (start (treesit-node-start indent-node))
                (node (treesit-parent-while
                       indent-node
                       (lambda (n) (= start (treesit-node-start n)))))
                (end (treesit-node-end node)))
      (when (= (line-number-at-pos)
               (f90-ts--node-line node))
        (when-let ((node-struct (f90-ts--complete-smart-end-node node)))
          (when indent-struct
            ;; update node-struct, if indent changes anything
            (setq node-struct (or (f90-ts--complete-smart-end-indent node-struct)
                                  node-struct)))
          (f90-ts--complete-smart-end-show node-struct))))))


;;;------------------------------------------------------------------------------
;;; Indentation: auxiliary function
;;; mainly for handling leading ampersands in continued lines

(defmacro f90-ts--with-check-modified-line (&rest body)
  "Execute BODY, restoring unmodified status if current line is unchanged.

Note: do not use symbols `modified-before' and `line-before' symbols
in BODY."
  (declare (indent 0))
  `(let* ((modified-before (buffer-modified-p))
          (f90-ts--indent-modified-outside-line nil)
          (line-before (unless modified-before
                         (buffer-substring-no-properties
                          (line-beginning-position)
                          (line-end-position)))))
     ,@body
     (unless (or modified-before f90-ts--indent-modified-outside-line)
       (when (string= line-before
                      (buffer-substring-no-properties
                       (line-beginning-position)
                       (line-end-position)))
         (restore-buffer-modified-p nil)))))


(defmacro f90-ts--with-check-modified-region (beg end &rest body)
  "Execute BODY, restoring unmodified status if region BEG..END is unchanged.

Note: do not use symbols `modified-before' and `region-before' symbols
in BODY."
  (declare (indent 2))
  `(let* ((modified-before (buffer-modified-p))
          (region-before (unless modified-before
                           (buffer-substring-no-properties ,beg ,end))))
     ,@body
     (unless modified-before
       (when (string= region-before
                      (buffer-substring-no-properties ,beg ,end))
         (restore-buffer-modified-p nil)))))


(defun f90-ts--indent-leading-ampersand-column ()
  "Compute the column for a leading ampersand on the current line.
Uses `f90-ts-leading-ampersand-style' to determine placement.
For the `indent' style, uses the column of the first node of the
continued statement plus the configured offset."
  (pcase f90-ts-leading-ampersand-style
    (`(column . ,col)
     col)
    (`(indent . ,offset)
     (+ offset
        (let* ((node (f90-ts--node-at-indent-pos (point)))
               (parent (treesit-node-parent node))
               (pstmt-1 (f90-ts--previous-stmt-first node parent)))
          (f90-ts--node-column pstmt-1))))
    (_ (error "Invalid f90-ts-leading-ampersand-style: %S"
              f90-ts-leading-ampersand-style))))


(defun f90-ts--indent-blank-leading-amp-or-label-line ()
  "Blank a leading ampersand or statement label on the current line.
Returns nil if neither was found, \\='(amp) if an ampersand was
blanked, or \\='(label . label-text) if a statement label was
blanked."
  (unless (f90-ts--point-on-empty-line-p)
    (save-excursion
      (back-to-indentation)
      (let ((c (char-after (point))))
        (cond
         ;; leading ampersand
         ((and c (eq c ?&))
          ;; if this line contains a single ampersand and optionally some comment,
          ;; then we should considers this to be a trailing ampersand and keep it as is
          (unless (looking-at  "&\\s-*\\(?:!\\|$\\)")
            (let ((node (treesit-node-at (point))))
              ;; this excludes string literals
              (when (and node
                         (= (point) (treesit-node-start node))
                         (f90-ts--node-type-p node "&"))
                (delete-char 1)
                (insert " ")
                '(amp)))))
         ;; statement label
         ((and c (>= c ?0) (<= c ?9))
          (let ((node (treesit-node-at (point))))
            (when (and node
                       (= (point) (treesit-node-start node))
                       (f90-ts--node-type-p node "statement_label"))
              (let ((text (treesit-node-text node)))
                (delete-char (length text))
                (insert (make-string (length text) ?\s))
                (cons 'label text))))))))))


(defun f90-ts--indent-restore-leading-ampersand-line ()
  "Restore a leading ampersand after indentation.
It moves to the column determined by `f90-ts--indent-leading-ampersand-column'
inserting blanks and moving code to the right if necessary.
Then it pastes an ampersand at the determined column, leaving the code
positioned as it is."
  (let ((amp-col (f90-ts--indent-leading-ampersand-column)))
    (back-to-indentation)
    (let* ((indent-col (current-column))
           (delta (- indent-col amp-col)))
      (if (<= delta 0)
          (insert (make-string (- delta) ?\s))
        (backward-char delta )
        (delete-char 1))
      (insert "&"))))


(defun f90-ts--indent-restore-label-line (label-text)
  "Restore a statement_label after indentation.
It moves to the column determined by `f90-ts-stmt-label-column',
inserting blanks and moving code to the right if necessary.
Then it pastes LABEL-TEXT at the determined column, leaving the code
positioned as it is.  A blank is ensured after the label."
  (let* ((adj (car f90-ts-stmt-label-column))
         (col (cdr f90-ts-stmt-label-column))
         (label-len (length label-text))
         (label-col (if (eq adj 'right)
                        (max 0 (- col (1- label-len)))
                      col)))
    (back-to-indentation)
    (let* ((indent-col (current-column))
           (delta (- indent-col label-col)))
      (if (<= delta 0)
          (insert (make-string (- delta) ?\s)
                  label-text
                  " ")
        (backward-char delta)
        (insert label-text)
        ;; we need to remove label-len blank, currently are delta blanks,
        ;; hence if label-len <= delta-1 we can just remove the blanks and still have at least one left
        ;; otherwise we only can remove delta-1
        (delete-char (min label-len (1- delta)))))))


(defun f90-ts--indent-restore-leading-amp-or-label-line (amp-or-label)
  "Restore a leading ampersand or statement label from AMP-OR-LABEL.
AMP-OR-LABEL is a value previously returned by
`f90-ts--indent-blank-leading-amp-or-label-line'."
  (when (or amp-or-label
            (and f90-ts-leading-ampersand
                 (f90-ts--node-type-p
                  (f90-ts--first-node-on-line (point)) "&")))
    (pcase amp-or-label
      ((or 'nil '(amp))
       ;; if nil there was no ampersand but there is a virtual ampersand
       ;; signalling a continued line and f90-ts-leading-ampersand is non-nil
       (f90-ts--indent-restore-leading-ampersand-line))
      (`(label . ,label-text)
       (f90-ts--indent-restore-label-line label-text))
      (_ (cl-assert nil nil "unexpected value %S" amp-or-label)))))


(defun f90-ts--indent-blank-leading-amp-or-label-region (beg end)
  "Blank leading ampersands and statement labels for each line in BEG..END.
Returns a vector (one entry per line) of values as returned by
`f90-ts--indent-blank-leading-amp-or-label-line'."
  (save-excursion
    (goto-char beg)
    (let* ((line-beg (line-number-at-pos beg))
           (line-end (line-number-at-pos end))
           (n-lines  (- line-end line-beg -1))
           (vec      (make-vector n-lines nil)))
      ;; after blanking loop, each element of the vector vec will be one of:
      ;;   nil               – no amp, no label on the line
      ;;   (amp)             – had a leading & on the line
      ;;   (label . "12345") – had a statement label on the line
      (cl-loop
       for ix   from 0
       for line from line-beg to line-end
       do (progn
            (cl-assert (= (line-number-at-pos (point)) line)
                       nil
                       "line mismatch at index %d: expected %d, got %d"
                       ix line (line-number-at-pos (point)))
            (aset vec ix (f90-ts--indent-blank-leading-amp-or-label-line))
            (forward-line 1)))
      vec)))


(defun f90-ts--indent-restore-leading-amp-or-label-region (beg vec)
  "Restore leading ampersands and statement labels from BEG using VEC.
VEC is a vector as returned by
`f90-ts--indent-blank-leading-amp-or-label-region'."
  (save-excursion
    (goto-char beg)
    (let ((line-beg (line-number-at-pos beg)))
      (cl-loop
       for line from line-beg
       for amp-or-label across vec
       do (progn
            (cl-assert (= (line-number-at-pos (point)) line)
                       nil
                       "line mismatch at index %d: expected %d, got %d"
                       (- line line-beg) line (line-number-at-pos (point)))
            (f90-ts--indent-restore-leading-amp-or-label-line amp-or-label)
            (forward-line 1))))))


(defun f90-ts--indent-line-aux (&optional variant)
  "Indent a single line.
This is the default function for indentation of a single line.  Smart end
completion or other extra stuff is not executed by this function.
If provided VARIANT is the variant symbol for how to compute alignment in
multi-line statements.  Default value is `f90-ts-indent-list-line'.
Optional leading ampersands on continuation lines are temporarily
removed before calling `treesit-indent' and then restored at the
column determined by `f90-ts-leading-ampersand-style'."
  (let ((f90-ts--align-continued-variant-tab
         (or variant f90-ts-indent-list-line))
        (amp-or-label (f90-ts--indent-blank-leading-amp-or-label-line)))
    ;; do indentation without leading ampersand and statement label
    (treesit-indent)
    ;; where applicable insert statement label or leading ampersand
    ;; (ampersand if there was already one or if f90-ts-leading-ampersand
    ;; is non-nil)
    (save-excursion
      (f90-ts--indent-restore-leading-amp-or-label-line amp-or-label))))


(defun f90-ts--indent-and-complete-line-aux (variant indent-struct)
  "Auxiliary wrapper for indent-and-complete-line function.
VARIANT is the tab variant to be used.
If INDENT-STRUCT is true, and point is at some end statement, then
indent the whole block closed by the end statement after smart end
completion."
  ;; indent line, taking leading ampersand into account if necessary
  (f90-ts--indent-line-aux variant)
  ;; if end statement, do smart end completion
  (f90-ts--complete-smart-tab indent-struct))


(defun f90-ts--indent-stmt-region (beg end)
  "Apply indent region from begin of line at BEG to end of line at END.
Return true if the region was already properly indented (nothing was
changed)."
  (let ((beg-reg (save-excursion
                   (goto-char beg)
                   (line-beginning-position)))
        (end-reg (save-excursion
                   (goto-char end)
                   (line-end-position))))
    (let ((old-text (buffer-substring-no-properties beg-reg end-reg))
          (vec (f90-ts--indent-blank-leading-amp-or-label-region beg-reg end-reg)))
      (treesit-indent-region beg-reg end-reg)
      (f90-ts--indent-restore-leading-amp-or-label-region beg-reg vec)
      ;; place point properly on last line, but where does treesit-indent-region and
      ;; the restore function (which uses a save-excursion) put point?
      (skip-chars-forward "& \t")
      (string= old-text (buffer-substring-no-properties beg-reg end-reg)))))


(defun f90-ts--indent-and-complete-region-aux (beg end)
  "Indent region and execute smart end completion in region from BEG to END.
This is an auxiliary function for `f90-ts-indent-and-complete-region'.  But it
can also be called by line based operations triggering indentation and
completion for a region, like indent-stmt operations on an end struct line."
  (let (beg-marker end-marker)
    (unwind-protect
        (progn
          ;; beg marker should stay before inserted text
          ;; end marker should stay after inserted text
          (setq beg-marker (copy-marker beg))
          (setq end-marker (copy-marker end t))
          (f90-ts--with-check-modified-region beg-marker end-marker
            (f90-ts-complete-smart-end-region beg-marker end-marker)
            ;; remove leading ampersands, saving which lines had them
            (let ((vec (f90-ts--indent-blank-leading-amp-or-label-region
                        beg-marker end-marker)))
              (treesit-indent-region beg-marker end-marker)
              ;; restore ampersands or labels: beg-marker still points to the
              ;; first line (insertion-type nil keeps it before any text
              ;; treesit-indent may have inserted at the start).
              (f90-ts--indent-restore-leading-amp-or-label-region
               beg-marker vec))))
      (when beg-marker (set-marker beg-marker nil))
      (when end-marker (set-marker end-marker nil)))))


;;;------------------------------------------------------------------------------
;;; Indentation and smart end completion

;;; line indentation for <tab>, C-<tab> etc.
;;;  * f90-ts-indent-and-complete-stmt
;;;  * f90-ts-indent-and-complete-line
;;;  * f90-ts-indent-line
;;;  * f90-ts-indent-for-tab-command{-[2,3]}
;;;
;;; region indentation:
;;;  * f90-ts-indent-and-complete-region

(defun f90-ts-indent-and-complete-line ()
  "Indent and apply smart end completion to current line.
This is the default function for indent and smart complete of end lines,
bound to <tab>.  More advanced indentations of involved continued lines and
block structures is done by `f90-ts--indent-and-complete-stmt'"
  (interactive)
  (f90-ts--with-check-modified-line
   (f90-ts--indent-and-complete-line-aux
    f90-ts-indent-list-line
    nil)))


(defun f90-ts-indent-line (&optional variant)
  "Indent a single line.
This is the default function for indentation of a single line.  Smart end
completion or other extra stuff is not executed by this function.
If provided VARIANT is the variant symbol for how to compute alignment in
multi-line statements.  Default value is `f90-ts-indent-list-line'."
  (interactive)
  (f90-ts--with-check-modified-line
   (f90-ts--indent-line-aux variant)))


;; used by f90-ts-indent-and-complete-region
(defun f90-ts-complete-smart-end-region (beg end)
  "Execute smart end completion in region from BEG to END."
  (interactive
   (if (use-region-p)
       (list (region-beginning) (region-end))
     (list (point-min) (point-max))))

  (let ((beg-pos (if (markerp beg) (marker-position beg) beg))
        (end-pos (if (markerp end) (marker-position end) end))
        (end-marker nil))
    (unwind-protect
        (progn
          (setq end-marker (copy-marker end-pos))
          (catch 'f90-ts--past-end
           (cl-loop
            with pos = beg-pos
            for node = (treesit-search-forward
                        (treesit-node-at pos)
                        (lambda (n)
                          (let ((start-n (treesit-node-start n)))
                            ;; treesit-search-forward has no early abort
                            ;; option, without this, the search exhausts
                            ;; the whole remaining tree
                            (when (> start-n end-marker)
                              (throw 'f90-ts--past-end nil))
                            (and (<= pos start-n)
                                 (member (treesit-node-type n)
                                         f90-ts--complete-end-structs))))
                             nil ; search forward
                             nil ; only named nodes (end-structs are always named nodes)
                             )
            while node
            do (let ((node-start (treesit-node-start node)))
                 (f90-ts--complete-smart-end-node node)
                 (progn ; or better save-excursion (seems unnecessary?)
                   (goto-char node-start)
                   (forward-line 1)
                   (setq pos (point))))))
          ;; after finishing move to end of region
          (goto-char end-marker))
      (set-marker end-marker nil))))


(defun f90-ts-indent-and-complete-region (beg end)
  "Indent region and execute smart end completion in region from BEG to END.
It is based on the treesitter tree overlapping that region.
For region based indentation, smart end completion should be executed first,
as this might repair the tree.  Only then indentation should be done.
For single line the order does not matter.  Example:

module mod
contains
 subroutine sub()
 end function sub
end module mod

At the end function line, \"end\" represents the end subroutine statement,
hence indentation as well as smart end completion both work.  However,
the keyword \"function\" after \"end\" starts a new function and muddles the
subsequent tree.

Leading ampersands on continuation lines are temporarily removed before
calling `treesit-indent-region' and restored afterwards at the column
determined by `f90-ts-leading-ampersand-style'."
  (interactive
   (if (use-region-p)
       (list (region-beginning) (region-end))
     (list (point-min) (point-max))))
  (f90-ts--indent-and-complete-region-aux beg end))


(defun f90-ts-indent-and-complete-stmt ()
  "Perform indentation and smart end completion for a whole statement.
In general, this just calls `f90-ts--indent-and-complete-line-aux'
with non-nil for argument `indent-struct' to trigger indentation of a
whole structure if at end of some structure.

However, if within a continued line region, it determines the first line of
the current statement and performs indent region from this first line up to
and including the current line.  If indentation of current line has not
changed, then it indents the current line by invoking
`f90-ts--indent-and-complete' to apply rules like rotation of list context
items.  Otherwise it indents with default line choice.

If a region is active, then just invoke `f90-ts-indent-and-complete-region'"
  (interactive)
  (cond
   ((use-region-p)
    (f90-ts-indent-and-complete-region (region-beginning)
                                       (region-end)))

   ((not (f90-ts--pos-within-continued-stmt-p (point)))
    ;; just do indent-and-complete plus block indentation if applicable
    (f90-ts--with-check-modified-line
     (f90-ts--indent-and-complete-line-aux
      f90-ts-indent-list-line ; use default line variant
      t)))

   (t
    ;; multi-line statement
    (let* ((end (point))
           (node (f90-ts--first-node-on-line end))
           (first (f90-ts--first-node-of-stmt node))
           (beg (treesit-node-start first))
           (variant-line f90-ts-indent-list-line))
      (f90-ts--with-check-modified-region beg end
        (if (f90-ts--indent-stmt-region beg end)
            ;; no indentation applied, invoke indentation for current line
            ;; like doing rotational alignment,
            ;; no smart end completion necessary, as there is no end is involved
            (f90-ts--indent-line-aux variant-line)
          ;; statement up to current line was changed by indent statement region
          (back-to-indentation)
          (skip-chars-forward "& \t")))))))


(defun f90-ts-indent-for-tab-command-2 ()
  "Invoke `indent-for-tab-command' with variant `f90-ts-indent-list-line-2'.
The variant to be used can be customized.  Intended for use in key bindings."
  (interactive)
  (let ((f90-ts-indent-list-line f90-ts-indent-list-line-2))
    (indent-for-tab-command)))


(defun f90-ts-indent-for-tab-command-3 ()
  "Invoke `indent-for-tab-command' with variant `f90-ts-indent-list-line-3'.
The variant to be used can be customized.  Intended for use in key bindings."
  (interactive)
  (let ((f90-ts-indent-list-line f90-ts-indent-list-line-3))
    (indent-for-tab-command)))


;;;-----------------------------------------------------------------------------
;;; Break lines and add continuation symbol

(defun f90-ts--break-line-insert-amp-at-end ()
  "If not yet present, insert ampersand at end of line."
  (or (eq (char-before) ?&)
      (insert " &")))


;; Portions of the following code are adapted from `f90.el',
;; which is part of GNU Emacs.
(defun f90-ts-break-line ()
  "Break line at point, insert continuation marker where necessary and indent."
  (interactive "*")
  (cond
   ((f90-ts-in-string-p)
    (insert "&\n&"))

   ((f90-ts-in-openmp-p)
    ;; looks like a comment, but starting with special "!$" sequence,
    ;; breaking openmp lines requires a continuation symbol
    (let* ((node (treesit-node-at (point)))
           (prefix (f90-ts--comment-prefix node)))
      (delete-horizontal-space)
      (f90-ts--break-line-insert-amp-at-end)
      (insert "\n" prefix)))

   ((f90-ts-in-comment-p)
    (let* ((node (treesit-node-at (point)))
           (prefix (f90-ts--comment-prefix node)))
      (delete-horizontal-space)
      (insert "\n" prefix)))

   ((f90-ts--bol-to-point-blank-p)
    ;; this results in an empty line, no ampersand
    (delete-horizontal-space)
    (insert "\n"))

   (t
    (delete-horizontal-space)
    ;; note that a leading ampersand (depend on f90-ts-leading-ampersand)
    ;; is inserted by the indentation function, and thus does not need to
    ;; be added here
    (f90-ts--break-line-insert-amp-at-end)
    (newline 1)))
  ;; finally indent the new line after insertion of the newline
  (indent-according-to-mode))


(defun f90-ts--join-line-empty-prev ()
  "For point on an empty line, remove all blank lines before point.
After the operation point is after the last character on the non-blank line."
  (cl-assert (f90-ts--point-on-empty-line-p)
             nil "join-line-empty-prev requires point to be on an empty line")
  (let* ((prev (save-excursion
                 (skip-chars-backward "[ \t\n]")
                 (point)))
         (end (line-end-position)))
    (delete-region prev end)))


(defun f90-ts--join-line-empty-next ()
  "For point on an empty line, remove all blank lines after point.
Move point to first character on the line after it was originally placed."
  (cl-assert (f90-ts--point-on-empty-line-p)
             nil "join-line-empty-next requires point to be on an empty line")
  (let* ((next (save-excursion
                 (skip-chars-forward "[ \t\n]")
                 (line-beginning-position)))
         (beg (line-beginning-position)))
    (delete-region beg next)
    (back-to-indentation)))


(defun f90-ts--join-line-aux (first secnd is-prev)
  "Join lines between nodes FIRST and SECND.
For continued lines without comments in between, FIRST and SECND are the two
ampersand nodes (FIRST at end of line, SECND at beginning of next non-empty
line).  This function joins the two lines where FIRST and SECND are located,
and removes any empty lines in-between.

If IS-PREV is non-nil, then this is called from `f90-ts-join-line-prev',
otherwise from `f90-ts-join-line-next.'  This is used to place point after
deleting intermediate empty lines or if nothing can be joined."
  ;; note: due to comments and empty lines, a simple forward-line or backward-line
  ;; does not seem possible easily, instead reconstruct the (&, comment*, &)
  ;; sequence of nodes and use it for navigation and changes
  (let* ((is-amp-1st (f90-ts--node-type-p first "&"))
         (is-amp-2nd (f90-ts--node-type-p secnd "&"))
         (is-comment-1st (f90-ts--node-type-p first "comment"))
         (is-comment-2nd (f90-ts--node-type-p secnd "comment")))
    (cl-destructuring-bind (beg end post)
        (cond
         ((and is-amp-1st is-amp-2nd)
          ;; chose start and end positions such that the two ampersand are
          ;; removed as well
          (list (treesit-node-start first)
                (treesit-node-end secnd)
                (lambda ()
                  (fixup-whitespace)
                  (skip-chars-forward "[ \t]"))))

         ((and is-amp-1st is-comment-2nd)
          ;; append comment after ampersand
          (list (treesit-node-end first)
                (treesit-node-start secnd)
                (lambda () (insert " "))))

         ((and is-comment-1st
               is-comment-2nd
               (string= (f90-ts--comment-prefix first)
                        (f90-ts--comment-prefix secnd)))
          ;; two comments with same comment prefix, join comments
          (list (save-excursion
                  ;; if the comment has trailing blanks, we need to remove them
                  (goto-char (treesit-node-end first))
                  (skip-chars-backward "[ \t]")
                  (point))
                (+ (treesit-node-start secnd)
                   (length (f90-ts--comment-prefix secnd)))
                (lambda () (insert " "))))

         ((and (null is-comment-1st)
               is-comment-2nd)
          ;; some command and a comment, append comment
          (list (save-excursion
                  ;; if the node end position does not correspond with last non-blank characters
                  ;; (can happen for comments, but any other node, maybe), remove trailing blanks
                  (goto-char (treesit-node-end first))
                  (skip-chars-backward "[ \t]")
                  (point))
                (treesit-node-start secnd)
                (lambda () (insert " "))))

         (t
          ;; only delete intermediate empty lines
          (list (save-excursion
                  (goto-char (treesit-node-end first))
                  (line-beginning-position 2))
                (save-excursion
                  (goto-char (treesit-node-start secnd))
                  (line-beginning-position))
                (lambda () (if is-prev
                               (skip-chars-forward "[ \t]")
                               (skip-chars-backward "[ \t\n]"))))))

      (if (and beg end)
          (progn
            (delete-region beg end)
            (goto-char beg)
            (when post
              (funcall post)))
        (message "join failed: joining not possible")))))


(defun f90-ts--join-line-string (node pos1 pos2)
  "Join previous line with current line both belonging to a continued string.
The string is provided by NODE, which is of type string_literal.
Positions POS1 and POS2 are end of previous line and start of current line."
  (cl-assert (f90-ts--node-type-p node "string_literal")
             nil "node is not a string literal")
  (cl-assert (eq (char-before pos1) ?&)
             nil "character before pos1 is not an ampersand")
  (cl-assert (eq (char-after pos2) ?&)
             nil "character at pos2 is not an ampersand")
  (let ((beg (1- pos1))
        (end (1+ pos2)))
    (delete-region beg end)
    (goto-char beg)))


(defun f90-ts-join-line-prev ()
  "Join previous line with the current one, if part of a continued statement.
This is (partially) a counterpart to `f90-ts-break-line'.
If previous line has comments (at end, next line etc.) joining is not done."
  (interactive)
  (cond
   ((f90-ts--point-on-empty-line-p)
    (f90-ts--join-line-empty-prev))
   ((save-excursion
      (back-to-indentation)
      (bobp))
    ;; on first line and not empty, just move to beginning of line
    (beginning-of-line))
   (t
    (let* ((pos1 (save-excursion
                   (beginning-of-line)
                   (skip-chars-backward "[ \t\n]")
                   (point)))
           (pos2 (save-excursion
                   (beginning-of-line)
                   (skip-chars-forward "[ \t\n]")
                   (point)))
           (first (f90-ts--node-on-pos pos1 nil))
           (secnd (f90-ts--node-on-pos pos2 nil))
           (is-cont-str (and (f90-ts--node-type-p first "string_literal")
                             (f90-ts--node-type-p secnd "string_literal")
                             (treesit-node-eq first secnd))))
      ;;(f90-ts-log-msg :joinprev "pos1: %s, %s" pos1 first)
      ;;(f90-ts-log-msg :joinprev "pos2: %s, %s" pos2 secnd)
      ;;(f90-ts-log-msg :joinprev "is-cont-str: %s" is-cont-str)
      (cl-assert (or first (= pos1 (point-min)))
                 nil "first node is nil with wrong pos1")
      (cl-assert (or (null first)
                     is-cont-str
                     (or (= pos1 (treesit-node-end first))
                         ;; note that a comment might have trailing blanks, hence pos1
                         ;; might differ from node end position
                         (and (f90-ts--node-type-p first "comment")
                              (string-blank-p (buffer-substring pos1 (treesit-node-end first))))))
                 nil "first node has wrong end position %s" first)
      (cl-assert secnd nil "secnd node is nil")
      (cl-assert (or (= pos2 (treesit-node-start secnd))
                     is-cont-str)
                 nil "secnd node has wrong start position")

      (cond
       (is-cont-str
        ;; check that previous line is not a comment
        ;; (within the string, not yet supported by tree-sitter grammar)
        (if (eq (char-before pos1) ?&)
            ;; first and secnd are equal (established in is-cont-str)
            (f90-ts--join-line-string first pos1 pos2)
          (message "join failed: joining not possible (comment within string literal)")))

      (first
       (f90-ts--join-line-aux first secnd t))

      (t
       ;; all lines prior to point are empty, delete them
       (back-to-indentation)
       (delete-region pos1 (point))))))))


(defun f90-ts-join-line-next ()
  "Join current line with the next one, if part of a continued statement.
This is (partially) a counterpart to `f90-ts-break-line'.
If continued line has comments (at end, next line etc.) joining is not done."
  (interactive)
  (cond
   ((f90-ts--point-on-empty-line-p)
    (f90-ts--join-line-empty-next))
   ((save-excursion
      (end-of-line)
      (eobp))
    ;; on last line and not empty, just move to end of line
    (end-of-line))
   (t
    (let* ((pos1 (save-excursion
                   (end-of-line)
                   (skip-chars-backward "[ \t\n]")
                   (point)))
           (pos2 (save-excursion
                   (end-of-line)
                   (skip-chars-forward "[ \t\n]")
                   (point)))
           (first (f90-ts--node-on-pos pos1 nil))
           (secnd (f90-ts--node-on-pos pos2 nil))
           (is-cont-str (and (f90-ts--node-type-p first "string_literal")
                             (f90-ts--node-type-p secnd "string_literal")
                             (treesit-node-eq first secnd))))
      ;;(f90-ts-log-msg :joinnext "pos1: %s, %s" pos1 first)
      ;;(f90-ts-log-msg :joinnext "pos2: %s, %s" pos2 secnd)
      ;;(f90-ts-log-msg :joinnext "is-cont-str: %s" is-cont-str)
      (cl-assert first nil "first node is nil")
      (cl-assert (or (= pos1 (treesit-node-end first))
                     is-cont-str
                     ;; note that a comment might have trailing blanks, hence pos1
                     ;; might differ from node end position
                     (and (f90-ts--node-type-p first "comment")
                          (string-blank-p (buffer-substring pos1 (treesit-node-end first)))))
                 nil "first node has wrong end position")
      ;; in contrast to join-line-prev, if there are only blank lines after point,
      ;; pos2 is at point-max and secnd is the root node "translation_unit"
      (cl-assert secnd nil "secnd node is nil")
      (cl-assert (or (not (f90-ts--node-type-p secnd "translation_unit"))
                     (= pos2 (point-max)))
                 nil "secnd node is translation_unit with with wrong pos2")
      (cl-assert (or (f90-ts--node-type-p secnd "translation_unit")
                     is-cont-str
                     (= pos2 (treesit-node-start secnd)))
                 nil "secnd node has wrong start position")
      (cond
       ((f90-ts--node-type-p secnd "translation_unit")
        ;; all lines after point are empty, delete them
        (end-of-line)
        (delete-region (point) pos2))

       (is-cont-str
        ;; check that previous line is not a comment
        ;; (within the string, not yet supported by tree-sitter grammar)
        (if (eq (char-after pos2) ?&)
            ;; first and secnd are equal (established in is-cont-str)
            (f90-ts--join-line-string first pos1 pos2)
          (message "join failed: joining not possible (comment within string literal)")))
       (t
        (f90-ts--join-line-aux first secnd nil)))))))


;;;-----------------------------------------------------------------------------
;;; treesitter based region functions

(defun f90-ts--pos-first-nonspace (pos)
  "Determine position of first non-space character of line at POS."
  (save-excursion
    (goto-char pos)
    (beginning-of-line)
    (skip-chars-forward " \t")
    (point)))


(defun f90-ts--pos-last-nonspace (pos)
  "Determine position right after last non-space character of line at POS."
  (save-excursion
    (goto-char pos)
    (end-of-line)
    (skip-chars-backward " \t")
    (point)))


(defun f90-ts--pos-nonspace (pos)
  "Move point to first or last non-space character on current line.
If POS is before the first non-space character, move to it.
If POS is after the last non-space character, move to just after it.
Otherwise return POS."
  (let ((first (f90-ts--pos-first-nonspace pos))
        (last (f90-ts--pos-last-nonspace pos)))
    (cond
     ((< pos first) first)
     ((> pos last)  last)
     (t             pos))))


(defun f90-ts--mark-region-node (node &optional reversed)
  "Mark the region spanned by NODE.
If REVERSED is non-nil, then put point at start of region, otherwise point
is at end of region."
  (let ((beg (treesit-node-start node))
        (end (treesit-node-end node)))
    (if reversed
        (progn
          (goto-char beg)
          (push-mark end t t))
      (push-mark beg t t)
      (goto-char end))))


(defun f90-ts--smallest-child0-same-span (node)
  "Find the smallest child0 of NODE which spans the same region."
  (cl-loop for current = node then child
           for child = (treesit-node-child current 0 t)
           while (and child
                      (= (treesit-node-start child) (treesit-node-start current))
                      (= (treesit-node-end child) (treesit-node-end current)))
           finally return current))


(defun f90-ts--largest-node-same-span (node)
  "Find the largest ancestor of NODE which spans the same region.
Example: for (contains_statement \"contains\") `treesit-node-on' returns
\"contains\", but for navigation, we usually want the largest node with
same bounds, which is the contains_statement node."
  (treesit-parent-while
   node
   (lambda (n)
     (and (= (treesit-node-start n) (treesit-node-start node))
          (= (treesit-node-end n) (treesit-node-end node))))))


(defun f90-ts--smallest-named-node-containing-region (beg end)
  "Return the smallest named node fully containing region from BEG to END.
The node must be strictly larger than the region (BEG END)."
  (when-let* ((node (treesit-node-on beg end))
              (cover (treesit-parent-until
                      node
                      (lambda (n)
                        (and (treesit-node-check n 'named)
                             (<= (treesit-node-start n) beg)
                             (>= (treesit-node-end n) end)
                             (< (- end beg)
                                (- (treesit-node-end n) (treesit-node-start n)))))
                      t)))
    (f90-ts--largest-node-same-span cover)))


(defun f90-ts--node-on-pos (pos named)
  "Return the smallest node covering position POS.
If NAMED is non-nil, consider only named nodes, otherwise include anonymous
nodes as well.

Function `treesit-node-on' works on half-open regions.
It returns a node spanning the half-open region [beg, end).
If POS is at end position of node, then the region [POS,POS) is empty and
`treesit-node-on' returns a larger node.
This function queries at POS and at POS-1, and selects the smallest node
containing POS in the closed interval logic.
Example
subroutine sub()
   if (cond) then
   end if|
end subroutine sub
If point is at |, then the smallest named no is the end_statement node
for \"end if\".  However, treesit-node-on returns the subroutine node.
Querying at POS-1 gives the expected answer."
  (let* ((nodes (delq nil
                      (list (treesit-node-on pos   pos   nil named)
                            (when (< (point-min) pos)
                              (treesit-node-on (1- pos) (1- pos) nil named)))))
         (filtered (seq-filter (lambda (n) (and (<= (treesit-node-start n) pos)
                                                (<= pos (treesit-node-end n))))
                               nodes))
         (sorted (seq-sort (lambda (n1 n2) (< (- (treesit-node-end n1)
                                                 (treesit-node-start n1))
                                              (- (treesit-node-end n2)
                                                 (treesit-node-start n2))))
                           filtered)))
    (car sorted)))


(defun f90-ts-enlarge-region ()
  "Expand region to next larger node.
If no region is active, select the smallest named node at point.
If region is active, expand to the smallest named node that is larger
than current region."
  (interactive)
  (if (use-region-p)
      (let* ((beg (region-beginning))
             (end (region-end))
             (node (f90-ts--smallest-named-node-containing-region beg end)))
        (if node
            (f90-ts--mark-region-node node
                                      f90-ts-mark-region-reversed)
          (message "no tree-sitter node found enlarging current region")))
    ;; no active region, select smallest named node at point
    ;; (but move point to nonspace part first)
    (if-let* ((pos (f90-ts--pos-nonspace (point)))
              (node-on (f90-ts--node-on-pos pos 'named))
              (node (f90-ts--largest-node-same-span node-on)))
        (f90-ts--mark-region-node node
                                  f90-ts-mark-region-reversed)
      (message "no tree-sitter node found at point"))))


(defun f90-ts-child0-region ()
  "Find smallest node covering region.
Then reduce region to its first child.  If there are further first child with
same region, return the smallest of these grandchildren."
  (interactive)
  (if (use-region-p)
      (if-let* ((beg (region-beginning))
                (end (region-end))
                (node-on (treesit-node-on beg end))
                (node (f90-ts--smallest-child0-same-span node-on))
                (child0 (treesit-node-child node 0 t)))
          (f90-ts--mark-region-node child0
                                    f90-ts-mark-region-reversed)
        (message "no tree-sitter child0 found for current region"))
    (message "no active region")))


(defun f90-ts-prev-region ()
  "Find smallest node covering current marked region.
If the node spans the current region, then mark its previous sibling.
Otherwise mark the region spanned by the node itself (like enlarge-region)."
  (interactive)
  (if (use-region-p)
      (if-let* ((beg (region-beginning))
                (end (region-end))
                (node-on (treesit-node-on beg end))
                (node (f90-ts--largest-node-same-span node-on))
                (node-mark (if (and (= beg (treesit-node-start node))
                                    (= end (treesit-node-end node)))
                               (treesit-node-prev-sibling node t)
                             node)))
          (f90-ts--mark-region-node node-mark
                                    f90-ts-mark-region-reversed)
        (message "no tree-sitter previous sibling found for current region"))
    (message "no active region")))


(defun f90-ts-next-region ()
  "Find smallest node covering current marked region.
If the node spans the current region, then mark its next sibling.
Otherwise mark the region spanned by the node itself (like enlarge-region)."
  (interactive)
  (if (use-region-p)
      (if-let* ((beg (region-beginning))
                (end (region-end))
                (node-on (treesit-node-on beg end))
                (node (f90-ts--largest-node-same-span node-on))
                (node-mark (if (and (= beg (treesit-node-start node))
                                    (= end (treesit-node-end node)))
                               (treesit-node-next-sibling node t)
                             node)))
          (f90-ts--mark-region-node node-mark
                                    f90-ts-mark-region-reversed)
        (message "no tree-sitter next sibling found for current region"))
    (message "no active region")))


;;;-----------------------------------------------------------------------------
;;; Comment region using some prefix

(defun f90-ts--comment-region-ins-del (beg end prefix)
  "Insert or delete PREFIX at each line between BEG and END."
  (let* ((prefix-trimmed (string-trim-right prefix))
         (prefix-trimmed-re (regexp-quote prefix-trimmed))
         (uncomment-re (concat "\\s-*\\(?1:" prefix-trimmed-re "\\)")))
    (goto-char beg)
    (beginning-of-line)
    (cl-loop
     do (cond
         ((looking-at uncomment-re)
          (delete-region (match-beginning 1) (match-end 1))
          (when (looking-at-p "[ \t]+$")
            ;; after deletion, we have an empty line, remove trailing blanks
            (delete-region (point) (line-end-position))))
         ((looking-at-p "[ \t]*$")
          ;; avoid trailing blanks on empty lines
          (insert prefix-trimmed))
         (t
          (insert prefix)))
     while (and (zerop (forward-line 1))
                (< (point) end)))))


(defun f90-ts--comment-region-adjust (beg end prefix)
  "Adjust indentation of code between BEG and END commented by PREFIX.
After pasting PREFIX and indenting the commented region, the commented code
is adjusted to preserve original indentation as far as possible.  This also
depends on option `f90-ts-comment-prefix-keep-indent'.  This also takes into
account, that different types of prefixes might be indented differently,
depending on `f90-ts-special-comment-rules'."
    (goto-char end)
    ;; if end marker is at end of line, skip that line
    (if (bolp)
        (forward-line -1)
      (beginning-of-line))

    (let* ((prefix-re (regexp-quote prefix))
           (adjust-re (concat "\\(?1:\\(?2:\\s-*\\)" prefix-re "\\)\\(?3:\\s-*\\)"))
           (min-len-after
            ;; determine maximal number of blanks we can delete in each line safely,
            ;; using the same number for each line preserves relative indentation
            (cl-loop
             do (beginning-of-line)
             if (looking-at adjust-re)
             minimize (let* ((cap-group-before (if f90-ts-comment-prefix-keep-indent 1 2))
                             (len-before (length (match-string cap-group-before)))
                             (after (match-string 3)))
                        (min len-before (length after)))
             while (and (> (point) beg)
                        (zerop (forward-line -1))))))

      ;; delete blanks uniformly in a second pass, but only
      ;; if blanks can be removed at all
      (when (and min-len-after
                 (> min-len-after 0))
        (goto-char end)
        (if (bolp)
            (forward-line -1)
          (beginning-of-line))
        (cl-loop
         do (when (looking-at adjust-re)
              (delete-region (match-beginning 3)
                             (+ (match-beginning 3) min-len-after)))
         while (and (> (point) beg)
                    (zerop (forward-line -1)))))))


;; The following code was originally adapted from `f90.el' (part of GNU Emacs).
(defun f90-ts-comment-region-with-prefix (beg-region end-region prefix)
  "Comment/uncomment every line in the region using comment PREFIX.
Region is given by BEG-REGION and END-REGION.

Insert comment prefix at every line in the region, taking special comment
rules for indentation of comment prefix into account.

If the prefix is already present, then remove it and uncomment the line.

Note that prefixes are allowed to have trailing blanks.  These are inserted
as well.  However, for uncommenting, the trimmed prefix is used."
  (let ((beg (copy-marker beg-region))
        (end (copy-marker end-region t)))
    (unwind-protect
        (progn
          ;; pass 1 (insert/delete comment prefix)
          (f90-ts--comment-region-ins-del beg end prefix)
          ;; pass 2
          (treesit-indent-region beg end)
          ;; pass 3 (adjust indentation within commented part)
          (f90-ts--comment-region-adjust beg end prefix)

          (goto-char end))
      (set-marker beg nil)
      (set-marker end nil))))


(defun f90-ts-comment-region-default (beg-region end-region)
  "Comment/uncomment every line in the region using default !!$ prefix.
Region is given by BEG-REGION and END-REGION."
  (interactive "*r")
  (f90-ts-comment-region-with-prefix beg-region
                                     end-region
                                     f90-ts-comment-region-prefix))


(defun f90-ts-comment-region-custom (beg-region end-region prefix)
  "Comment/uncomment every line in the region using custom PREFIX.
Region is given by BEG-REGION and END-REGION.
If called interactively, prompt for a prefix from
`f90-ts-extra-comment-prefixes' and `f90-ts-comment-region-prefix'."
  (interactive
   (list
    (progn
      (barf-if-buffer-read-only)
      (region-beginning))
    (region-end)
    (completing-read "choose comment prefix: "
                     (append f90-ts-extra-comment-prefixes
                             (list f90-ts-comment-region-prefix))
                     nil t nil nil (car f90-ts-extra-comment-prefixes))))
  (f90-ts-comment-region-with-prefix beg-region
                                     end-region
                                     prefix))


;;;-----------------------------------------------------------------------------
;;; Imenu and navigation: queries and further properties

(defconst f90-ts--nav-queries
  `(("program"
     :label   "program"
     :face    f90-ts-nav-module-face
     :capture name_program
     :query   "(program (program_statement \"program\" (name) @name_program))")

    ("module"
     :label   "module"
     :face    f90-ts-nav-module-face
     :capture name_module
     :query   "(module (module_statement \"module\" (name) @name_module))")

    ("submodule"
     :label   "submodule"
     :face    f90-ts-nav-module-face
     :capture name_submodule
     :query   "(submodule (submodule_statement \"submodule\" (name) @name_submodule))")

    ("subroutine"
     :label   "subroutine"
     :face    f90-ts-nav-procedure-face
     :capture name_subroutine
     :query   "(subroutine (subroutine_statement \"subroutine\" name: (name) @name_subroutine))")

    ("function"
     :label   "function"
     :face    f90-ts-nav-procedure-face
     :capture name_function
     :query   "(function (function_statement \"function\" name: (name) @name_function))")

    ("module_procedure"
     :label   "module procedure"
     :face    f90-ts-nav-procedure-face
     :capture name_module_proc
     :query   "(module_procedure (module_procedure_statement \"module\" \"procedure\" name: (name) @name_module_proc))")

    ("derived_type_definition"
     :label   "derived type"
     :face    f90-ts-nav-type-face
     :capture name_dt_type
     :query   "(derived_type_definition (derived_type_statement \"type\" (_) * (type_name) @name_dt_type))")

    ("interface"
     :label   "interface"
     :face    f90-ts-nav-procedure-face
     :capture name_interface
     :query   ,(concat "(interface (interface_statement (abstract_specifier)?"
                       " \"interface\""
                       " [((name) @name_interface)"
                       "  ((operator) @name_interface)"
                       "  ((assignment) @name_interface)]?"
                       "))"))

    ("variable_declaration"
     :label   "variable"
     :face    f90-ts-nav-variable-face
     :capture name_var_decl
     :query   ,(concat "(variable_declaration"
                       " declarator:"
                       " [((identifier) @name_var_decl)"
                       "  (init_declarator left: (identifier) @name_var_decl)"
                       "  (pointer_init_declarator left: (identifier) @name_var_decl)"
                       "  (sized_declarator (identifier) @name_var_decl)])")
     :leaf t))
  "Query specification and properties for Imenu, nav-buffer and nav-tree menu.
Each entry is a list (KEY PLIST) where KEY is a string returned by the related
Tree-sitter node type, and PLIST may contain:
  :label   Display string used in Imenu and menus.
  :capture Symbol matching the Tree-sitter capture name for the node name.
  :query   Tree-sitter query string capturing the relevant node name.
  :leaf    Non-nil if entries should be treated as leaf nodes (no children).")


(defconst f90-ts--nav-capture-key-alist
  (cl-loop for (key . plist) in f90-ts--nav-queries
           collect (cons (plist-get plist :capture) key))
  "Alist mapping Tree-sitter capture symbols to query-key.
Each entry is (CAPTURE-SYMBOL . KEY) where KEY is the
car of the corresponding entry in `f90-ts--nav-queries'.")


(defun f90-ts--nav-entry-label (key name)
  "Return the display label string for KEY and NAME.
KEY is a symbol from `f90-ts--nav-queries'.  NAME is the identifier or name
of the entry.
The base label is looked up via :label in the query plist.  If NAME is
non-nil and non-empty it is appended as \"LABEL: NAME\"."
  (let* ((plist (alist-get key f90-ts--nav-queries))
         (label-base (plist-get plist :label)))
    (if (and name (not (string-empty-p name)))
        (format "%s: %s" label-base name)
      label-base)))


(defun f90-ts--nav-entry-face (key)
  "Return the face for KEY, a symbol from `f90-ts--nav-queries'.
If no :face property is present, then return `f90-ts-nav-variable-face'
as default face."
  (or (plist-get (alist-get key f90-ts--nav-queries) :face)
      'f90-ts-nav-variable-face))


;;;-----------------------------------------------------------------------------
;;; Imenu

(defconst f90-ts--imenu-query-compiled
  (let ((query-string
         (mapconcat
          (lambda (entry)
            (plist-get (cdr entry) :query))
          f90-ts--nav-queries
          "\n")))
    (treesit-query-compile 'fortran query-string))
  "Pre-compiled global query for a one-pass scan to build imenu.")


(defun f90-ts--imenu-spec-for-type (type)
  "Return the plist for TYPE from `f90-ts--nav-queries'."
  (alist-get type f90-ts--nav-queries nil nil #'string=))


(defun f90-ts--imenu-name-pos-fn (node)
  "Return list of (NAME . POSITION) for NODE using its associated imenu query.
This extracts the name by taking the first captured node from the query,
regardless of the capture name symbol used."
  (let* ((type  (treesit-node-type node))
         (spec  (f90-ts--imenu-spec-for-type type))
         (query (plist-get spec :query))
         (caps  (and query (treesit-query-capture node query))))
    (cl-loop for (_ . node) in caps
             collect (cons (treesit-node-text node t)
                           (treesit-node-start node)))))


(defun f90-ts--imenu-group-items (items)
  "Group flat ITEMS list into ((LABEL (NAME . MARKER) ...) ...) for Imenu.
Each element of ITEMS is (LABEL NAME . MARKER)."
  (cl-loop for (label . group) in (seq-group-by #'car items)
           collect (cons label
                         (mapcar (lambda (item)
                                   (cons (cadr item) (caddr item)))
                                 group))))


(defun f90-ts--imenu-captures-to-items (captures)
  "Convert raw CAPTURES from `treesit-query-capture' to a flat list of items.
Items are triples (LABEL NAME MARKER), where LABEL is derived from the
capture symbol via `f90-ts--nav-queries'."
  (cl-loop for (cap-sym . node) in captures
           for key   = (alist-get cap-sym f90-ts--nav-capture-key-alist)
           for label = (and key (plist-get (alist-get key f90-ts--nav-queries) :label))
           when label
           collect (list label
                         (treesit-node-text node t)
                         (set-marker (make-marker)
                                     (treesit-node-start node)))))


(defun f90-ts-simple-imenu ()
  "Return an Imenu index for the current buffer using a single query pass.
Using `treesit-simple-imenu' is far more expensive computationally."
  (let* ((root     (treesit-buffer-root-node))
         (captures (treesit-query-capture root f90-ts--imenu-query-compiled))
         (items    (f90-ts--imenu-captures-to-items captures)))
    (f90-ts--imenu-group-items items)))


;;;-----------------------------------------------------------------------------
;;; Navigation tree builder (for use with fortran easy-menu and navigation buffer)
;;; (this mirrors imenu, but it is recursively constructed)

(defvar-local f90-ts--nav-tree-cache-root nil
  "The treesit root node at the time of the last navigation tree build.
Used to verify via `treesit-node-eq' whether the cache is still valid.")


(defvar-local f90-ts--nav-tree-cache nil
  "The last generated sparse navigation tree.")


(defconst f90-ts--nav-tree-query-compiled
  (let ((query-string
         (mapconcat
          (lambda (entry)
            (let ((query (plist-get (cdr entry) :query)))
              ;; wrap each original nav query with @struct on the outer form
              ;; Example:
              ;;   (subroutine (...) @name_subroutine)
              ;; becomes:
              ;;   ((subroutine (...) @name_subroutine) @struct)
              (concat "(" query " @struct)")))
          f90-ts--nav-queries
          "\n")))
    (treesit-query-compile 'fortran query-string))
  "Pre-compiled Tree-sitter query for menu generation with struct captures.")


(defun f90-ts--nav-tree-combine-captures (captures)
  "Pair consecutive (struct name struct name ...) in CAPTURES.
Return a list of triples (name-type struct-node name-node) where name-type
is capture symbol of name and nodes are captured node of struct and name.

In general the captures have exactly one name for a struct.  But in some cases,
it might be possible that there is zero, one or more name captures in the list.
Return a triple for each (struct name_i) pair with name_i being one of the name
nodes after struct."
  (let ((groups (mapcar #'nreverse
                        (nreverse (cl-reduce
                                   (lambda (acc cap)
                                     (if (eq (car cap) 'struct)
                                         (push (list cap) acc) ; build new struct sublist
                                       (setcar acc (cons cap (car acc)))
                                       acc))
                                   captures
                                   :initial-value nil)))))

    (cl-mapcan (lambda (group)
                 (let ((struct-node (cdar group))
                       (names (cdr group)))
                   (cl-loop for (cap-sym . name-node) in names
                            collect (list cap-sym struct-node name-node))))
               groups)))


(defun f90-ts--nav-tree-node-hash-fn (node)
  "Hash function for NODE using its start position."
  (treesit-node-start node))


(define-hash-table-test 'f90-ts--nav-tree-node-hash-test
  #'treesit-node-eq
  #'f90-ts--nav-tree-node-hash-fn)


(defun f90-ts--nav-tree-node-table (root)
  "Capture all menu nodes under ROOT in one pass using name-struct pairing.
Returns a hash table mapping each struct node to a list of (KEY NAME POS)
triples, where KEY is a type name from `f90-ts--nav-queries'."
  (let* ((captures (treesit-query-capture root f90-ts--nav-tree-query-compiled))
         (entities (f90-ts--nav-tree-combine-captures captures))
         (table (make-hash-table :test 'f90-ts--nav-tree-node-hash-test)))
    (cl-loop
     for (cap-sym struct-node name-node) in entities
     for key = (alist-get cap-sym f90-ts--nav-capture-key-alist)
     do (progn
          (cl-assert key nil "key is nil for capture-symbol = %s, struct = %s, name = %s"
                     cap-sym struct-node name-node)
          (cl-pushnew
           (list key
                 (treesit-node-text name-node t)
                 (treesit-node-start name-node))
           (gethash struct-node table)
           :test #'equal)))
    (maphash (lambda (k v) (puthash k (nreverse v) table)) table)
    table))


(defun f90-ts--nav-tree-predicate (node-table)
  "Return a predicate that accepts nodes present in NODE-TABLE."
  (lambda (node)
    (gethash node node-table)))


(defun f90-ts--nav-tree-process-fn (node-table)
  "Return a PROCESS-FN for `treesit-induce-sparse-node' for navigate menu.
The returned process function replaces a raw node with its entry list
from NODE-TABLE."
  (lambda (node)
    (gethash node node-table)))


(defun f90-ts--nav-tree-build ()
  "Build the sparse navigation tree for the current buffer.
If the cached tree is still valid, return this.
Otherwise build the tree and cache it along with its root node in
`f90-ts--nav-tree-cache' and `f90-ts--nav-tree-cache-root'.

A sparse node in the tree is a pair (ENTRIES . CHILDREN),
where ENTRIES is a list of triples (KEY NAME POS) as produced by
`f90-ts--nav-tree-node-table'.  CHILDREN is a list of sparse nodes
which are children of the sparse node.
If a sparse node has children, then ENTRIES should contain at most one triple.
For example, the root node usually is not interesting itself but has a list of
children, so ENTRIES=nil but CHILDREN is non-empty."
  (let ((root (treesit-buffer-root-node)))
    (if (and f90-ts--nav-tree-cache-root
             f90-ts--nav-tree-cache
             (treesit-node-eq root f90-ts--nav-tree-cache-root)
             (not (treesit-node-check f90-ts--nav-tree-cache-root 'outdated)))
        f90-ts--nav-tree-cache
      (let* ((node-table  (f90-ts--nav-tree-node-table root))
             (sparse-tree (treesit-induce-sparse-tree
                           root
                           (f90-ts--nav-tree-predicate node-table)
                           (f90-ts--nav-tree-process-fn node-table))))
        (setq f90-ts--nav-tree-cache-root root)
        (setq f90-ts--nav-tree-cache      sparse-tree)
        sparse-tree))))


;;;-----------------------------------------------------------------------------
;;; Easy-menu renderer from navigation tree

(defun f90-ts--nav-menu-entry (label marker)
  "Return a clickable easy-menu vector for LABEL jumping to MARKER."
  (vector label
          (lambda ()
            (interactive)
            (switch-to-buffer (marker-buffer marker))
            (goto-char marker)
            (push-mark))
          t))


(defun f90-ts--nav-menu-from-leaf (entry)
  "Build a `f90-ts--nav-menu-entry' from ENTRY=(KEY NAME POS)."
  (let* ((key    (nth 0 entry))
         (name   (nth 1 entry))
         (pos    (nth 2 entry))
         (label  (f90-ts--nav-entry-label key name))
         (marker (set-marker (make-marker) pos)))
    (f90-ts--nav-menu-entry label marker)))


(defun f90-ts--nav-menu-from-branch (entries children)
  "Build two `f90-ts--nav-menu-entry' items from a sparse node and its CHILDREN.
ENTRIES contains exactly one triple for a non-leaf structure."
  (let* ((first  (car entries))
         (key    (nth 0 first))
         (name   (nth 1 first))
         (pos    (nth 2 first))
         (label  (f90-ts--nav-entry-label key name))
         (marker (set-marker (make-marker) pos)))
    (list
     (f90-ts--nav-menu-entry label marker)
     (cons "[+]"
           (cl-mapcan #'f90-ts--nav-menu-from-sparse-tree children)))))


(defun f90-ts--nav-menu-from-sparse-tree (sparse-node)
  "Recursively convert SPARSE-NODE to easy-menu format.
SPARSE-NODE is a pair (ENTRIES . CHILDREN), where ENTRIES is produced by
`f90-ts--nav-tree-node-table' and CHILDREN are children of SPARSE-NODE,
and itself SPARSE-NODES."
  (let* ((entries  (car sparse-node))
         (children (cdr sparse-node)))
    (cond
     ;; root sentinel (root of a sparse tree, which usually is a forest
     ;; rather than a tree), just walk the forest
     ((null entries)
      (cl-mapcan #'f90-ts--nav-menu-from-sparse-tree children))

     ;; leaf node (either something like a variable declaration or
     ;; some structure without sub-nodes like an empty subroutine body).
     ((null children)
      (mapcar #'f90-ts--nav-menu-from-leaf entries))

     ;; a branch, which is a structure contains other interesting items
     ;; (like a subroutine with variable declarations inside it)
     (t
      (f90-ts--nav-menu-from-branch entries children)))))


(defun f90-ts--nav-menu-tree (_current-menu)
  "Return the easy-menu structure for the current buffer."
  (let* ((sparse-tree (f90-ts--nav-tree-build))
         (items       (f90-ts--nav-menu-from-sparse-tree sparse-tree)))
    (cons (f90-ts--nav-menu-entry "Top of buffer" (point-min-marker))
          (or items '(["(empty)" ignore t])))))


;;;-----------------------------------------------------------------------------
;;; Navigation buffer: based on navigation tree

;; TODO:
;; * open a file: nav buffer not switched
;; * mouse actions
;; * show/hide variables
;; * use shortcuts (mod, submod, prog, subr, fun, var, type ifc)
;; * move point (e.g. by helm-projectile-grep and other actions) does not always sync the buffer

(defvar f90-ts--nav-buffer-name "*F90-TS Navigate*"
  "Buffer name for the f90-ts navigation buffer.")


(defvar-local f90-ts--nav-buffer-source nil
  "The Fortran source buffer this nav panel was spawned from.")


(defvar f90-ts-nav-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "RET") #'f90-ts-nav-buffer-jump)
    (define-key map (kbd "SPC") #'f90-ts-nav-buffer-preview)
    (define-key map (kbd "n")   #'next-line)
    (define-key map (kbd "p")   #'previous-line)
    (define-key map (kbd "g")   #'f90-ts-nav-buffer-refresh)
    (define-key map (kbd "q")   #'f90-ts-nav-buffer-quit)
    (define-key map (kbd "C-g") #'f90-ts-nav-buffer-quit)
    map)
  "Keymap for `f90-ts-nav-mode'.")


;;;-----------------------------------------------------------------------------
;;; Navigation buffer: map sparse tree to navigation buffer tree

(cl-defstruct f90-ts-nav-buffer-node
  "A node in the navigation buffer tree.
KIND is the type string (\"subroutine\", \"module\", …), which serves as a key..
LABEL is the display string.  MARKER points into the source buffer.
CHILDREN is a (possibly empty) list of child nodes."
  kind label marker face children)


(defun f90-ts--nav-buffer-node-from-entry (entry &optional children)
  "Build a `f90-ts-nav-buffer-node' from a (KEY NAME POS) ENTRY and CHILDREN."
  (let* ((key    (nth 0 entry))
         (name   (nth 1 entry))
         (pos    (nth 2 entry))
         (label  (f90-ts--nav-entry-label key name))
         (face   (f90-ts--nav-entry-face key))
         (marker (set-marker (make-marker) pos)))
    (make-f90-ts-nav-buffer-node :kind     key
                                 :label    label
                                 :marker   marker
                                 :face     face
                                 :children (or children '()))))


(defun f90-ts--nav-buffer-from-sparse-tree (sparse-node)
  "Convert SPARSE-NODE into a list of nav tree nodes.
SPARSE-NODE is from `f90-ts--nav-tree-build' and originates in
`f90-ts--nav-tree-node-table'.  It is a pair (ENTRIES . CHILDREN),
where each ENTRY in the list of ENTRIES has the form (KEY NAME POS).
CHILDREN are further sparse nodes of the same shape.

Returns a flat list of `f90-ts-nav-buffer-node' structs."
  (let* ((entries  (car sparse-node))
         (children (cdr sparse-node)))
    (cond
     ;; root sentinel: no entries, just walk the forest
     ((null entries)
      (cl-mapcan #'f90-ts--nav-buffer-from-sparse-tree children))

     ;; leaf node: one nav tree node per entry, no children
     ((null children)
      (mapcar #'f90-ts--nav-buffer-node-from-entry entries))

     ;; branch: build the parent node(s) with converted children
     (t
      (let ((child-nodes (cl-mapcan #'f90-ts--nav-buffer-from-sparse-tree children)))
        ;; there should only be exactly one entry for a non-leaf node,
        ;; be defensive: only the first gets the children
        (cons (f90-ts--nav-buffer-node-from-entry (car entries) child-nodes)
              (mapcar #'f90-ts--nav-buffer-node-from-entry (cdr entries))))))))


;;;-----------------------------------------------------------------------------
;;; Navigation buffer: rendering, interaction

(defvar-local f90-ts--nav-buffer-idle-timer nil
  "Idle timer for automatic nav buffer refresh after source edits.")


(defvar-local f90-ts--nav-buffer-last-sync-pos nil
  "Last value of point when nav buffer was synced.
This is used to avoid excessive syncing.")


(defun f90-ts--nav-buffer-render-nodes (nodes depth)
  "Insert NODES at DEPTH into the nav buffer and recurse into children."
  (cl-loop for node in nodes
           for indent = (make-string (* depth 2) ?\s)
           for face   = (f90-ts-nav-buffer-node-face node)
           for text   = (concat indent
                                (propertize (f90-ts-nav-buffer-node-label node)
                                            'face face))
           do (progn
                (insert text)
                (put-text-property (line-beginning-position) (line-end-position)
                                   'f90-ts-nav-marker
                                   (f90-ts-nav-buffer-node-marker node))
                (put-text-property (line-beginning-position) (line-end-position)
                                   'f90-ts-nav-kind
                                   (f90-ts-nav-buffer-node-kind node))
                (insert "\n")
                (f90-ts--nav-buffer-render-nodes
                 (f90-ts-nav-buffer-node-children node) (1+ depth)))))


(defun f90-ts--nav-buffer-render (tree-nodes)
  "Render TREE-NODES into the current navigation buffer."
  (let ((inhibit-read-only t))
    (erase-buffer)
    (f90-ts--nav-buffer-render-nodes tree-nodes 0)
    (goto-char (point-min))))


(defun f90-ts--nav-buffer-marker-at-point ()
  "Return the marker stored on the current line, or nil."
  (get-text-property (line-beginning-position) 'f90-ts-nav-marker))


(defun f90-ts-nav-buffer-jump ()
  "Jump to the entry on the current line and close the nav buffer."
  (interactive)
  (when-let ((marker (f90-ts--nav-buffer-marker-at-point)))
    (unless (buffer-live-p (marker-buffer marker))
      (user-error "Source buffer no longer live"))
    (pop-to-buffer (marker-buffer marker))
    (goto-char marker)
    (recenter)))


(defun f90-ts-nav-buffer-preview ()
  "Preview the entry at point without leaving the nav buffer."
  (interactive)
  (when-let ((marker (f90-ts--nav-buffer-marker-at-point)))
    (unless (buffer-live-p (marker-buffer marker))
      (user-error "Source buffer no longer live"))
    (with-selected-window (display-buffer (marker-buffer marker)
                                          '(display-buffer-reuse-window))
      (goto-char marker)
      (recenter)
      (pulse-momentary-highlight-one-line (point)))))


(defun f90-ts--nav-buffer-schedule-refresh ()
  "Schedule a nav buffer refresh.
It is scheduled after `f90-ts-nav-buffer-idle-delay' seconds of the source
buffer being idle."
  (when f90-ts--nav-buffer-idle-timer
    (cancel-timer f90-ts--nav-buffer-idle-timer))
  (setq f90-ts--nav-buffer-idle-timer
        (run-with-idle-timer f90-ts-nav-buffer-idle-delay nil
                             #'f90-ts-nav-buffer-refresh-from-timer
                             (current-buffer))))


(defun f90-ts-nav-buffer-refresh-from-timer (src-buf)
  "Refresh the nav buffer for SRC-BUF if it is still live."
  (when (buffer-live-p src-buf)
    (with-current-buffer src-buf
      (setq f90-ts--nav-tree-cache-root nil)
      (f90-ts-nav-buffer-open))))


(defun f90-ts--nav-buffer-after-change (&rest _)
  "Schedule a nav buffer refresh after a source buffer change."
  (f90-ts--nav-buffer-schedule-refresh))


(defun f90-ts--nav-buffer-associated-line (pos)
  "Return the nav buffer line number of the entry associated with POS.
POS is a buffer position in the source buffer.
Must be called with the nav buffer as current buffer, as it reads
`f90-ts--nav-buffer-source' to resolve line numbers in the source buffer.
Returns nil if no suitable entry is found.

For non-variable entries the associated entry is the closest one whose
marker position is <= POS.  For variable entries the marker must be on
the same source line as POS; among those, the entry is selected if POS
is >= the marker position, except for the first variable on the line
which also captures positions before it on that line."
  (let ((assoc-line nil)
        (assoc-mline nil)
        (line (with-current-buffer f90-ts--nav-buffer-source
                (line-number-at-pos pos)))
        (done nil))
    (save-excursion
      (goto-char (point-min))
      (while (and (not (eobp)) (not done))
        (let* ((marker (get-text-property (line-beginning-position) 'f90-ts-nav-marker))
               (kind   (get-text-property (line-beginning-position) 'f90-ts-nav-kind))
               (nav-line (line-number-at-pos))
               (mpos   (and marker
                            (with-current-buffer f90-ts--nav-buffer-source
                              (marker-position marker))))
               (mline  (and mpos
                            (with-current-buffer f90-ts--nav-buffer-source
                              (line-number-at-pos mpos)))))
          (cl-assert marker nil "nav buffer line %s has no marker" nav-line)
          (if (and (> mline line))
              (setq done t)
            (when (or (not (string= kind "variable_declaration"))
                      (and (= mline line) ; only consider variable declarations if on the same line
                           (or (not assoc-line) ; nothing found so far
                               (< assoc-mline mline) ; accept even if pos is before marker pos
                               (<= mpos pos) ; find last variable with marker before point
                               )))
              (setq assoc-line  nav-line
                    assoc-mline mline)))
          (unless done
            (forward-line 1))))
      (or assoc-line
          ;; if assoc-line is nil but there are markers, point is before first marker
          ;; return line number of that first marker entry
          (and (goto-char (point-min))
               (get-text-property (point) 'f90-ts-nav-marker)
               (line-number-at-pos))))))


(defun f90-ts--nav-buffer-sync-now (src-buf pos)
  "Actually perform the nav buffer sync for SRC-BUF at POS."
  (when (buffer-live-p src-buf)
    (let ((nav-buf (get-buffer f90-ts--nav-buffer-name)))
      (when (and nav-buf
                 (buffer-live-p nav-buf)
                 (get-buffer-window nav-buf))
        (with-current-buffer nav-buf
          (when-let ((assoc-line (f90-ts--nav-buffer-associated-line pos)))
            (goto-char (point-min))
            (forward-line (1- assoc-line))
            (when-let ((nav-win (get-buffer-window nav-buf)))
              (set-window-point nav-win (point))
              (with-selected-window nav-win
                (recenter)
                (hl-line-highlight)))))))))


(defun f90-ts--nav-buffer-sync ()
  "Schedule a nav buffer sync via idle timer."
  (when f90-ts-nav-buffer-auto-sync
    (when f90-ts--nav-buffer-idle-timer
      (cancel-timer f90-ts--nav-buffer-idle-timer))
    (setq f90-ts--nav-buffer-idle-timer
          (run-with-idle-timer f90-ts-nav-buffer-idle-delay
                               nil #'f90-ts--nav-buffer-sync-now
                               (current-buffer) (point)))))


(defun f90-ts--nav-buffer-follow-source (_frame)
  "Re-render the nav buffer when focus is moved to a different f90-ts buffer."
  (let ((nav-buf (get-buffer f90-ts--nav-buffer-name)))
    (when (and nav-buf
               (buffer-live-p nav-buf)
               (derived-mode-p 'f90-ts-mode)
               (not (eq (current-buffer)
                        (buffer-local-value 'f90-ts--nav-buffer-source
                                            nav-buf))))
      (f90-ts-nav-buffer-open))))


(defun f90-ts--nav-buffer-add-hooks ()
  "Install the hooks for sync and idle refresh timer.
This is done for the current f90-ts source buffer."
  (add-hook 'post-command-hook #'f90-ts--nav-buffer-sync nil t)
  (add-hook 'after-change-functions
            #'f90-ts--nav-buffer-after-change nil t))


(defun f90-ts-nav-buffer-refresh ()
  "Rebuild the nav buffer from the source buffer."
  (interactive)
  (let ((src (or f90-ts--nav-buffer-source
                 (user-error "Not linked to a F90-TS source buffer"))))
    (unless (buffer-live-p src)
      (user-error "Linked source buffer no longer live"))
    (with-current-buffer src
      ;; invalidate the shared cache
      (setq f90-ts--nav-tree-cache-root nil)
      (f90-ts-nav-buffer-open))))


(define-derived-mode f90-ts-nav-mode special-mode "F90-TS-Nav"
  "Major mode for the F90 navigation side-panel."
  :keymap f90-ts-nav-mode-map
  (setq truncate-lines t)
  (hl-line-mode 1))


;;;###autoload
(defun f90-ts-nav-buffer-open ()
  "Open (or refresh) the F90 navigation side-panel for the current buffer."
  (interactive)

  (when (not (derived-mode-p 'f90-ts-mode))
    (user-error "Not a F90-TS source buffer, navigation buffer not available"))

  (let* ((src-buf (current-buffer))
         (sparse (f90-ts--nav-tree-build))
         (tree-nodes (f90-ts--nav-buffer-from-sparse-tree sparse))
         (nav-buf (get-buffer-create f90-ts--nav-buffer-name)))
    (with-current-buffer nav-buf
      ;; only on first creation, otherwise defvar-local variables are deleted
      (unless (derived-mode-p 'f90-ts-nav-mode)
        (f90-ts-nav-mode))
      (setq f90-ts--nav-buffer-source src-buf)
      (f90-ts--nav-buffer-render tree-nodes))
    (let ((win (display-buffer
                nav-buf
                '(display-buffer-in-side-window
                  (side . left)))))
      (when (window-live-p win)
        (window-resize win
                       (- f90-ts-nav-buffer-width
                          (window-total-width win))
                       t)))
    (with-selected-window (get-buffer-window nav-buf)
      (hl-line-highlight))
    (f90-ts--nav-buffer-add-hooks)
    ;; add hook for automatic nav buffer switching
    (add-hook 'window-buffer-change-functions
              #'f90-ts--nav-buffer-follow-source)))


;;;###autoload
(defun f90-ts-nav-buffer-focus ()
  "Focus the navigation side buffer, opening it first if necessary."
  (interactive)
  (unless (get-buffer f90-ts--nav-buffer-name)
    (f90-ts-nav-buffer-open))
  (when-let ((nav-win (get-buffer-window f90-ts--nav-buffer-name)))
    (select-window nav-win)))


(defun f90-ts-nav-buffer-quit ()
  "Quit the nav buffer."
  (interactive)
  (remove-hook 'window-buffer-change-functions
               #'f90-ts--nav-buffer-follow-source)
  (quit-window))


(easy-menu-define f90-ts-nav-mode-menu f90-ts-nav-mode-map
  "Menu for the F90 navigation side buffer."
  '("F90-TS-Nav"
    ["Jump to entry"    f90-ts-nav-buffer-jump    :active t]
    ["Preview entry"    f90-ts-nav-buffer-preview :active t]
    "---"
    ["Refresh"          f90-ts-nav-buffer-refresh :active t]
    "---"
    ["Quit"             f90-ts-nav-buffer-quit    :active t]))


;;;-----------------------------------------------------------------------------
;;; Defun and thing

(defun f90-ts--thing-node-p (node)
  "Check whether NODE is named or anonymous.
Just checking with regexp is not sufficient, as main structure node
and keyword are sometimes equal.  But we only want the structure node."
  (treesit-node-check node 'named))


(defun f90-ts--defun-name (node)
  "Return the name of defun NODE, for use in `which-function-mode' etc."
  (caar (f90-ts--imenu-name-pos-fn node)))


(defconst f90-ts--thing-defun-regexp-pred
  (cons
   (concat "^" (regexp-opt '("module"
                             "submodule"
                             "program"
                             "subroutine"
                             "function"
                             "module_procedure"
                             "interface"
                             "derived_type_definition")) "$")
   #'f90-ts--thing-node-p)
  "Regexp and predicate for matching node types to determine defun nodes.")


(defconst f90-ts--thing-procedure-regexp-pred
  (cons
   (concat "^" (regexp-opt '("subroutine"
                             "function"
                             "module_procedure")) "$")
   #'f90-ts--thing-node-p)
  "Regexp and predicate for matching node types to determine procedure nodes.")


(defconst f90-ts--thing-interface-regexp-pred
  (cons
   "^interface$"
   #'f90-ts--thing-node-p)
  "Regexp and predicate for matching node types to determine interface nodes.")


(defconst f90-ts--thing-type-regexp-pred
  (cons
   "^derived_type_definition$"
   #'f90-ts--thing-node-p)
  "Regexp and predicate for matching node types to determine derived type nodes.")


(defconst f90-ts--thing-settings
  `((fortran
     (defun     ,f90-ts--thing-defun-regexp-pred)
     (procedure ,f90-ts--thing-procedure-regexp-pred)
     (interface ,f90-ts--thing-interface-regexp-pred)
     (type      ,f90-ts--thing-type-regexp-pred)))
  "List of things with regexp and predicates to identify relevant nodes.")


;; keep this: it has been resolved by adding an advice for treesit-node-parent
;; which resolves other related cases like `treesit-beginning-of-defun'
;;
;; after "(treesit-major-mode-setup)" in f90-ts-mode:
;;  (setq-local add-log-current-defun-function #'f90-ts--add-log-current-defun)
;;
;; (defun f90-ts--add-log-current-defun ()
;;   "Implement add-log-current-defun taking continuation lines in to account.
;; If point is at a virtual ampersand node, it has no parent.  Consequently,
;; the `treesit-parent-until'-ascend used in `treesit-thing-at' (which is called
;; by `treesit-add-log-current-defun') fails.  To avoid this, we move point to
;; a position where a proper node is obtained by `treesit-node-at'."
;;   (let* ((pos-0 (point))
;;          (node (treesit-node-at pos-0))
;;          (pos (if (null (treesit-node-parent node))
;;                   (treesit-node-end node)
;;                 pos-0)))
;;     (save-excursion
;;       (goto-char pos)
;;       (treesit-add-log-current-defun))))


(defun f90-ts-thing-next-procedure ()
  "Move to next procedure."
  (interactive)
  (when-let ((pos (treesit-navigate-thing (point) 1 'beg 'procedure)))
    (goto-char pos)))


(defun f90-ts-thing-prev-procedure ()
  "Move to previous procedure."
  (interactive)
  (when-let ((pos (treesit-navigate-thing (point) -1 'beg 'procedure)))
    (goto-char pos)))


(defun f90-ts-thing-beginning-of-procedure ()
  "Move to beginning of current procedure."
  (interactive)
  (treesit-beginning-of-thing 'procedure))


(defun f90-ts-thing-end-of-procedure ()
  "Move to end of current procedure."
  (interactive)
  (treesit-end-of-thing 'procedure))


(defun f90-ts-thing-next-type ()
  "Move to next derived type."
  (interactive)
  (when-let ((pos (treesit-navigate-thing (point) 1 'beg 'type)))
    (goto-char pos)))


(defun f90-ts-thing-prev-type ()
  "Move to previous derived type."
  (interactive)
  (when-let ((pos (treesit-navigate-thing (point) -1 'beg 'type)))
    (goto-char pos)))


(defun f90-ts-thing-beginning-of-type ()
  "Move to beginning of current derived type."
  (interactive)
  (treesit-beginning-of-thing 'type))


(defun f90-ts-thing-end-of-type ()
  "Move to end of current derived type."
  (interactive)
  (treesit-end-of-thing 'type))


(defun f90-ts-thing-next-interface ()
  "Move to next interface."
  (interactive)
  (when-let ((pos (treesit-navigate-thing (point) 1 'beg 'interface)))
    (goto-char pos)))


(defun f90-ts-thing-prev-interface ()
  "Move to previous interface."
  (interactive)
  (when-let ((pos (treesit-navigate-thing (point) -1 'beg 'interface)))
    (goto-char pos)))


(defun f90-ts-thing-beginning-of-interface ()
  "Move to beginning of current interface."
  (interactive)
  (treesit-beginning-of-thing 'interface))


(defun f90-ts-thing-end-of-interface ()
  "Move to end of current interface."
  (interactive)
  (treesit-end-of-thing 'interface))


;;;-----------------------------------------------------------------------------
;;; menu definition

(easy-menu-define f90-ts-mode-menu f90-ts-mode-map
  "Menu for `f90-ts-mode'."
  '("Fortran"
    ("Indent"
     ;; `indent-for-tab-command' invokes `f90-ts-indent-and-complete-line',
     ;; but we use `indent-for-tab-command' to have keybinding shown properly
     ["Indent line"                 indent-for-tab-command             :active t]
     ["Indent line (alt 2)"         f90-ts-indent-for-tab-command-2    :active t]
     ["Indent line (alt 3)"         f90-ts-indent-for-tab-command-3    :active t]
     ["Indent & complete statement" f90-ts-indent-and-complete-stmt    :active t]
     ["Indent & complete region"    f90-ts-indent-and-complete-region  :active (region-active-p)]
     "---"
     ["Complete end statements in region" f90-ts-complete-smart-end-region :active t])
    ("Break & Join lines"
     ["Break line"          f90-ts-break-line      :active t]
     ["Join with prev line" f90-ts-join-line-prev  :active t]
     ["Join with next line" f90-ts-join-line-next  :active t])
    ("Comment"
     ["Comment/uncomment region (default prefix)" f90-ts-comment-region-default :active (region-active-p)]
     ["Comment/uncomment region (custom prefix)"  f90-ts-comment-region-custom  :active (region-active-p)])
    ("Region"
     ["Enlarge region"  f90-ts-enlarge-region :active t]
     ["Child-0 region"  f90-ts-child0-region  :active (region-active-p)]
     ["Previous region" f90-ts-prev-region    :active (region-active-p)]
     ["Next region"     f90-ts-next-region    :active (region-active-p)])
    "---"
    ("Defun & Thing"
     ["Beginning of defun" beginning-of-defun :active t]
     ["End of defun"       end-of-defun       :active t]
     ["Mark defun"         mark-defun         :active t]
     "---"
     ["Narrow to defun"    narrow-to-defun    :active t]
     ["Widen"              widen              :active (buffer-narrowed-p)]
     "---"
     ["Next procedure"          f90-ts-thing-next-procedure          :active t]
     ["Prev procedure"          f90-ts-thing-prev-procedure          :active t]
     ["Beginning of procedure"  f90-ts-thing-beginning-of-procedure  :active t]
     ["End of procedure"        f90-ts-thing-end-of-procedure        :active t]
     "---"
     ["Next type"               f90-ts-thing-next-type               :active t]
     ["Prev type"               f90-ts-thing-prev-type               :active t]
     ["Beginning of type"       f90-ts-thing-beginning-of-type       :active t]
     ["End of type"             f90-ts-thing-end-of-type             :active t]
     "---"
     ["Next interface"          f90-ts-thing-next-interface          :active t]
     ["Prev interface"          f90-ts-thing-prev-interface          :active t]
     ["Beginning of interface"  f90-ts-thing-beginning-of-interface  :active t]
     ["End of interface"        f90-ts-thing-end-of-interface        :active t])
    ("Xref"
     ["Find definition"  xref-find-definitions :active t]
     ["Find references"  xref-find-references  :active t]
     ["Find apropos"     xref-find-apropos     :active t]
     "---"
     ["Go back"          xref-go-back          :active t]
     ["Go forward"       xref-go-forward       :active t])
    "---"
    ["Open navigation side buffer" f90-ts-nav-buffer-open :active t]
    ["Focus navigation side buffer" f90-ts-nav-buffer-focus :active t]
    ("Navigation tree"
     :visible f90-ts-menu-show-navigate
     :filter (lambda (menu) (f90-ts--nav-menu-tree menu)))
    "---"
    ["Customize f90-ts" (customize-group 'f90-ts) :active t]))


;;;-----------------------------------------------------------------------------

;;;###autoload
(define-derived-mode f90-ts-mode prog-mode "F90[TS]"
  "Major mode for editing Fortran 90+ files, using tree-sitter library."
  :group 'f90-ts
  :syntax-table f90-ts-mode-syntax-table

  ;; check if treesit has a ready parser for 'fortran
  (unless (treesit-available-p)
    (error "Tree-sitter support is not available"))

  ;; create parser or report error
  (if (treesit-ready-p 'fortran)
      (treesit-parser-create 'fortran)
    (error
     (concat "Tree-sitter parser for 'fortran not ready. "
             "Run `M-x treesit-install-language-grammar RET fortran RET' "
             "or ensure treesit-language-source-alist points to a built grammar.")))

  ;; font-lock feature list controls what features are enabled for highlighting
  (setq-local treesit-font-lock-feature-list
              '((comment preproc)                                ; level 1
                (builtin keyword string type)                    ; level 2
                (constant number)                                ; level 3
                (function variable operator bracket delimiter))) ; level 4

  ;; use the pre-defined font-lock rules variable
  (setq-local treesit-font-lock-settings
              (apply #'append f90-ts-font-lock-rules))

  ;; use the pre-defined indentation rules variable
  (setq-local treesit-simple-indent-rules f90-ts-indent-rules)

  ;; Imenu Setup
  (setq-local imenu-create-index-function #'f90-ts-simple-imenu)

  ;; Defun
  (setq-local treesit-defun-type-regexp f90-ts--thing-defun-regexp-pred)
  (setq-local treesit-defun-name-function #'f90-ts--defun-name)
  (setq-local treesit-defun-tactic 'nested)  ; or 'top-level?
  (setq-local treesit-thing-settings f90-ts--thing-settings)

  ;; basic setup helper provided by emacs for tree-sitter powered modes,
  ;; this must be called after setting setq-local variables above!
  (treesit-major-mode-setup)

  ;; set indentation functions (both add smart end completion before
  ;; indentation, so no hook available); this must be done AFTER
  ;; calling treesit-major-mode-setup
  (setq-local indent-line-function #'f90-ts-indent-and-complete-line)
  (setq-local indent-region-function #'f90-ts-indent-and-complete-region)

  (add-hook 'xref-backend-functions #'f90-ts-xref-backend nil t)

  ;; provide a simple mode name in the modeline
  (setq-local mode-name "F90-TS"))


;;;-----------------------------------------------------------------------------

(provide 'f90-ts-mode)

;;; f90-ts-mode.el ends here
