;;; 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: 20260821.1115
;; Package-Revision: 756c299f7cd2
;; 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+)
;;
;; Recently changed, added or improved:
;;   [08-2026] `f90-ts-shift-line-break' as combined break/join function added.
;;   [08-2026] Defcustom `f90-ts-font-lock-error` replaced by
;;             `f90-ts-font-lock-error-show'.  Errors are now always fontified
;;             by `f90-ts-font-lock-error-face'.  The new defcustom
;;             `f90-ts-font-lock-error-show' can be used to turn ERROR node
;;             highlighting on and off, or the number of lines to be highlighted
;;             for each ERROR node.
;;   [08-2026] Jump-to-rightmost-position (within fill-column) to the
;;             interactive fill operation added.
;;   [08-2026] Mark region operations fixed: always consider trimmed region
;;             of nodes.  Some nodes like a whole "subroutine..end subroutine"
;;             block contains a trailing newline, which should not be
;;             considered.  Not consequently trimming all spans broke some mark
;;             region operations.
;;   [08-2026] About, README and MANUAL entries in the fortran and transient
;;             popup menu to view information about the mode added.
;;   [08-2026] Additional font-locking for error regions added.  This can be
;;             customized by `f90-ts-font-lock-error' and
;;             `f90-ts-font-lock-error-face'.
;;   [08-2026] Smart end completion of coarray "change team ... end team"
;;             blocks fixed.  It was wrongly assumed that the end statement is
;;             "end change team".
;;
;;   [07-2026] Inherit attribute of some font lock faces fixed.
;;   [07-2026] Alignment of unary expressions with leading minus or plus
;;             improved.
;;
;;   [06-2026] Fill line and region operations added.
;;   [06-2026] Defcustom group f90-ts-comment added.
;;   [06-2026] Indentation of lines after a structure beginning line with
;;             statement label fixed.
;;   [06-2026] Indentation within and after preprocessor blocks fixed.
;;   [06-2026] Trailing blank part "\\(\\s-+\\|$\\)" in defcustom regexps
;;             `f90-ts-comment-prefix-regexp' and `f90-ts-openmp-prefix-regexp'
;;             removed from the defcustom definitions and added as
;;             `f90-ts-comment-prefix-separator-regexp'.  If the regexp
;;             variables have been customized, please adjust.
;;   [06-2026] Mark region operations complemented
;;
;; Features:
;;   - Almost all statements up to F2023
;;   - Syntax highlighting, including syntactically incorrect code
;;   - Indentation of lines, regions, multiline statements and structure blocks
;;   - Alignment for multiline statements with rotation and other options
;;   - Smart end completion
;;   - Configurable leading ampersand and statement label positions
;;   - Breaking and joining of continued lines
;;   - Filling and rebalancing of lines or regions (with rightmost breakpoint
;;     selection or interactive break and join session)
;;   - (Un)commenting regions with configurable prefixes and indentation rules
;;   - Special comments like doc strings and separators
;;     (syntax highlighting and indentation options)
;;   - Keyword highlighting in comments (like TODO, Remark etc.)
;;   - OpenMP and preprocessor directives
;;   - Coarray keywords and statements
;;   - Region selection based on tree-sitter nodes
;;   - Imenu and a Fortran menu in the menu bar
;;   - Navigation (defun, things, Xref, side panel tree)
;;
;; 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
;;
;; 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.
;; For details see MANUAL at https://github.com/mscfd/emacs-f90-ts-mode

;;; Code:

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

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

;; for loading online README and MANUAL
(require 'url)

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

(defconst f90-ts-mode-version "0.3.0-snapshot"
  "Version of `f90-ts-mode'.")


(defconst f90-ts--github-url
  "https://github.com/mscfd/emacs-f90-ts-mode")


(defconst f90-ts--about-text
  "
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+).

Recently changed, added or improved:

[08-2026]
- `f90-ts-shift-line-break' as combined break/join function added.
- Defcustom `f90-ts-font-lock-error' replaced by `f90-ts-font-lock-error-show'.
  Errors are now always fontified by f90-ts-font-lock-error-face.
  The new defcustom `f90-ts-font-lock-error-show' can be used to turn ERROR
  node highlighting on and off, or the number of lines to be highlighted for
  each ERROR node.
- Jump-to-rightmost-position (within fill-column) to the interactive
  fill operation added.
- Mark region operations fixed: always consider trimmed region
  of nodes. Some nodes like a whole `subroutine..end subroutine`
  block contains a trailing newline, which should not be
  considered. Not consequently trimming all spans broke some mark
  region operations.
- About, README and MANUAL entries in the fortran and transient
  popup menu to view information about the mode added.
- Additional font-locking for error regions added.  This can be
  customized by `f90-ts-font-lock-error' and
  `f90-ts-font-lock-error-face'.
- Smart end completion of coarray \"change team ... end team\"
  blocks fixed.  It was wrongly assumed that the end statement is
  \"end change team\".

[07-2026]
- Inherit attribute of some font-lock faces fixed.
- Alignment of unary expressions with leading minus or plus improved.

[06-2026]
- Fill line and region operations added.
- Defcustom group `f90-ts-comment' added.
- Indentation of lines after a structure beginning line with
  statement label fixed.
- Indentation within and after preprocessor blocks fixed.
- Trailing blank part removed from
  `f90-ts-comment-prefix-regexp' and
  `f90-ts-openmp-prefix-regexp'.  If customized, please adjust.
- Mark region operations complemented.
")


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

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


(defgroup f90-ts-font-lock nil
  "Font-locking options used by `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 options used by `f90-ts-mode'."
  :prefix "f90-ts-"
  :group  'f90-ts)


(defgroup f90-ts-comment nil
  "Comment and openmp options used by `f90-ts-mode'."
  :prefix "f90-ts-"
  :group  'f90-ts)


(defgroup f90-ts-nav nil
  "Navigation options used by `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-options-alist
  '(("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-region-options-alist
  (cl-remove-if (lambda (x)
                  (memq (cdr x) '(rotate keep-or-rotate)))
                f90-ts--indent-options-alist)
  "Options for region indentation (excludes rotation).")


(defconst f90-ts--indent-values
  (mapcar #'cdr f90-ts--indent-options-alist)
  "List of valid symbols for single-line indentation.")


(defconst f90-ts--indent-region-values
  (mapcar #'cdr f90-ts--indent-region-options-alist)
  "List of valid symbols for region indentation (excludes rotation).")


(defun f90-ts--indent-make-radio-type (options)
  "Generate a customize radio type from an alist of indent OPTIONS."
  `(radio ,@(mapcar (lambda (x)
                      `(const :tag ,(car x) ,(cdr x)))
                    options)))


(defcustom f90-ts-indent-list-region 'keep-or-primary
  "Method to select indentation column for continued lines in list-like context.
Used as default setting in `indent-region' and similar operations."
  :type (f90-ts--indent-make-radio-type f90-ts--indent-region-options-alist)
  :safe (lambda (val) (memq val f90-ts--indent-region-values))
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-list-line 'rotate
  "Method to 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-make-radio-type f90-ts--indent-options-alist)
  :safe (lambda (val) (memq val f90-ts--indent-values))
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-list-line-2 'continued-line
  "Method to 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-make-radio-type f90-ts--indent-options-alist)
  :safe (lambda (val) (memq val f90-ts--indent-values))
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-list-line-3 'primary
  "Method to 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-make-radio-type f90-ts--indent-options-alist)
  :safe (lambda (val) (memq val f90-ts--indent-values))
  :group 'f90-ts-indent)


(defcustom f90-ts-indent-paren-default 1
  "Additional offset applied for alignment with opening parenthesis.
The default is used 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 (with offset 2, which aligns some_expr two columns to the right of =):
x =      & ! some comment
    some_expr

Primary alignment column for the second line is column of assignment \"=\" plus
`f90-ts-indent-expr-assign-default'.  Applied to all nodes except associate
operators, which are handled by `f90-ts-indent-expr-assign-assoc-op'."
  :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 (with offset 0, which aligns = and + at the same colum):
x = value1 &
  + some_expr

Primary alignment column for the second line is column of assignment \"=\" plus
`f90-ts-indent-expr-assign-assoc-op' for associative operators.
All other cases are handled by `f90-ts-indent-expr-assign-default'."
  :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")))
  :safe (lambda (v) (and (consp v)
                         (memq (car v) '(column indent))
                         (integerp (cdr v))))
  :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)"))
  :safe (lambda (v) (and (consp v)
                         (memq (car v) '(right left))
                         (integerp (cdr v))))
  :group 'f90-ts)


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

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


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


(defface f90-ts-font-lock-operator-face
  '((t :inherit font-lock-operator-face))
  "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
  :group 'f90-ts-comment)


(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
  :group 'f90-ts-comment)


(defface f90-ts-font-lock-error-face
  '((t (:underline (:style wave :color "OrangeRed"))))
  "Additional face properties applied to Tree-sitter ERROR nodes.

The face is appended to the existing syntax highlighting, so it is
intended to specify only UI-related attributes such as slant,
underline, or a subtle background."
  :group 'f90-ts-font-lock)


(defcustom f90-ts-font-lock-error-show 'all
  "Extent of highlighting applied to tree-sitter ERROR nodes.

The value controls how much of an ERROR node is highlighted:
- nil, do not apply any additional highlighting to ERROR nodes
- symbol `all' highlight the complete span of the ERROR
- positive integer: highlight this many lines from the start of the ERROR node

Highlighting uses the face `f90-ts-font-lock-error-face'.

- nil: do not apply any additional highlighting to ERROR nodes.
- the symbol `all': highlight the whole ERROR node.
- a positive integer: highlight only that many lines from the start
  of the ERROR node."
  :type '(choice
          (const :tag "Disabled" nil)
          (const :tag "Whole node" all)
          (integer :tag "Number of lines from start"))
  :safe (lambda (val)
          (or (null val)
              (eq val 'all)
              (and (integerp val) (> val 0))))
  :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
  :safe  #'booleanp
  :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 no-message 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-mark-region-order 'preserve
  "Mark region operations need to place point at beginning or end of region.
If `start', point is placed at start of region.
If `end', point is placed at end of region.
If `preserve', the point/mark order of the active region is preserved,
defaulting to end of region if there is no active region present."
  :type  '(choice (const :tag "Point at start" start)
                  (const :tag "Point at end" end)
                  (const :tag "Preserve order" preserve))
  :safe  (lambda (v) (memq v '(start end preserve)))
  :group 'f90-ts)


(defcustom f90-ts-fill-select-breakpoint-by 'rightmost
  "How to select the break point when filling a Fortran line.
- rightmost:   automatically pick the rightmost eligible break point.
- interactive: rotate through possible break points with left/right or
               \\[previous-line]/\\[next-line], confirming with RET.
               Start at previous break point if there was one."
  :type '(choice (const :tag "Rightmost" rightmost)
                 (const :tag "Interactive" interactive))
  :safe (lambda (v) (memq v '(rightmost interactive)))
  :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-*"
  "Regular expression for matching and capturing comment starts.
Together with `f90-ts-comment-prefix-separator-regexp', this is used to extract
the comment prefix for `f90-ts-break-line', `f90-ts-join-line-prev',
`f90-ts-join-line-next' and various fill operations.
OpenMP prefix is matched by `f90-ts-openmp-prefix-regexp'.

Note: do *NOT* use capturing groups in the regular expression, otherwise
comment prefix matching fails.  If a group is required, then use non-capturing
groups with \"\\(?:regexp\\)\".  Example: \"!\\(?:doc\\|remark\\|!\\$\\)\".

The default value \"!\\S-*\" with separator \"\\s-\" assumes that the comment
prefixes are always separated by a blank.  If comment content starts right
after the comment start \"!\", then these two regexp must be adjusted to
properly match only desired comment starters without any separator."
  :type  'regexp
  :safe  #'stringp
  :group 'f90-ts-comment)


(defcustom f90-ts-comment-prefix-separator-regexp "\\s-"
  "Regular expression for separating comment prefix and its content.
End-of-string always serves as separator as well and does not need to provided.

If comment content regularly starts right after comment start \"!\", then this
should be disabled and `f90-ts-comment-prefix-regexp' properly formulate to
match only exactly desired prefixes."
  :type '(choice (regexp :tag "Separator regexp")
                 (const :tag "No separator" nil))
  :safe (lambda (v) (or (null v) (stringp v)))
  :group 'f90-ts-comment)


(defcustom f90-ts-openmp-prefix-regexp "!\\$\\(?:omp\\)?"
  "Regular expression for matching OpenMP starts.
It is used for identifying openmp statements, which are just comment nodes.
For example, this is relevant for line break operations, as openmp statements
require continuation symbols."
  :type  'regexp
  :safe  #'stringp
  :group 'f90-ts-comment)


(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
  :safe  #'stringp
  :group 'f90-ts-comment)


(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)
  :safe (lambda (v) (and (listp v) (cl-every #'stringp v)))
  :group 'f90-ts-comment)


(defcustom f90-ts-comment-prefix-keep-indent t
  "Keep indentation in comment 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.  This preserves the original
indentation."
  :type  'boolean
  :safe  #'booleanp
  :group 'f90-ts-comment)


(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"))
  :safe (lambda (v) (or (null v) (stringp v)))
  :group 'f90-ts-font-lock
  :group 'f90-ts-comment)


(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"))))
  :safe (lambda (v)
          (and (listp v)
               (cl-every (lambda (rule)
                            (and (listp rule)
                                 (stringp (plist-get rule :name))
                                 (or (stringp (plist-get rule :match))
                                     (functionp (plist-get rule :match)))
                                 (memq (plist-get rule :indent)
                                       '(column-0 context indented))
                                 (symbolp (plist-get rule :face))))
                          v)))
  :group 'f90-ts-font-lock
  :group 'f90-ts-indent
  :group 'f90-ts-comment)


;;;-----------------------------------------------------------------------------
;;; 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

(defvar-keymap f90-ts-mode-map
  :doc "Keymap for `f90-ts-mode'."
  ;; TAB commands
  "C-<tab>"           #'f90-ts-indent-and-complete-stmt
  "<backtab>"         #'f90-ts-indent-for-tab-command-2 ; S-<tab>
  "C-S-<iso-lefttab>" #'f90-ts-indent-for-tab-command-3 ; Linux
  "C-<backtab>"       #'f90-ts-indent-for-tab-command-3 ; Windows?

  ;; other keybindings inspired by f90-mode
  "C-<return>" #'f90-ts-break-line
  "C-c ;"      #'f90-ts-comment-region-default
  "C-c '"      #'f90-ts-comment-region-custom

  ;; C-c C-f prefix for the transient menu
  "C-c C-f" #'f90-ts-transient)


(transient-define-infix f90-ts-transient--indent-list-line ()
  "Transient infix for indent-line alignment variant."
  :class    'transient-lisp-variable
  :variable 'f90-ts-indent-list-line
  :prompt   "Indent list line method: "
  :reader   (lambda (prompt initial _history)
              (let* ((choice (completing-read
                               prompt
                               f90-ts--indent-options-alist
                               nil t nil nil
                               (car (rassq initial f90-ts--indent-options-alist)))))
                (cdr (assoc choice f90-ts--indent-options-alist)))))


(transient-define-infix f90-ts-transient--fill-column ()
  "Transient infix for fill column override."
  :class    'transient-lisp-variable
  :variable 'fill-column
  :prompt   "Fill column: "
  :reader   (lambda (prompt initial _history)
               (read-number prompt initial)))


(transient-define-suffix f90-ts-transient--fill-select-breakpoint-by ()
  "Toggle breakpoint selection between `rightmost' and `interactive'."
  :transient t
  :description (lambda ()
                 (concat "Fill column select by: "
                         (propertize (symbol-name f90-ts-fill-select-breakpoint-by)
                                     'face 'transient-value)))
  (interactive)
  (setq f90-ts-fill-select-breakpoint-by
        (if (eq f90-ts-fill-select-breakpoint-by 'interactive)
            'rightmost
          'interactive)))


(transient-define-prefix f90-ts-transient ()
  "F90 Tree-sitter Mode."
  ;; Modify
  [["Indentation, break & join"
    ("L"   "Indent list line:"          f90-ts-transient--indent-list-line)
    ("TAB" "Indent line"                f90-ts-indent-and-complete-line)
    ("s"   "Indent & complete stmt"     f90-ts-indent-and-complete-stmt)
    ("I"   "Indent & complete region"   f90-ts-indent-and-complete-region)
    ("E"   "Smart end complete region"  f90-ts-complete-smart-end-region)
    ("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-s" "Shift line break"           f90-ts-shift-line-break)]
   ["Mark and (un)comment region"
    ("r"   "Enlarge"                    f90-ts-mark-region-enlarge)
    ("0"   "Shrink to first child"      f90-ts-mark-region-shrink-child-first)
    ("9"   "Shrink to last child"       f90-ts-mark-region-shrink-child-last)
    ("{"   "First sibling"              f90-ts-mark-region-first-sibling)
    ("["   "Previous sibling"           f90-ts-mark-region-prev-sibling)
    ("]"   "Next sibling"               f90-ts-mark-region-next-sibling)
    ("}"   "Last sibling"               f90-ts-mark-region-last-sibling)
    ("X"   "Exchange point and mark"    exchange-point-and-mark)
    ("c"   "Comment region (default)"   f90-ts-comment-region-default)
    ("C"   "Comment region (custom)"    f90-ts-comment-region-custom)]
   ["Fill/Rebalance"
    ("C-f" "Fill column:"               f90-ts-transient--fill-column)
    ("C-b"                              f90-ts-transient--fill-select-breakpoint-by) ; text is in description slot
    ("f"   "Fill region/buffer"         f90-ts-fill-region)
    ("M-f" "Fill at line"               f90-ts-fill-at-line)
    ("M-j" "Fill with prev line"        f90-ts-fill-prev-line)
    ("M-J" "Fill with next line"        f90-ts-fill-next-line)]]

  ;; Navigate
  [["Procedure"
    ("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)]
   ["Derived Type"
    ("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"
    ("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)]
   ["Side panel (alpha!)"
    ("B"   "Open nav buffer"            f90-ts-nav-buffer-open)
    ("F"   "Focus nav buffer"           f90-ts-nav-buffer-focus)]
   ["About & Doc"
    ("C-h a" "About"                    f90-ts-mode-about)
    ("C-h r" "README"                   f90-ts--browse-readme)
    ("C-h m" "MANUAL"                   f90-ts--browse-manual)]])


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

;; 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."
  (lambda (_node _parent _bol &rest _)
    (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"))
    ;; return nil to ensure that the dummy rule fails (as the real log function also does)
    nil))


;;;-----------------------------------------------------------------------------
;;; auxiliary predicates, walk and query functions

(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)))


(defun f90-ts--node-start-trimmed (node)
  "Return the position of the first non-blank character of NODE."
  (save-excursion
    (goto-char (treesit-node-start node))
    (skip-chars-forward " \t\n")
    (point)))


(defun f90-ts--node-end-trimmed (node)
  "Return the position of the last non-blank character of NODE."
  (save-excursion
    (goto-char (treesit-node-end node))
    (skip-chars-backward " \t\n")
    (point)))


(defun f90-ts--node-span-trimmed (node)
  "Return the trimmed span of NODE as cons cell (START . END).
The trimmed span starts at the first non-blank character
and ends at the last non-blank character of NODE."
  (save-excursion
    (cons (progn
            (goto-char (treesit-node-start node))
            (skip-chars-forward " \t\n\r\f")
            (point))
          (progn
            (goto-char (treesit-node-end node))
            (skip-chars-backward " \t\n\r\f")
            (point)))))


(defun f90-ts--empty-comment-node-p (node)
  "Return non-nil if comment NODE has no content after its prefix."
  (and (f90-ts--node-type-p node "comment")
       (null (f90-ts--comment-content node))))


(defun f90-ts--line-empty-p (pos)
  "Return non-nil if the line at POS is empty or has only blanks."
  (save-excursion
    (goto-char pos)
    (looking-at-p "^[ \t]*$")))


(defun f90-ts--next-line-empty-p (pos)
  "Return non-nil if the next line to POS is empty or has only blanks."
  (save-excursion
    (goto-char pos)
    (and (zerop (forward-line 1))
         (f90-ts--line-empty-p (point)))))


(defun f90-ts--line-empty-comment-p (pos)
  "Return non-nil if the line at POS has an empty comment node."
  (f90-ts--empty-comment-node-p
   (f90-ts--node-at-indent-pos pos)))


(defun f90-ts--next-line-empty-comment-p (pos)
  "Return non-nil if the next line after POS has an empty comment node."
  (save-excursion
    (goto-char pos)
    (when (zerop (forward-line 1))
      (f90-ts--line-empty-comment-p (point)))))


(defun f90-ts--region-trimmed ()
  "Return (BEG . END) of trimmed active region.
The trimming removes leading and trailing whitespace."
  (cons (save-excursion
          (goto-char (region-beginning))
          (skip-chars-forward " \t\n")
          (point))
        (save-excursion
          (goto-char (region-end))
          (skip-chars-backward " \t\n")
          (point))))


(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--node-type-p (node type)
  "Compare type of NODE with 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 (null 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)
  "Match type of NODE with 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 (null type-rx)
      (and node
           (let ((type-n (treesit-node-type node)))
             (string-match-p type-rx type-n)))))


(defun f90-ts--nodes-same-span-p (node1 node2)
  "Return non-nil if NODE1 and NODE2 have the same span."
  (and (= (treesit-node-start node1) (treesit-node-start node2))
       (= (treesit-node-end node1)   (treesit-node-end node2))))


(defun f90-ts--node-span-p (node beg end)
  "Return non-nil if NODE has the span BEG..END."
  (and (= beg (treesit-node-start node))
       (= end (treesit-node-end node))))


(defun f90-ts--comment-omp-prefix-regexp ()
  "Return the combined comment and openmp prefix regexp.
The returned regexp also captures trailing blanks, which serves as an assertion
that the prefix is properly separated by a blank.  If accessing the captured
prefix, match group 1 needs to be used.

Note: this regexp cannot be used to match directly in the buffer, as it uses
an anchor to match only at start of a comment.  It is intended to be used on
the text of a comment node."
  ;; first match openmp as comment prefix might just take the initial ! and
  ;; ignore the following $omp part in openmp statements
  (concat "^\\(?:"
          "\\(" f90-ts-openmp-prefix-regexp "\\)\\(?:\\s-\\|$\\)"
          "\\|\\(" f90-ts-comment-prefix-regexp "\\)"
          (when f90-ts-comment-prefix-separator-regexp
            (concat "\\(?:" f90-ts-comment-prefix-separator-regexp "\\|$\\)"))
          ;; if nothing matches, then extract the leading comment starter
          "\\|\\(!\\)"
          "\\)"))


(defun f90-ts--match-comment-omp-prefix (text)
  "Match a comment prefix at the start of TEXT.
Returns the prefix in the comment TEXT if matched, nil otherwise.
It uses `f90-ts--comment-omp-prefix-regexp' to capture the prefix."
  (when (string-match (f90-ts--comment-omp-prefix-regexp) text)
    (or (match-string 1 text)
        (match-string 2 text)
        (match-string 3 text))))


(defun f90-ts--comment-omp-prefix-with-blanks (text prefix)
  "Return PREFIX extended by any blanks following it in TEXT.
Used to capture trailing blanks in comment and openmp prefixes."
  (let ((pos (length prefix)))
    (string-match "\\s-*" text pos)
    (substring text 0 (match-end 0))))


(defun f90-ts--comment-prefix (node trim)
  "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.
If TRIM is `with-blanks', trailing blanks are included in the returned prefix.
If TRIM is `trimmed', only the matched prefix is returned."
  (cl-assert (f90-ts--node-type-p node "comment")
             nil "comment node expected")
  (cl-assert (memq trim '(with-blanks trimmed)) nil "argument trim has invalid value, got %s" trim)
  (let* ((text (treesit-node-text node))
         (prefix (f90-ts--match-comment-omp-prefix text)))
    ;; there should always be a prefix, as a single "!" is captured as well
    (cl-assert prefix nil "comment has no prefix")
    (if (eq trim 'with-blanks)
        (f90-ts--comment-omp-prefix-with-blanks text prefix)
      prefix)))


(defun f90-ts--comment-content (node)
  "Extract the content of a comment NODE following the comment prefix.
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.
It always removes blanks after the prefix.  Thus the first character in the
returned content is a non-blank character, or content is nil."
  (cl-assert (f90-ts--node-type-p node "comment")
             nil "comment node expected")
  (let* ((text (treesit-node-text node))
         (prefix (f90-ts--match-comment-omp-prefix text)))
    (cl-assert prefix nil "comment has no prefix")
    (let ((pos (length prefix)))
      (string-match "\\s-*" text pos)
      (let ((content-start (match-end 0)))
        (when (< content-start (length text))
          (substring text content-start))))))


(defun f90-ts--comment-forward-prefix (node)
  "Position point at end of comment prefix matched at start of 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 node expected")
  ;; first match openmp as comment prefix would just take the initial ! and ignoring
  ;; following $omp part in openmp statements
  (let ((start (treesit-node-start node))
        (text (treesit-node-text node)))
    (if (string-match (f90-ts--comment-omp-prefix-regexp) text)
        (progn
          (goto-char (+ start (match-end 0)))
          (skip-chars-backward " \t"))
      (cl-assert nil nil "failed to match comment prefix")
      ;; skip the leading comment starter
      (goto-char (1+ start)))))


(defun f90-ts--node-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--node-openmp-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 "\\(\\s-+\\|$\\)")
                    (treesit-node-text node))))


(defun f90-ts--node-block-label-ancestor (node)
  "Return block_label_start_expression ancestor of leaf NODE if there is one.
NODE is assumed to be the leaf node at the start of a line.  The function
checks whether it is part of a \"block_label_start_expression\"."
  ;; Unfortunately, this comes in two variants (as a label name, which is a language
  ;; keyword parses slightly differently):
  ;;
  ;;   (block_label_start_expression
  ;;    'label'
  ;;    :)
  ;;
  ;; and if the label is a reserved keyword:
  ;;
  ;;   (block_label_start_expression
  ;;    'label'
  ;;     keyword
  ;;    :)
  ;;
  ;; In both cases, 'label' is an anonymous node.  In the second case, it has the
  ;; child keyword.
  ;; In any case, the function should return \"block_label_start_expression\",
  ;; or nil.
  (cl-assert (or (not node)
                 (zerop (treesit-node-child-count node nil)))
             nil "node is not a leaf node: %s" node)
  (let* ((parent (and node (treesit-node-parent node)))
         (grandparent (and parent (treesit-node-parent parent))))
    (cond
     ((and (f90-ts--node-type-p node "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))))


(defun f90-ts--node-preproc-p (node)
  "Check if NODE is a preprocessor directive node.
This is done by checking whether the node text starts with a \"#\".
For indentation, only these directive nodes are relevant.
This function should cover both anonymous leaf nodes as well as named nodes.
Hence checking the type of the node works only partially."
    (let ((start (treesit-node-start node)))
      ;; only fetch the first character instead of the whole node text
      (eq (char-after start) ?#)))


(defconst f90-ts--preproc-block-keyword-regexp
  "^#\\(ifdef\\|ifndef\\|elifdef\\|elifndef\\|elif\\|else\\|endif\\|if\\)$"
  "Regexp for matching preprocessor nodes of block type (if block).")


(defun f90-ts--preproc-block-keyword-p (node)
  "Match type of NODE against block type preprocessor keywords.
This uses `f90-ts--preproc-block-keyword-regexp' as a regexp for the matching."
  (f90-ts--node-type-match-p node f90-ts--preproc-block-keyword-regexp))


(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--node-openmp-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--node-openmp-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-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-error-p (node)
  "Return non-nil if NODE is not of type error."
  (not (f90-ts--node-type-p node "ERROR")))


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


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


(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-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))


(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)))


(defun f90-ts--node-on-pos (pos side &optional 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 some parent node properly including POS.
Also note that if POS is not within the span of the root node, then
`treesit-node-on' returns the root node, even so it does not cover POS.

In contrast to `treesit-node-on', this function uses the closed interval logic
and looks for nodes really covering [POS,POS].  If there is more than one such
node (one ending at POS, another starting at POS), SIDE is is used to resolve
the ambiguity.  SIDE is either `left' or `right'.  This selects the node which
ends at POS and starts at POS, respectively.

Example
subroutine sub()
   if (cond) then
   end if|
end subroutine sub

If point is at |, then the smallest named node is the end_statement
for \"end if\".  However, treesit-node-on returns the subroutine node.
Querying with [POS-1,POS) gives the expected answer."
  (cl-assert (member side '(left right))
             nil "invalid argument side, got %s" side)
  (let* ((right-on (treesit-node-on pos pos nil named))
         (left-on  (and (> pos (point-min))
                        (treesit-node-on (1- pos) pos nil named)))
         ;; filter nodes which do not cover POS
         (right (when (and right-on
                           (<= (treesit-node-start right-on) pos)
                           (<= pos (treesit-node-end right-on)))
                  right-on))
         (left (when (and left-on
                          (<= (treesit-node-start left-on) pos)
                          (<= pos (treesit-node-end left-on)))
                 left-on)))
    (cond
     ;; only one candidate
     ((null left) right)
     ((null right) left)

     ;; ambiguity case
     ((and (= (treesit-node-end left) pos)
           (= pos (treesit-node-start right)))
      (if (eq side 'left) left right))

     ;; return node with smaller span (which should be a descendant of the large node)
     (t
      (let ((len-left (- (treesit-node-end left)
                         (treesit-node-start left)))
            (len-right (- (treesit-node-end right)
                          (treesit-node-start right))))
        (if (< len-left len-right) left right))))))


(defun f90-ts--smallest-node-same-span (node)
  "Find the smallest named descendant of NODE which spans the same region."
  (let* ((beg (treesit-node-start node))
         (end (treesit-node-end node))
         (sparse (treesit-induce-sparse-tree
                  node
                  (lambda (n) (and (treesit-node-check n 'named)
                                   (f90-ts--node-span-p n beg end))))))
    ;; get the first leaf, descend the first child until a leaf is reached
    (cl-loop for current = sparse then (car (cdr current))
             while (cdr current)
             finally return (car 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)
     (f90-ts--nodes-same-span-p n node))))


(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--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--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--skip-comments-to-ampersand (node sibling-fn)
  "Return final ampersand after a sequence of comment nodes.
Walk from NODE via SIBLING-FN across comment nodes, and return
the ampersand node reached once comments end.  Return nil if NODE
is nil, not a comment, or if the node reached after skipping comments
is not an ampersand."
  (cl-loop for n = node then (funcall sibling-fn n)
           while (f90-ts--node-type-p n "comment")
           finally return (and (f90-ts--node-ampersand-p n) n)))


(defun f90-ts--find-ampersand-boundary (node sibling-fn)
  "Find the ampersand at the far end of an &-comment*-& sequence.

Walking siblings is done via SIBLING-FN, which determines the direction of
the walk \(`treesit-node-prev-sibling' or `treesit-node-next-sibling'\).

If NODE is an ampersand or a comment that is part of such a sequence, return
the ampersand at the far end of it.  Otherwise, including if NODE is
of any other type, return nil."
  (cond
   ((f90-ts--node-ampersand-p node)
    ;; try to skip subsequent comments, otherwise return node,
    ;; which is already the boundary ampersand
    (or (f90-ts--skip-comments-to-ampersand
         (funcall sibling-fn node) sibling-fn)
        node))
   ((f90-ts--node-type-p node "comment")
    (f90-ts--skip-comments-to-ampersand node sibling-fn))
   (t nil)))


(defun f90-ts--sibling-skip-continuation (node sibling-fn)
  "Return NODE's sibling, skipping a &-comment*-& sequence if present.

Walking siblings is done via SIBLING-FN, which determines the direction of
the walk \(`treesit-node-prev-sibling' or `treesit-node-next-sibling'\).

If sibling of NODE is an ampersand or comment that is part of such a sequence,
return the node directly following the sequence's second ampersand (nil if
there is no such sibling).  Otherwise return the sibling of NODE itself."
  (when-let ((nsib (funcall sibling-fn node)))
    (if-let ((amp2 (f90-ts--find-ampersand-boundary
                    nsib #'treesit-node-next-sibling)))
        (treesit-node-next-sibling amp2)
      nsib)))


(defun f90-ts--skip-continuation-forward (node)
  "Return NODE's next sibling, skipping a &-comment*-& sequence if present.
See `f90-ts--sibling-skip-continuation'."
  (f90-ts--sibling-skip-continuation node #'treesit-node-next-sibling))


(defun f90-ts--find-first-ampersand (node)
  "Find the first ampersand if at a &-comment*-& sequence.
In continued lines, continuation symbol ampersands appears in
sequences like &, (comment)*, &.  This routines checks whether NODE
is any of those ampersand or comment nodes, and returns the first
ampersand node of this sequence."
  (f90-ts--find-ampersand-boundary node #'treesit-node-prev-sibling))


(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--previous-stmt-first-line (node line-num)
  "Return previous statement determined by NODE.
First search for any reasonable (leaf) node, which is before line with
line number LINE-NUM, 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-error-preproc-p' during ascend or descend.
For ascend, it suffices to ignore errors, but for descend we also need to
exclude comment and preprocessor nodes in `f90-ts--before-child'."
  (let* ((predicate #'f90-ts--node-not-comment-error-preproc-p)
         ;; ascend until a previous ancestor is found
         (prev-sib-of-anc
          (cl-loop for ancestor = node then (treesit-node-parent ancestor)
                   while ancestor
                   for relative = (f90-ts--before-child ancestor line-num 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 line-num predicate))
                        ;; if there is a next, continue and shift next to sib
                        ;; with "for sib=next" in the first cl-loop line
                        while next
                        finally return sib)))
         ;; take continuation lines into account and go to beginning of statement
         (first (and prev-descend
                     (f90-ts--first-node-of-stmt prev-descend))))
    ;; check for statement_label node and skip if possible
    (when first
      (if (not (f90-ts--node-type-p first "statement_label"))
          ;; standard case, no statement label present
          first
        ;; first should be the unnamed node in (statement_label "statement_label")
        ;; we need the parent, first ensure that this assumption is correct
        (cl-assert (f90-ts--node-type-p (treesit-node-parent first) "statement_label")
                   nil "unexpected tree structure at leaf node of type statement_label")
        (let ((next (treesit-node-next-sibling
                     (treesit-node-parent first))))
          (if (and next
                   (= (f90-ts--node-line first)
                      (f90-ts--node-line next)))
              ;; retrieve the leaf node starting at next
              (treesit-node-at (treesit-node-start next))
            first))))))


(defun f90-ts--previous-stmt-first (node parent)
  "Return previous non-preproc statement determined by NODE and PARENT.
It uses `f90-ts--previous-stmt-first' to step back statement by statement,
until a non-preprocessor statement is found.

It starts at NODE, and if it is nil, it uses PARENT.  The function is used by
the indent engine, which does not have a NODE but always has a PARENT (for
example on empty lines)."
  (cl-loop for ancestor = (or node parent) then pstmt-1
           for cur-line =    (f90-ts--line-number-at-node-or-pos node)
                        then (f90-ts--node-line pstmt-1)
           for pstmt-1 = (f90-ts--previous-stmt-first-line ancestor cur-line)
           while pstmt-1
           when (not (f90-ts--node-preproc-p pstmt-1)) return pstmt-1))


(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.
This might be a \"block_label_start_expression\", which needs to be skipped.

Auxiliary function for `f90-ts--previous-stmt-keyword' or when
first statement is known."
  (if-let* ((block-label (f90-ts--node-block-label-ancestor first))
	        (next (f90-ts--skip-continuation-forward block-label)))
      (cl-loop
       for n = 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--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--prev-sib-by-parent (parent)
  "Previous sibling based on position of point and PARENT.
Especially for an 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.
If the sibling is an ERROR node, then descend (always the first sibling) to
find a relevant structure type, like subroutine_statement or similar.
Usually only one step is required to skip the ERROR node.

Comment and preprocessor nodes are ignored as previous siblings."
  (let* ((cur-line (line-number-at-pos))
         (psib (f90-ts--before-child parent cur-line
                                     #'f90-ts--node-not-comment-or-preproc-p)))
    ;; 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--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-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-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--parent-no-preproc (parent)
  "Ascend until a non-preproc ancestor PARENT is found.
If PARENT is a normal node, then return PARENT."
  (treesit-parent-until parent
                        (lambda (n) (not (f90-ts--node-type-match-p n "preproc.*")))
                        t))


(defun f90-ts--grandparent-no-preproc (parent)
  "Ascend until a non-preproc ancestor PARENT is found.
If PARENT is a normal node, then return PARENT."
  (when-let* ((parent-nopp (f90-ts--parent-no-preproc parent))
              (gp (treesit-node-parent parent-nopp)))
    (f90-ts--parent-no-preproc gp)))


(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.
This does not anchor at NODE, just at indentation of first statement node
on the line.

Note: ampersands and statement_label's are removed for indented lines, but
node might not be on such a line (for line indentation of region indention
with relevant nodes outside of marked region), thus we need to actively skip
them.

Note: the determined position can be used as anchor in indentation even within
`treesit-indent-region', which uses buffering of computed (anchor offset).

TODO: besides ampersands also skip statement_label's."
  (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.
If the line is empty, return nil."
  (save-excursion
    (goto-char pos)
    (back-to-indentation)
    (let ((node (treesit-node-at (point))))
      (when (and node
                 (= (point) (treesit-node-start node)))
        node))))


;;;-----------------------------------------------------------------------------
;;; 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))))))


(defun f90-ts--fontify-error (node _override _start _end &rest _)
  "Add error fontification for span of NODE if enabled and applicable.
If `f90-ts-font-lock-error-show' is non-nil, and NODE of type \"ERROR\" has
no other error node has descendant, then the function appends
`f90-ts-font-lock-error-face' to existing font-lock face.
Often an error results in several \"ERROR\" nodes in the chain towards the root.
Only the smallest error nodes should be marked.  Moreover, the span is trimmed
to exclude leading and trailing blanks, which are sometimes part of ERROR nodes."
  (when (and f90-ts-font-lock-error-show
             (let ((sparse-tree (treesit-induce-sparse-tree node "^ERROR$")))
               ;; if the sparse-tree has only one node (node itself),
               ;; it has the shape "(nil (node))"
               (and (= (length (cdr sparse-tree)) 1)
                    (null (cdr (cadr sparse-tree))))))

    (cl-destructuring-bind (start . end) (f90-ts--node-span-trimmed node)
      (let ((end-err (if (eq f90-ts-font-lock-error-show 'all)
                         end
                       (cl-assert (and (integerp f90-ts-font-lock-error-show)
                                       (> f90-ts-font-lock-error-show 0))
                                  nil
                                  "invalid value f90-ts-font-lock-error-show: %s"
                                  f90-ts-font-lock-error-show)
                       ;; go f90-ts-font-lock-error-show minus one line forward and
                       ;; then trim to last character of that line
                       (save-excursion
                         (goto-char start)
                         (end-of-line f90-ts-font-lock-error-show)
                         (skip-chars-backward " \t")
                         (point)))))
        (treesit-fontify-with-override start end-err
                                       'f90-ts-font-lock-error-face
                                       'append)))))


;;;-----------------------------------------------------------------------------
;;; 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--node-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))))))


(defun f90-ts--font-lock-rules-error ()
  "Font-lock rule for error nodes.
Append a customizable property like italic or underline to hightlight an
error region, which tree-sitter was not able to parse.
This rule should be processed last, so that the error property can be
append to a determined font lock face."
  (treesit-font-lock-rules
   :language 'fortran
   :feature 'error
   '(;; if enabled append some error face properties to existing faces
     ((ERROR) @f90-ts--fontify-error))))


(defun f90-ts-font-lock-rules ()
  "Return list of font-lock rules.
Internally, some rules are selected depending on grammar properties, like
changes in how string_literal is parsed and whether it is decomposed."
  (append
   (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)
   (f90-ts--font-lock-rules-error)))

;;;-----------------------------------------------------------------------------
;;; 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 10
  "Fixed size for `f90-ts--indent-cache'.")


;; slot indices of indent cache
;; (node,parent) and various related nodes
(defconst f90-ts--indent-slot-node               0)
(defconst f90-ts--indent-slot-parent             1)
(defconst f90-ts--indent-slot-parent-nopp        2)
(defconst f90-ts--indent-slot-gparent-nopp       3)
(defconst f90-ts--indent-slot-child0             4)
(defconst f90-ts--indent-slot-prev-sib-by-parent 5)
(defconst f90-ts--indent-slot-prev-stmt-first    6)
(defconst f90-ts--indent-slot-prev-stmt-keyword  7)
;; 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             8)
(defconst f90-ts--indent-slot-offset             9)


(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-parent-nopp ()
  "Return no-preproc parent of node.
Use cached value or compute using cached node.
The no-preproc parent is parent if it is a normal non-preproc node,
otherwise it is the first such ancestor of parent."
  (f90-ts--indent-with-cache
   f90-ts--indent-slot-parent-nopp
   (let ((parent (f90-ts--indent-cached-parent)))
     (and parent (f90-ts--parent-no-preproc parent)))))


(defun f90-ts--indent-grandparent-nopp ()
  "Return no-preproc grandparent of node.
Use cached value or compute using cached node.
It is the no-preproc parent of the no-preproc parent of the (node,parent) pair."
  (f90-ts--indent-with-cache
   f90-ts--indent-slot-gparent-nopp
   (let ((parent (f90-ts--indent-cached-parent)))
     (and parent (f90-ts--grandparent-no-preproc parent)))))


(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.  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, we can compute the delta and add it to all cached lines.  This is
necessary to have consistent indentation across all previous lines

The cache also stores BOL-COL to detect, whether internal indentation
buffer of `treesit-indent-region' has already been flushed for a line.

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 (anoff)
  "Return the final column of ANOFF in a continued statement.
ANOFF is a cons (ANCHOR.OFFSET), where ANCHOR is a node or buffer position on
some previous line, for which indentation has already been computed.
OFFSET is an integer value to provide a relative offset to the anchor.
It is allowed to be negative.  If the resulting column becomes negative,
then it is bounded by zero.

Lookup the cache for the line anchor is placed on.  If current and cached
indentation is equal, then apply cached delta to current column,
otherwise return column as is."
  (let* ((anchor (car anoff))
         (offset (cdr anoff))
         (pos (if (treesit-node-p anchor)
                  (treesit-node-start anchor)
                anchor))
         (col (max 0 (+ (f90-ts--column-number-at-pos pos)
                        offset))))
    (if f90-ts--align-continued-variant-tab
        ;; line based indentation, no caching
        col
      (let* ((line (line-number-at-pos pos))
             (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--node-openmp-p node)))


(defun f90-ts--preproc-node-is (node _parent _bol &rest _)
  "Succeed if NODE a fortran preprocessor statement."
  (and node (f90-ts--node-preproc-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--node-preproc-p parent)
       (let ((ancestor (treesit-parent-until
                        parent
                        (lambda (n)
                          (not (f90-ts--node-preproc-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--nopp-parent-is (type-p)
  "Provide patched matcher `parent-is' as used by `treesit-simple-indent'.
TYPE-P is expected to be a regular expressions.  It is matched against type
of the parent of node, in general.
However, if parent is a preprocessor node, then ascend the tree until
a normal node is encountered."
  (lambda (_node parent _bol &rest _)
    (let ((parent-nopp (f90-ts--parent-no-preproc parent)))
      (f90-ts--node-type-match-p parent-nopp type-p))))


(defun f90-ts--nopp-n-p-gp (type-n type-p type-gp)
  "Provide patched matcher `n-p-gp' as used by `treesit-simple-indent'.
TYPE-N, TYPE-P and TYPE-GP are expected to be a regular expressions.
They are matched against type of node, its parent and grandparent, in general.
However, if parent or grand-parent are preprocessor node, then ascend the
tree until normal nodes are encountered."
  (lambda (node parent _bol &rest _)
    (let* ((parent-nopp (f90-ts--parent-no-preproc parent))
           (grandparent-nopp (f90-ts--grandparent-no-preproc parent)))
      (and (f90-ts--node-type-match-p node type-n)
           (f90-ts--node-type-match-p parent-nopp type-p)
           (f90-ts--node-type-match-p grandparent-nopp type-gp)))))


(defun f90-ts--nopp-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 node,
TYPE-P is matched against type of no-preproc 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))
          (parent-nopp (f90-ts--parent-no-preproc parent)))
      (and (f90-ts--node-type-match-p node type-n)
           (f90-ts--node-type-match-p parent-nopp type-p)
           (f90-ts--node-type-match-p pstmt-k type-pstmtk)))))


(defun f90-ts--nopp-n-p-gp-pstmtk (type-n type-p type-gp type-pstmtk)
  "Succeed if types of nodes match provided types.
TYPE-N, TYPE-P, TYPE-GP 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 node,
TYPE-P is matched against type of no-preproc parent and
TYPE-GP is matched against type of no-preproc grandparent 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))
          (parent-nopp (f90-ts--parent-no-preproc parent))
          (grandparent-nopp (f90-ts--grandparent-no-preproc parent)))
      (and (f90-ts--node-type-match-p node type-n)
           (f90-ts--node-type-match-p parent-nopp type-p)
           (f90-ts--node-type-match-p grandparent-nopp type-gp)
           (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 node,
TYPE-P is matched against type of 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--nopp-parent (_node _parent bol &rest _)
  "Return anchor position determine by start of no-preproc PARENT.
If PARENT is not available, return BOL."
  (if-let* ((nopp-parent (f90-ts--indent-parent-nopp)))
      (treesit-node-start nopp-parent)
    bol))


(defun f90-ts--nopp-grandparent (_node _parent bol &rest _)
  "Return anchor position determine by start of no-preproc grandparaent.
The grandparent is determined by PARENT.  If PARENT is not available,
return BOL."
  (if-let* ((nopp-gparent (f90-ts--indent-grandparent-nopp)))
      (treesit-node-start nopp-gparent)
    bol))


(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."
  ;; skip preprocessor nodes in ancestor line
  (let* ((grandparent (f90-ts--indent-grandparent-nopp))
         (ggparent    (and grandparent
                           (f90-ts--grandparent-no-preproc 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--node-leftmost-unary (node)
  "Return leftmost descendant of NODE if it is an unary_expression.
This is only done, if NODE is a binary expression of type math_expression,
logical_expression or relational_expression.  It checks for field :left
and descend it until there is no such field or the node is of
type unary_expression."
  (cond
   ((f90-ts--node-type-p node "unary_expression")
    node)

   ((f90-ts--node-type-p node '("math_expression"
                                "logical_expression"
                                "relational_expression"))
    (cl-loop
     for n = node then (treesit-node-child-by-field-name n "left")
     while (and n (treesit-node-child-by-field-name n "left"))
     ;; note that a logical_expression without a left field is an unary expression
     ;; with operator .not., but it is not recorded as an unary_expression node
     finally return (when (and n
                               (f90-ts--node-type-p n '("unary_expression"
                                                        "logical_expression")))
                      n)))))


(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
    (let ((unary-leftm (f90-ts--node-leftmost-unary node)))
      (cond
       ((f90-ts--node-type-p node "ERROR")
        'error)

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

       (unary-leftm
        (if (f90-ts--node-type-p (treesit-node-child-by-field-name unary-leftm "operator")
                                 '("-" "+"))
            'operator-unary-minusplus
          ;; either user defined operator or logical .not.
          'operator-unary-other))

       ((string= (treesit-node-field-name node) "operator")
        ;; applies if node is a binary operator like "+" or ".and."
        (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)
            (_                           '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, parenthesized_expression etc.
            (_    'named))))))))


(defun f90-ts--align-nsym-compatible-p (nsym1 nsym2)
  "Return non-nil if NSYM1 and NSYM2 are considered compatible for alignment.
Two node symbols are equal if `eq', or if both NSYM1 and NSYM2 are
members of `(named operator-unary-minusplus operator-unary-other)'
We consider operator-unary of type named, but with the hint to adjust
offset to align the body and ignore the leading minus."
  (or (eq nsym1 nsym2)
      (and (memq nsym1 '(named operator-unary-minusplus operator-unary-other))
           (memq nsym2 '(named operator-unary-minusplus operator-unary-other)))))


(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-op-expr-p))


(defun f90-ts--align-list-aux-context-p (context)
  "Return t if the node CONTEXT represents an auxiliary context node.
In some cases, a list context is part of an assignment, parenthesized
expression or a comma separated list, which are called auxiliary context."
  (f90-ts--node-type-p context '("=" "(" ",")))


;;++++++++++++++
;; 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 expression tree NODE.
An expression like (A and B and C) or (x + y) is represented as a binary tree
like logical_expression(logical_expression(A and B) and C).
The routine returns the five children A, and, B, and, C.
Similar for other expression types like math_expression.
It does not descend into parenthesized_expressions and unary_expression whose
operator is a minus."
  (if (and (f90-ts--node-op-expr-p node)
           (not (and (f90-ts--node-type-p node "unary_expression")
                     (f90-ts--node-type-p (treesit-node-child-by-field-name node "operator")
                                          "-"))))
      (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-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--align-list-aux-context-p aux-context))
               "invalid aux context, 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 (cons arg1 (or arg2 0))
                           ,acc)))

                 (as-primary (arg1 &optional arg2)
                   (cl-assert (or (null arg1)
                                  (and (consp arg1) (not arg2))
                                  (integerp arg1)
                                  (treesit-node-p arg1))
                              nil "wrong usage of as-primary")
                   (setq ,acc (append ,acc
                                      (list
                                       (cond
                                        ((consp arg1) arg1)
                                        (arg1 (cons arg1 (or arg2 0))))))))

                 (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)))
    (cons (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 cons (node . offset).  It is assumed that anchor
is a node (in general it is a node or a buffer position) and offset is 0."
  (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 cons (node . offset).  It is assumed that anchor
is a node (in general it is a node or a buffer position) and offset is 0."
  ;;(f90-ts-log-msg :smallcol "cache = %s" f90-ts--continued-line-cache)
  ;;(cl-loop
  ;; for node-off in items
  ;; do (f90-ts-log-msg :smallcol "node-off col = %s, %s"
  ;;     node-off (f90-ts--continued-line-cache-get-col node-off)))
  (cl-loop
   for node-off in items
   minimize (f90-ts--continued-line-cache-get-col node-off)))


(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 (cons node-lead 0))))
    (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-op-expr-p (car context))
             nil "wrong context, expected some op-expr, got '%s'" (car context))

  (let* ((aux-context (cdr context)))
    (f90-ts--collecting-anoff
     (when aux-context
       (cl-assert (f90-ts--align-list-aux-context-p aux-context)
                  "invalid aux context, list-context=%, aux-context=%s"
                  (car context) 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 there is an auxiliary context, one of the three cases is true
                               ("("
                                (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.

If ITEMS-SYM in ITEMS-PLIST 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
       (when (< (f90-ts--node-line node-colons)
                (alist-get 'line loc))
         ;; start of "::" plus f90-ts-indent-declaration
         (collect (treesit-node-start node-colons)
                  f90-ts-indent-declaration)))
      (node-type-attr
       (when (< (f90-ts--node-line node-colons)
                (alist-get 'line loc))
         ;; 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-prev-nsym (items-all cur-line)
  "Filter ITEMS-ALL and add node symbol information.
ITEMS-ALL are all nodes of a list context and might contain nodes from future
lines.

The filter removes any items not before line CUR-LINE.  It also filters out
ampersand nodes (continuation symbols), which are not relevant for alignment.
Those ampersands cannot appear as leading nodes in a line, since they leading
ampersands are removed during indentation.

It returns a list (NODE . NSYM) with symbol information for all filtered
items."
  (let ((items-filtered (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)))
    (mapcar
     (lambda (n) (cons n (f90-ts--align-node-symbol n)))
     items-filtered)))


(defun f90-ts--align-list-items-head-p (node-nsym context-line)
  "Predicate to determine relevant items on first context line (head line).
NODE-NSYM is a cons (NODE . NSYM) providing NODE and the symbol for NODE.
The predicate compares line number of NODE with CONTEXT-LINE.
It also drops comments and auxiliary context nodes (assignment, parenthesis,
comma) on the head line, as items on the head line are used to  verify whether
proper items are present on this line."
  (let ((n (car node-nsym)))
    (and (= context-line (f90-ts--node-line n))
         (not (f90-ts--node-type-p n "comment"))
         (not (f90-ts--align-list-aux-context-p n)))))


(defun f90-ts--align-list-items-tail-p (node-nsym context-line)
  "Predicate to determine relevant items in the tail after context line.
NODE-NSYM is a cons (NODE . NSYM) providing NODE and the symbol for NODE.
The predicate compares line number of NODE with CONTEXT-LINE."
  (let ((n (car node-nsym)))
    (< context-line (f90-ts--node-line n))))


(defun f90-ts--align-list-nsym-offset (loc item-nsym)
  "Compute alignment offset for ITEM-NSYM depending on LOC.
LOC is the location data at point, and provides a reference symbol and the
node at point.  ITEM-NSYM is a cons (NODE . NSYM) for a filtered item of the
list context.

NSYM at LOC and item-nsym determine the offset:
`named' is paired with `operator-unary-minusplus' gives offset -1;
`operator-unary-minusplus' paired with an item `named' gives offset 1;
otherwise offset is 0.
Note that `operator-unary-minusplus' are unary_expression nodes with
operator \"-\" and no other unary expression.
Furthermore, offset is in fact the difference of \"-\" and argument node of
unary_expression, to handle blanks between the minus and the value content."
  (let ((nsym (cdr item-nsym))
        (nsym-loc (alist-get 'nsym loc)))
    (cond
     ((and (memq nsym-loc '(named operator-unary-other))
           (eq nsym 'operator-unary-minusplus))
      (let* ((node (car item-nsym))
             (unary-leftm (f90-ts--node-leftmost-unary node))
             (arg (treesit-node-child-by-field-name unary-leftm "argument")))
        (if (= (f90-ts--node-line node) (f90-ts--node-line arg))
            (- (treesit-node-start arg) (treesit-node-start node))
          ;; argument of unary expression is not on the same line
          ;; TODO: this should be resolved at the anchor level (do not the
          ;; unary-minus node as anchor, instead use argument as anchor...)
          1)))

     ((and (eq nsym-loc 'operator-unary-minusplus)
           (memq nsym '(named operator-unary-other)))
      (let* ((node (alist-get 'node loc))
             (unary-leftm (f90-ts--node-leftmost-unary node))
             (arg (treesit-node-child-by-field-name unary-leftm "argument")))
        (if (= (f90-ts--node-line node) (f90-ts--node-line arg))
            (- (treesit-node-start node) (treesit-node-start arg))
          ;; argument of unary expression is not on the same line, there is not much we
          ;; can do about this, just move the minus one character to the left of the
          ;; '(named operator-unary-other) anchor
          -1)))

     (t 0))))


(defun f90-ts--align-list-nsym-filter-offset (items-prev-sym pred loc)
  "Filter ITEMS-PREV-SYM by PRED, then map to (NODE . OFFSET) cons cells.
ITEMS-PREV-SYM is a list of (NODE . NSYM).  PRED is called for
each (NODE . NSYM) cons cell in ITEMS-PREV-SYM.  LOC is passed to
`f90-ts--align-list-nsym-offset' to compute the offset for each item,
which satisfies PRED."
  (mapcar
   (lambda (nsym)
     (cons (car nsym)
           (f90-ts--align-list-nsym-offset loc nsym)))
   (seq-filter pred items-prev-sym)))


(defun f90-ts--align-list-map-col-pos-off (anoff)
  "Map an ANOFF = (ANCHOR.OFFSET) to a triple (COLUMN POSITION OFFSET).
ANCHOR is either a node or an otherwise obtained position.
For a node, the start position of node is used.

The returned COLUMN in the triple is the final column, taking (possibly)
cached indentation on the line at anchor into account.

OFFSET is allowed to be negative and restricted if necessary to avoid negative
column numbers."
  (cl-assert
   (and (or (treesit-node-p (car anoff))
            (integerp (car anoff)))
        (integerp (cdr anoff)))
   nil
   "anoff is not a cons (node . offset) or (pos . offset), got %s" anoff)

  (let* ((anchor (car anoff))
         (offset (cdr anoff))
         (pos (if (treesit-node-p anchor)
                  (treesit-node-start anchor)
                anchor))
         ;; we need to bound offset here if negative
         (col (f90-ts--continued-line-cache-get-col (cons pos 0)))
         (offset-bounded (max (- col) offset)))
    ;; if offset is negative, we need to be careful, to avoid getting a
    ;; negative column (corresponding to a buffer position on the
    ;; previous line), the used position must always be valid in the
    ;; current buffer before indentation takes place
    (list
     (+ col offset-bounded)
     pos
     offset-bounded)))


(defun f90-ts--align-list-cpo-sort (cpo-list)
  "Make CPO-LIST 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 ((cpo-list-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 (cpo1 cpo2)
                                 (if (> (cadr cpo1) (cadr cpo2)) cpo1 cpo2))
                               (cdr group)))
                  (seq-group-by #'car cpo-list))))
    (seq-sort (lambda (a b) (< (car a) (car b))) cpo-list-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
  ;; cpo = (column 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-off-unsorted (seq-map #'f90-ts--align-list-map-col-pos-off items))
         (col-pos-off (f90-ts--align-list-cpo-sort col-pos-off-unsorted))
         (aligned-at (seq-find (lambda (cpo) (= cur-col (car cpo)))
                               col-pos-off))
         (primary-col-pos-off (f90-ts--align-list-map-col-pos-off 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-off
    (cl-assert col-pos-off 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-off,
     ;; if this is the case we go to primary, not to first entry in col-pos-off
     ((< cur-col (caar col-pos-off))
      (cdr primary-col-pos-off))

     ;; 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-off is sorted by columns
      (let ((aligned-next (seq-find (lambda (cpo) (< cur-col (car cpo)))
                                    col-pos-off)))
        ;; next if there is a next, otherwise first entry (not necessarily primary)
        (or (cdr aligned-next)
            (cdar col-pos-off))))

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

     ;; 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-off
      ;; 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-off nil "cond logic not complete")
      (cdr primary-col-pos-off)))))


(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))))
         (node-sym (alist-get 'nsym loc))
         (items-prev-sym
          (f90-ts--align-list-filter-prev-nsym items-all cur-line))
         (items-head
          (f90-ts--align-list-nsym-filter-offset
           items-prev-sym
           (lambda (node-nsym)
             (f90-ts--align-list-items-head-p node-nsym cntxt-line))
           loc))
         (items-tail
          (f90-ts--align-list-nsym-filter-offset
           items-prev-sym
           (lambda (node-nsym)
             (f90-ts--align-list-items-tail-p node-nsym cntxt-line))
           loc))
         ;; further filter by symbol type node-sym of current node at point
         (items-sym
          (when node-sym
            (f90-ts--align-list-nsym-filter-offset
             items-prev-sym
             (lambda (nsym) (f90-ts--align-nsym-compatible-p (cdr nsym) node-sym))
             loc))))
    (list :sym  items-sym
          :prev items-prev-sym
          :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))
         ;;(_ (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-items-sym (plist-get anoff-items-plist :sym))
         (anoff-other (f90-ts--align-list-anoff-other loc
                                                      anoff-items-plist
                                                      context))
         ;; always add default continued offset position as anchor
         (anoff-continued (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-continued as fallback
         (anoff-primary (or (car anoff-other)
                            anoff-continued))
         ;; final list of anchors (which are nodes or pairs (position offset))
         (anoff-final (append (and anoff-continued (list anoff-continued))
                              anoff-other
                              anoff-items-sym)))
    ;;(f90-ts-log-msg :anoff "items-other = %s" anoff-other)
    ;;(f90-ts-log-msg :anoff "items-final = %s" anoff-final)
    ;;(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-beg (treesit-node-start ps-key))
         (stmt-root (when (<= stmt-beg pos)
                      (treesit-node-on (treesit-node-start ps-key) pos))))
    (when stmt-root
      (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 (when (f90-ts--node-op-expr-p node)   node)
              (when (f90-ts--node-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-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 where 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 is prefixed, the rest is
passed through unchanged."
  (let ((prefix-syms '(;; matcher constructor
                       nopp-parent-is
                       nopp-n-p-gp
                       nopp-n-p-pstmtk
                       nopp-n-p-gp-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
                       nopp-parent
                       nopp-grandparent
                       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 in most cases a (MATCHER ANCHOR OFFSET) form as
accepted by `f90-ts--map-rule'.  Returns a list of all expanded
triples suitable for the treesit simple indentation engine.

The first exception is (log-state MSG), which expands to the
triple ((f90-ts-log-indent-print-state MSG) parent 0) directly.

The second exception are conditional triples of the
form (when COND (MATCHER ANCHOR OFFSET))
and (unless COND (MATCHER ANCHRO OFFSET)).
COND is evaluated at runtime, and the entry contributes its triple only when
COND is non-nil (when) or nil (unless).  As the condition is evaluated after
the grammar is loaded, it can be used to adjust for grammar variants (like
`f90-ts--string-literal-decomposed-p', which checks for string_literal
parser variant)."
 `(cl-loop
   for rule in (list ,@(mapcar
                        (lambda (entry)
                          (pcase entry
                            (`(log-state ,msg)
                             `(list '(f90-ts-log-indent-print-state ,msg) 'parent 0))
                            (`(when ,cond-form (,matcher ,anchor ,offset))
                             `(when ,cond-form
                                (f90-ts--map-rule ,matcher ,anchor ,offset)))
                            (`(unless ,cond-form (,matcher ,anchor ,offset))
                             `(unless ,cond-form
                                (f90-ts--map-rule ,matcher ,anchor ,offset)))
                            (`(,matcher ,anchor ,offset)
                             `(f90-ts--map-rule ,matcher ,anchor ,offset))))
                          triples))
   when rule collect rule))


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

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


(defun f90-ts--indent-rules-comments ()
  "Indentation rules for comments (excluding OpenMP statements)."
  (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)))


(defun f90-ts--indent-rules-preproc ()
  "Indentation rules for preprocessor directives."
  (f90-ts--with-map-rules
   ;; indent preprocessor directive
   ;; directive itself: no indent
   ;; otherwise, skip preproc nodes as if they are not present
   ;; (this is done by the nopp=no-preproc mechanics)
   (preproc-node-is column-0 0)))


(defun f90-ts--indent-rules-continued ()
  "Indentation rules for continued lines."
  (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
   ((nopp-n-p-gp nil "string_literal" nil) nopp-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)))


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


(defun f90-ts--indent-rules-prog-mod ()
  "Indentation rules for program and module nodes."
  (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")    nopp-parent 0)
   ((nopp-parent-is      "program\\(_statement\\)?") nopp-parent toplevel-offset)
   ((nopp-n-p-pstmtk nil "ERROR" "program")          nopp-parent toplevel-offset)

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

   ((node-is             "end_submodule_statement")      nopp-parent 0)
   ((nopp-parent-is      "^submodule\\(_statement\\)?$") nopp-parent toplevel-offset)
   ((nopp-n-p-pstmtk nil "ERROR" "^submodule$")          nopp-parent toplevel-offset)))


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


(defun f90-ts--indent-rules-translation-unit ()
  "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."
  (f90-ts--with-map-rules
   ;; statements related to toplevel subroutine or function statements,
   ;; and ERROR cases (might or might not be toplevel)
   ;; most rules are for incomplete code (like shown in resources/indent_line_incomplete.erts)
   ;; unfortunately, these are difficult to reproduce and test with erts, as the exact composition of
   ;; relatives in the tree returned by tree-sitter queries depend on presence of trailing blanks and
   ;; newline symbols after point at |, like in this simple code piece:
   ;;
   ;; subroutine sub()
   ;; |
   ;; (as string: "subroutine sub()\n|", with point at the very last position, no newline)
   ;;
   ;; in short: there are no testcases for the following rules, but there are sometimes very short
   ;; code pieces like the above which might require exactly one of these rules...
   ((n-p-ch-psibp nil "translation_unit" nil "subroutine_statement") nopp-parent f90-ts-indent-block)
   ((n-p-ch-psibp nil "ERROR"            nil "subroutine_statement") nopp-parent f90-ts-indent-block)
   ((n-p-ch-psibp nil "translation_unit" nil "function_statement")   nopp-parent f90-ts-indent-block)
   ((n-p-ch-psibp nil "ERROR"            nil "function_statement")   nopp-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") nopp-parent f90-ts-indent-block)
   ((nopp-parent-is "translation_unit") column-0 0)))


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


(defun f90-ts--indent-rules-dtype-enum ()
  "Indentation rules for derived type and enumeration type statements."
  (f90-ts--with-map-rules
   ;; derived type definitions
   ((nopp-n-p-gp        "end_type_statement"      "derived_type_definition" nil)                      nopp-parent 0)
   ((n-p-ch-psibp       "derived_type_procedures" "derived_type_definition" "contains_statement" nil) nopp-parent 0)
   ((n-p-ch-psibp       "ERROR"                   "derived_type_definition" "contains_statement" nil) nopp-parent 0)
   ((nopp-n-p-gp-pstmtk nil                       "ERROR"                   "derived_type_definition" "contains")  previous-stmt-anchor f90-ts-indent-block)
   ((nopp-n-p-gp-pstmtk nil                       "ERROR"                   "derived_type_definition" "procedure") previous-stmt-anchor 0)
   ((nopp-parent-is     "derived_type_procedures") nopp-parent f90-ts-indent-block)
   ((nopp-parent-is     "derived_type_definition") nopp-parent f90-ts-indent-block)

   ;; enumeration types: enum and enumeration
   ((node-is         "end_enum_statement")                    nopp-parent 0)
   ((node-is         "end_enumeration_type_statement")        nopp-parent 0)
   ((nopp-parent-is  "^enum\\(eration_type\\)?$")             nopp-parent f90-ts-indent-block)
   ((nopp-n-p-pstmtk nil "ERROR" "^enum\\(eration_type\\)?$") nopp-parent f90-ts-indent-block)))


(defun f90-ts--indent-rules-if ()
  "Indentation rules for if-then-else statements."
  (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)
   ((nopp-n-p-gp     "end_if_statement" "if_statement"  nil)         nopp-parent 0)
   ((nopp-n-p-gp     "elseif_clause"    "if_statement"  nil)         nopp-parent 0)
   ((nopp-n-p-gp     "else_clause"      "if_statement"  nil)         nopp-parent 0)
   ((nopp-n-p-pstmtk nil                "if_statement"  "^if$")      nopp-parent f90-ts-indent-block) ; line right after if
   ((nopp-n-p-pstmtk nil                "if_statement"  "^else$")    nopp-parent f90-ts-indent-block) ; line right after else, with empty else block
   ((nopp-n-p-pstmtk nil                "if_statement"  "^elseif$")  nopp-parent f90-ts-indent-block) ; line right after elseif, with empty elseif block
   ((nopp-n-p-pstmtk nil                "else_clause"   "^else$")    nopp-parent f90-ts-indent-block) ; line after else, with non-empty else block
   ((nopp-n-p-pstmtk nil                "elseif_clause" "^elseif$")  nopp-parent f90-ts-indent-block) ; line right after "elseif"
   ((nopp-n-p-pstmtk nil                "elseif_clause" "^else$")    nopp-parent f90-ts-indent-block) ; line right after "else if"

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

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

   ((nopp-n-p-pstmtk nil                "ERROR" "^if$")     previous-stmt-anchor f90-ts-indent-block) ; empty line after if
   ((nopp-n-p-pstmtk nil                "ERROR" "^elseif$") previous-stmt-anchor f90-ts-indent-block) ; empty line after elseif
   ((nopp-n-p-pstmtk nil                "ERROR" "^else$")   previous-stmt-anchor f90-ts-indent-block) ; empty line after else
   ))


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

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

   ((nopp-n-p-pstmtk nil                "ERROR" "where")     previous-stmt-anchor f90-ts-indent-block) ; empty line after where
   ((nopp-n-p-pstmtk nil                "ERROR" "elsewhere") previous-stmt-anchor f90-ts-indent-block) ; empty line after elsewhere
   ))


(defun f90-ts--indent-rules-single-region ()
  "Indentation rules for single region structures.
These are do loops, block statements, associate construct and forall statements."
  (f90-ts--with-map-rules
   ;; structures with a single region block and linear execution
   ((nopp-n-p-gp     "end_do_loop" "do_loop"      nil)  nopp-parent 0)
   ((nopp-n-p-pstmtk nil                "do_loop" "do") nopp-parent f90-ts-indent-block)  ;; proper do block (with or without while)
   ((nopp-n-p-pstmtk nil                "ERROR"   "do") previous-stmt-anchor f90-ts-indent-block)

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

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

   ((nopp-n-p-gp "end_forall_statement"        "forall_statement" nil)      nopp-parent          0)
   ((nopp-n-p-pstmtk nil                       "forall_statement" "forall") nopp-parent          f90-ts-indent-block)
   ((nopp-n-p-pstmtk nil                       "ERROR"            "forall") previous-stmt-anchor f90-ts-indent-block)))


(defun f90-ts--indent-rules-select ()
  "Indentation rules for select statements (case and type)."
  (f90-ts--with-map-rules
   ;; control statements
   ((nopp-n-p-gp     "end_select_statement" "select_case_statement" nil)              nopp-parent 0)
   ((nopp-n-p-pstmtk "case_statement"       "select_case_statement" nil)              nopp-parent 0)
   ((nopp-n-p-pstmtk nil                    "select_case_statement" "case")           nopp-parent f90-ts-indent-block)
   ((nopp-n-p-pstmtk nil                    "case_statement"        "case")           nopp-parent f90-ts-indent-block)
   ((nopp-n-p-gp     "ERROR"                "select_case_statement" nil)              nopp-parent f90-ts-indent-block)
   ((nopp-n-p-gp     nil                    "ERROR"                 "case_statement") nopp-grandparent f90-ts-indent-block)
   ((nopp-parent-is                         "select_case_statement")                  nopp-parent 0)

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

   ((nopp-n-p-gp     "end_select_statement" "select_rank_statement" nil)              nopp-parent 0)
   ((nopp-n-p-pstmtk "rank_statement"       "select_rank_statement" nil)              nopp-parent 0)
   ((nopp-n-p-pstmtk nil                    "select_rank_statement" "rank")           nopp-parent f90-ts-indent-block)
   ((nopp-n-p-pstmtk nil                    "rank_statement"        "rank")           nopp-parent f90-ts-indent-block)
   ((nopp-n-p-gp     "ERROR"                "select_rank_statement" nil)              nopp-parent f90-ts-indent-block)
   ((nopp-n-p-gp     nil                    "ERROR"                 "rank_statement") nopp-grandparent f90-ts-indent-block)
   ((nopp-parent-is                         "select_rank_statement")                  nopp-parent 0)))


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

   ((nopp-n-p-gp     "end_coarray_team_statement" "coarray_team_statement" nil)      nopp-parent 0)
   ((nopp-n-p-pstmtk nil                          "coarray_team_statement" "change") nopp-parent f90-ts-indent-block)
   ((nopp-n-p-pstmtk nil                          "ERROR"                  "change") previous-stmt-anchor f90-ts-indent-block)))


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


(defun f90-ts-indent-rules ()
  "List of all indentation rules.
Rules are evaluated in the given order, which is important in some cases.
In particular, comments and continued lines must be dealt with before most
other 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))))


;;;-----------------------------------------------------------------------------
;;; 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)")
    ;; this is counter intuitive: "change team" is ended by "end team" not by "end change team"
    ("coarray_team_statement"     . "(coarray_team_statement (block_label_start_expression _ @name \":\")? \"change\" \"team\" @construct)"))
  "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 starting with `wcml-'in BODY."
  (declare (indent 0))
  `(let* ((wcml-modified-before (buffer-modified-p))
          (wcml-beg (line-beginning-position))
          (wcml-end (line-end-position))
          (f90-ts--indent-modified-outside-line nil)
          (wcml-line-before (unless wcml-modified-before
                              (buffer-substring-no-properties
                               wcml-beg wcml-end)))
          wcml-bol-marker
          wcml-eol-marker)
     (unwind-protect
         (progn
           (setq wcml-bol-marker (copy-marker wcml-beg))
           (setq wcml-eol-marker (copy-marker wcml-end t))
           ,@body
           (unless (or wcml-modified-before
                       f90-ts--indent-modified-outside-line)
             (when (string= wcml-line-before
                            (buffer-substring-no-properties
                             wcml-bol-marker wcml-eol-marker))
               (restore-buffer-modified-p nil))))
       (set-marker wcml-bol-marker nil)
       (set-marker wcml-eol-marker 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 starting with `wcmr-' in BODY."
  (declare (indent 2))
  `(let* ((wcmr-modified-before (buffer-modified-p))
          (wcmr-region-before (unless wcmr-modified-before
                                (buffer-substring-no-properties ,beg ,end)))
          wcmr-end-marker)
     (unwind-protect
         (progn
           (setq wcmr-end-marker (copy-marker ,end t))
           ,@body
           (unless wcmr-modified-before
             (when (string= wcmr-region-before
                            (buffer-substring-no-properties ,beg wcmr-end-marker))
               (restore-buffer-modified-p nil))))
       (set-marker wcmr-end-marker 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

(defconst f90-ts--join-line-prev-valid-actions
  '(empty-line
    beg-of-buffer
    remove-blank-lines-between
    join-continued-lines
    join-continued-string
    join-comments-same-prefix-trimmed
    join-comments-same-prefix-with-blanks
    append-comment-after-amp
    append-comment-after-stmt
    failed-comment-within-string)
  "All valid action symbols returned by `f90-ts--join-line-prev-aux'.")


(defconst f90-ts--join-line-next-valid-actions
  '(empty-line
    end-of-buffer
    remove-blank-lines-between
    join-continued-lines
    join-continued-string
    join-comments-same-prefix-trimmed
    join-comments-same-prefix-with-blanks
    append-comment-after-amp
    append-comment-after-stmt
    failed-comment-within-string)
  "All valid action symbols returned by `f90-ts--join-line-next-aux'.")


(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)))


(defun f90-ts--complete-end-node-p (node pos end-marker at-col0)
  "Predicate for `treesit-search-forward' in smart end completion loop.
Return non-nil if NODE is a completion target within POS and END-MARKER.
If AT-COL0 is non-nil, do no accept nodes at starting at END-MARKER.
Thus do not work on nodes at the line if end marker is at column 0.

It throws `f90-ts--past-end' if END-MARKER has been passed, as there is
no abort mechanism for `treesit-search-foward'."
  (let ((start-n (treesit-node-start node))
        (end-n  (f90-ts--node-end-trimmed node)))
    (when (or (> start-n end-marker)
              (and at-col0 (= start-n end-marker)))
      ;; treesit-search-forward has no early abort option,
      ;; without this, the search exhausts the whole remaining tree
      (throw 'f90-ts--past-end nil))
    (and (<= pos end-n)
         (member (treesit-node-type node)
                 f90-ts--complete-end-structs))))


;; 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))
         ;; skip the final line if end-pos is at zeroth column
         (at-col0 (= 0 (f90-ts--column-number-at-pos end-pos)))
         (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)
                           (f90-ts--complete-end-node-p n pos end-marker at-col0))
                         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)
                  (goto-char node-start)
                  (let ((line (line-number-at-pos)))
                    ;; that a bit difficult, if at end of buffer, `forward-line'
                    ;; does not progress a line, but still reports success, so we
                    ;; explicitly check line numbers
                    (forward-line 1)
                    (if (= line (line-number-at-pos))
                        (throw 'f90-ts--past-end nil)
                      (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 most cases, this just behaves like `f90-ts--indent-and-complete-line'.
However, in two cases this indents and complete a region associated with
the statement or block at point.

If point is on an \"end\" statement of some structure like a \"subroutine\",
a \"do\" or an \"if\" block, then the whole structure is indented as a region.

If point is on a line within a continued statement, it first indents the
statement starting at its first up to the current line as a region.
If the operation has not changed anything, then and only then it indents
the current line by invoking `f90-ts--indent-and-complete' to apply rules
like rotation of list context items.

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 'with-blanks)))
      (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 'with-blanks)))
      (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-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-action-common (first secnd is-prev)
  "Compute an action pair for joining lines at FIRST and SECND.
The pair (THUNK . ACTION) provides a THUNK to perform the join and an ACTION
symbol describing what is done.

The ACTION symbol is used by the caller to decide whether to execute the thunk,
for example in a `fill-region' loop context.

Argument IS-PREV signals whether the function was called from the
`join-line-prev' or the `join-line-next' function."
  (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")))
    (cond
     ((and is-amp-1st
           is-amp-2nd)
      (let ((beg (treesit-node-start first))
            (end (treesit-node-end secnd)))
        (cons (lambda ()
                (delete-region beg end)
                (goto-char beg)
                (fixup-whitespace)
                (skip-chars-forward " \t"))
              'join-continued-lines)))

     ((and is-amp-1st
           is-comment-2nd)
      (let ((beg (treesit-node-end first))
            (end (treesit-node-start secnd)))
        (cons (lambda ()
                (delete-region beg end)
                (goto-char beg)
                (insert " "))
              'append-comment-after-amp)))

     ((and is-comment-1st
           is-comment-2nd
           (string= (f90-ts--comment-prefix first 'trimmed)
                    (f90-ts--comment-prefix secnd 'trimmed)))
      (let ((beg (save-excursion
                   (goto-char (treesit-node-end first))
                   (skip-chars-backward " \t")
                   (point)))
            (end (+ (treesit-node-start secnd)
                    (length (f90-ts--comment-prefix secnd 'with-blanks)))))
        (cons (lambda ()
                (delete-region beg end)
                (goto-char beg)
                (insert " "))
              ;; join and fill operation behave differently: do not join in
              ;; fill operation, if indentation is different, so signal whether
              ;; prefixes including blanks or only trimmed
              (if (string= (f90-ts--comment-prefix first 'with-blanks)
                           (f90-ts--comment-prefix secnd 'with-blanks))
                  'join-comments-same-prefix-with-blanks
                'join-comments-same-prefix-trimmed))))

     ((and (null is-comment-1st)
           is-comment-2nd)
      (let ((beg (save-excursion
                   (goto-char (treesit-node-end first))
                   (skip-chars-backward " \t")
                   (point)))
            (end (treesit-node-start secnd)))
        (cons (lambda ()
                (delete-region beg end)
                (goto-char beg)
                (insert " "))
              'append-comment-after-stmt)))

     (t
      (let ((beg (save-excursion
                   (goto-char (treesit-node-end first))
                   (line-beginning-position 2)))
            (end (save-excursion
                   (goto-char (treesit-node-start secnd))
                   (line-beginning-position))))
        (cons (lambda ()
                (delete-region beg end)
                (goto-char beg)
                (if is-prev
                    (skip-chars-forward " \t")
                  (skip-chars-backward " \t\n")))
              'remove-blank-lines-between))))))


(defun f90-ts--join-line-prev-aux ()
  "Join previous line with the current one, if part of a continued statement.
Returns a cons (THUNK . ACTION); the caller is responsible for executing
THUNK and for messaging on failure."
  (cond
   ((f90-ts--point-on-empty-line-p)
    (cons (lambda () (f90-ts--join-line-empty-prev))
          'empty-line))

   ((save-excursion
      (back-to-indentation)
      (bobp))
    (cons (lambda () (beginning-of-line))
          'beg-of-buffer))

   (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 'left))
           (secnd (f90-ts--node-on-pos pos2 'right))
           (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))
                         (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
        (if (eq (char-before pos1) ?&)
            (cons (lambda () (f90-ts--join-line-string first pos1 pos2))
                  'join-continued-string)
          (cons (lambda () (back-to-indentation))
                'failed-comment-within-string)))

       (first
        (f90-ts--join-line-action-common first secnd t))

       (t
        (cons (lambda ()
                (back-to-indentation)
                (delete-region pos1 (point)))
              'beg-of-buffer)))))))


(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)
  (let* ((pair (f90-ts--join-line-prev-aux))
         (process-fn (car pair))
         (action (cdr pair)))
    (cl-assert (member action f90-ts--join-line-prev-valid-actions)
               nil "invalid action from f90-ts--join-line-prev-aux, got %s" action)
    (funcall process-fn)
    (when (and (called-interactively-p 'interactive)
               (eq action 'failed-comment-within-string))
      (message "join failed: joining not possible"))))


(defun f90-ts--join-line-next-aux ()
  "Join current line with the next one, if part of a continued statement.
Returns a cons (THUNK . ACTION); the caller is responsible for executing
THUNK and for messaging on failure."
  (cond
   ((f90-ts--point-on-empty-line-p)
    (cons (lambda () (f90-ts--join-line-empty-next))
          'empty-line))

   ((save-excursion
      (end-of-line)
      (eobp))
    (cons (lambda () (end-of-line))
          'end-of-buffer))

   (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 'left))
           (secnd (f90-ts--node-on-pos pos2 'right))
           (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
                     (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")
      (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 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")
        (cons (lambda ()
                (end-of-line)
                (delete-region (point) pos2))
              'end-of-buffer))

       (is-cont-str
        (if (eq (char-after pos2) ?&)
            (cons (lambda () (f90-ts--join-line-string first pos1 pos2))
                  'join-continued-string)
          (cons (lambda () (end-of-line))
                'failed-comment-within-string)))

       (t
        (f90-ts--join-line-action-common first secnd nil)))))))


(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)
  (let* ((pair (f90-ts--join-line-next-aux))
         (process-fn (car pair))
         (action (cdr pair)))
    (cl-assert (member action f90-ts--join-line-next-valid-actions)
               nil "invalid action from f90-ts--join-line-next-aux, got %s" action)
    (funcall process-fn)
    (when (and (called-interactively-p 'interactive)
               (eq action 'failed-comment-within-string))
      (message "join failed: joining not possible"))))


(defun f90-ts-shift-line-break ()
  "Shift the break point of current line to point.
It breaks line at point and then joins the trailing part with the next line.
If point is at end of line, then it does not nothing except to move point to
indentation of next line."
  (interactive)
  (if (save-excursion
        (skip-chars-forward " \t")
        (eolp))
      (when (zerop (forward-line 1))
        (back-to-indentation)
        (let ((node (treesit-node-at (point))))
          (when (f90-ts--node-type-p node "comment")
            (f90-ts--comment-forward-prefix node)
            (skip-chars-forward " \t"))))
    (f90-ts-break-line)
    (f90-ts-join-line-next)))


;;;-----------------------------------------------------------------------------
;;; fill operations
;;; the code is inspired and partially copied from the f90-mode.el in emacs core

(defconst f90-ts--join-line-fill-auto-actions
  '(join-continued-lines
    join-continued-string
    join-comments-same-prefix-with-blanks)
  "Set of join actions for non-interactive join during fill operations.
It is a subset of `f90-ts--join-line-next-valid-actions'.")


(defconst f90-ts--join-line-fill-interactive-actions
  '(join-continued-lines
    join-continued-string
    join-comments-same-prefix-trimmed
    join-comments-same-prefix-with-blanks
    append-comment-after-amp
    append-comment-after-stmt)
  "Set of join actions for interactive join during fill operations.
It is a subset of both `f90-ts--join-line-prev-valid-actions'
and `f90-ts--join-line-next-valid-actions' and used for interactive join with
previous and with next line.")


(defvar-local f90-ts--breakpoint-seed-markers nil
  "List of markers recording positions where continuation lines were joined.
It has the format (cons POS-MARKER SEED-MARKERS), where pos-marker stores
current point as preferred initial position, seed-markers are other seeds.
The other seeds are populated by `f90-ts--join-line-fill' during the join
phase and consumed by `f90-ts--find-breakpoint' during the subsequent break
phase to choose initial interactive position in case pos-marker is not
available.  Cleared after each statement is joined and broken up completely.")


(defun f90-ts--breakpoint-seed-markers-reset ()
  "Reset `f90-ts--breakpoint-seed-markers', invalidating all markers."
  (when-let* ((m (car f90-ts--breakpoint-seed-markers)))
    (set-marker m nil))
  (cl-loop for m in (cdr f90-ts--breakpoint-seed-markers)
           do (set-marker m nil))
  (setq f90-ts--breakpoint-seed-markers (cons nil nil)))


(defun f90-ts--seed-markers-pos-marker ()
  "Return the pos-marker from `f90-ts--breakpoint-seed-markers', or nil."
  (car f90-ts--breakpoint-seed-markers))


(defun f90-ts--seed-markers-seeds ()
  "Return the seed marker list from `f90-ts--breakpoint-seed-markers'."
  (cdr f90-ts--breakpoint-seed-markers))


(defun f90-ts--seed-markers-set-pos (pos)
  "Set or update the pos-marker to POS in `f90-ts--breakpoint-seed-markers'."
  (unless f90-ts--breakpoint-seed-markers
    (setq f90-ts--breakpoint-seed-markers (cons nil nil)))
  (if-let* ((m (car f90-ts--breakpoint-seed-markers)))
      (set-marker m pos)
    (setcar f90-ts--breakpoint-seed-markers (set-marker (make-marker) pos))))


(defun f90-ts--seed-markers-push ()
  "Push a seed marker at the current non-whitespace position.
Skips backward over whitespace before recording the position.
Does nothing if a seed marker at that position already exists."
  (save-excursion
    (skip-chars-backward " \t")
    (let ((pos (point)))
      (unless (cl-loop for m in (f90-ts--seed-markers-seeds)
                       when (= (marker-position m) pos) return t)
        (unless f90-ts--breakpoint-seed-markers
          (setq f90-ts--breakpoint-seed-markers (cons nil nil)))
        (push (copy-marker pos) (cdr f90-ts--breakpoint-seed-markers))))))


(defun f90-ts--seed-markers-invalidate-pos ()
  "Invalidate the pos-marker in `f90-ts--breakpoint-seed-markers'."
  (when-let* ((m (car f90-ts--breakpoint-seed-markers)))
    (set-marker m nil)
    (setcar f90-ts--breakpoint-seed-markers nil)))


(defun f90-ts--seed-markers-cleanup-before (pos)
  "Discard seed markers at or before POS, keeping those beyond it."
  (when f90-ts--breakpoint-seed-markers
    (setcdr f90-ts--breakpoint-seed-markers
            (cl-loop
             for m in (f90-ts--seed-markers-seeds)
             if (> (marker-position m) pos)
             collect m
             else do (set-marker m nil)))))


(defun f90-ts--breakpoint-node-within-fill-col-p (node pos fill-col)
  "Return non-nil if POS is within the effective fill column for NODE.
If NODE is a comment, no continuation ampersand is added, so FILL-COL
is compared directly.  Otherwise two characters are subtracted to
account for the space and ampersand appended by the break operation."
  (<= (f90-ts--column-number-at-pos pos)
      (if (f90-ts--node-type-p node "comment")
          fill-col
        (- fill-col 2))))


(defun f90-ts--breakpoint-pos-within-fill-col-p (pos fill-col)
  "Return non-nil if POS is within the effective fill column.
Depending on whether pos is within a statement or with a comment, FILL-COL
needs to be adjusted.
Like `f90-ts--breakpoint-node-within-fill-col-p', but queries the node at
POS via `treesit-node-at'."
  (f90-ts--breakpoint-node-within-fill-col-p (treesit-node-at pos) pos fill-col))


(defun f90-ts--find-breakpoint-prefer-p (node)
  "Decide whether the end point of NODE is a preferred breakpoint.
If possible, certain positions, like directly left of a comma, opening
parenthesis, before or after \"%\" in component selection should be avoided.
This predicate is ignored in break point selection only if no break point can
be found otherwise."
  (let* ((pos-next (save-excursion
                     (goto-char (treesit-node-end node))
                     (skip-chars-forward " \t\n")
                     (point)))
         (node-next (when pos-next
                    (treesit-node-at pos-next))))
    (not (or
          ;; do not split right before any of these delimiters
          (f90-ts--node-type-p node-next '("," "(" "%"))
          ;; do not split after this delimiter
          (f90-ts--node-type-p node "%")))))


(defun f90-ts--find-breakpoint-in-comment (node fill-col)
  "Find all break positions inside comment NODE at column <= FILL-COL.
Scan the comment text for word boundaries (whitespace preceded by a
non-whitespace character) that fall within the fill budget.  The
comment prefix (matched by `f90-ts-comment-prefix-regexp') is skipped
before searching for break candidates.
Returns a sorted list of buffer positions, or nil."
  (let* ((end (f90-ts--node-end-trimmed node)))
    (save-excursion
      (f90-ts--comment-forward-prefix node)
      (sort
       (cl-loop
        with prefix-end = (point)
        while (re-search-forward "\\S-\\(\\s-+\\)\\S-" end t)
        for pos = (match-beginning 1)
        ;; go back to avoid skipping the last \\S- match, which is
        ;; captured in the next loop as the first \\S-, otherwise we skip
        ;; one letter words like "a"
        do (goto-char (match-end 1))
        when (<= (f90-ts--column-number-at-pos pos) fill-col)
        collect pos
        into positions
        finally return (if (eq f90-ts-fill-select-breakpoint-by 'interactive)
                           (cons end (cons prefix-end positions))
                         positions))
       #'<))))


(defun f90-ts--find-breakpoint-collect (sparse-tree)
  "Collect all break-point positions from SPARSE-TREE.
SPARSE-TREE is a cons of a list of position integers and a possibly empty list
of children of the same format as SPARSE-TREE.
It returns a sorted list of buffer positions of prospective breakpoints."
  (let ((collected (cl-labels
                       ((collect (tree)
                          (when (consp tree)
                            (append (car tree)
                                    (seq-mapcat #'collect (cdr tree))))))
                     (collect sparse-tree))))
    (delete-dups
     (sort collected #'<))))


(defun f90-ts--find-breakpoints-for-node (node fill-col)
  "Return a list of break positions for NODE before FILL-COL.
In general, it returns the (trimmed) end position of the node as a
singleton list, if the column is below (- FILL-COL 2).  Two is subtracted to
account for a blank and the continuation symbol, which will be added by
breaking at this position.  However, for comment nodes, there might be several
prospective positions within the node.  These are collected by
`f90-ts--find-breakpoint-in-comment'."
  (if (f90-ts--node-type-p node "comment")
      (f90-ts--find-breakpoint-in-comment node fill-col)
    (let* ((pos (f90-ts--node-end-trimmed node)))
      (when (f90-ts--breakpoint-node-within-fill-col-p node pos fill-col)
        (list pos)))))


(defun f90-ts--find-breakpoint-sparse-tree (root beg end fill-col &optional prefer-p)
  "Return sparse tree of nodes, whose end position are possible breakpoints.
Start at ROOT, which should be some node properly covering the line to be
broken.

Nodes are selected by their (trimmed) end position.  In particular, a node's
end should be between BEG and END and sufficiently below FILL-COL (in general,
two characers are required for the \" &\" continuation symbol.

Predicate function PREFER-P can be be used additionally to other selection
conditions to reduce the tree to only contain preferred break points."
  ;; first map root to a sparse tree of prospective positions,
  ;; then collect and sort the list
  (treesit-induce-sparse-tree
   root
   (lambda (n)
     (let* ((end-node (f90-ts--node-end-trimmed n)))
       ;; only leaf nodes whose trimmed end falls on the
       ;; current line, the column check is done in the process-fn
       ;; function, as comment nodes need special care
       (and (null (treesit-node-children n))
            (<= beg end-node)
            (<= end-node end)
            (not (f90-ts--node-type-p n "&"))
            (or (null prefer-p) (funcall prefer-p n)))))
   (lambda (n) (f90-ts--find-breakpoints-for-node n fill-col))))


(defun f90-ts--find-breakpoint-rightmost-idx (positions fill-col)
  "Return index in POSITIONS of the rightmost candidate within FILL-COL.
A candidate satisfies the constraint according to
`f90-ts--breakpoint-pos-within-fill-col-p'.  Return nil if no candidate
in POSITIONS satisfies it."
  (when-let* ((target (cl-loop
                        for p in positions
                        when (f90-ts--breakpoint-pos-within-fill-col-p p fill-col)
                        maximize p)))
    (cl-position target positions)))


(defun f90-ts--find-breakpoint-read-key (idx positions fill-col at-end)
  "Read one key and return (IDX ACTION) for candidate POSITIONS.
ACTION is nil to continue, or a symbol: `confirm', `join', `skip',
`abort', `continue'.  AT-END controls whether SPC is is just a skip
line operation or whether it extends the region by one line.
FILL-COL is used to determine the target position for the \"r\" key,
which jumps to the rightmost candidate at or before FILL-COL."
  (let ((prompt (concat "Select break point: left/right/home/end or C-p/C-n, "
                        "r rightmost, "
                        "BACKSPACE/DEL join, RET confirm"
                        (if at-end
                            ", q skip, SPC skip and extend region"
                          ", q/SPC skip")
                        ", C-g abort")))
    (message prompt))
  (let ((key (read-key))
        (num-pos (length positions)))
    (cond
     ((or (eq key 'left)  (eq key ?\C-p)) (list (mod (1- idx) num-pos) nil))
     ((or (eq key 'right) (eq key ?\C-n)) (list (mod (1+ idx) num-pos) nil))
     ((eq key 'home)                      (list 0                      nil))
     ((eq key 'end)                       (list (1- num-pos)           nil))
     ((eq key ?r)
      (list (or (f90-ts--find-breakpoint-rightmost-idx positions fill-col) idx)
            nil))
     ((memq key '(return ?\r ?\n))        (list idx                    'confirm))
     ((eq key ?\d)                        (list idx                    'join-prev))
     ((eq key 'deletechar)                (list idx                    'join-next))
     ((eq key ?q)                         (list idx                    'skip))
     ((eq key ?\C-g)                      (list idx                    'abort))
     ((eq key ?\s)                        (list idx                    (if at-end 'continue 'skip)))
     ;; ignore any other keys, and keep idx
     (t                                   (list idx                    nil)))))


(defun f90-ts--find-breakpoint-initial-pos (positions fill-col)
  "Return initial position for interactive breakpoint selection from POSITIONS.
If the pos-marker in `f90-ts--breakpoint-seed-markers' is valid, return
the closest candidate at or before it.  Otherwise, return the closest
candidate at or before the rightmost seed marker within FILL-COL.
If no seed markers are available, return the rightmost candidate within
FILL-COL."
  (or
   ;; pos-marker: closest candidate at or before it
   (when-let* ((m (f90-ts--seed-markers-pos-marker))
               (ref (marker-position m)))
     (cl-loop
      for p in positions
      when (<= p ref)
      maximize p into best
      finally return best))

   ;; other seed-markers: rightmost marker within fill-col and then
   ;;                     closest candidate at or before it
   (when-let* ((ref (cl-loop
                     for m in (f90-ts--seed-markers-seeds)
                     for mpos = (marker-position m)
                     when (and mpos
                               (f90-ts--breakpoint-pos-within-fill-col-p mpos fill-col))
                     maximize mpos into best
                     finally return best)))
     (cl-loop
      for p in positions
      when (<= p ref)
      maximize p into best
      finally return best))

   ;; fallback: rightmost candidate in positions within fill-col
   (cl-loop
    for p in positions
    when (f90-ts--breakpoint-pos-within-fill-col-p p fill-col)
    maximize p into best
    finally return best)))


(defun f90-ts--find-breakpoint-interactive (positions fill-col allow-continue)
  "Interactively select a break point from POSITIONS.
Moves point to each candidate position as the user navigates with
LEFT/RIGHT or \\[previous-line]/\\[next-line].  Returns the selected position
on RET, or nil on \\[keyboard-quit].
Use POSITIONS to determine a candidate closest to FILL-COL but before that.
ALLOW-CONTINUE controls whether SPC is offered to extend the fill region.

Remark: the `read-key' loop in `f90-ts--find-breakpoint-read-key' blocks other
interaction (like scrolling in another buffer with mouse).  This might need
some improvements."
  (when-let* ((initial-pos (or (f90-ts--find-breakpoint-initial-pos positions fill-col)
                               ;; no previous breakpoint available, then look into positions
                               ;; before fill-col
                               (cl-loop for p in positions
                                        when (<= (f90-ts--column-number-at-pos p) fill-col)
                                        maximize p)
                               ;; use smallest position available as fallback
                               (car positions)))
              (idx (cl-position initial-pos positions))
              (orig-point (point))
              (orig-cursor cursor-type))
    (unwind-protect
        (progn
          ;; make cursor bar of roughly one third of character width
          (setq cursor-type (cons 'bar (max 2 (/ (frame-char-width) 3))))
          (goto-char (nth idx positions))
          (cl-loop
           for (new-idx action) = (f90-ts--find-breakpoint-read-key idx positions fill-col
                                                                    allow-continue)
           do (setq idx new-idx)
           until action
           do (goto-char (nth idx positions))
           ;; track current position in pos-marker in seed-markers list
           do (f90-ts--seed-markers-set-pos (point))
           finally return (pcase action
                            ;; return value nil signals that no position is available,
                            ;; do not break this line
                            ('confirm    (nth idx positions))
                            ('join-prev  'join-prev)
                            ('join-next  'join-next)
                            ('skip       nil)
                            ('abort      'abort)
                            ('continue   'continue))))
      (setq cursor-type orig-cursor)
      (goto-char orig-point))))


(defun f90-ts--find-breakpoints-all (fill-col fill-col-select)
  "Collect all candidate break points on the current line.
A break point is any end position of a leaf node on the current line,
at column at most FILL-COL-SELECT minus 2 and beyond the estimated
indentation of the continuation line.  FILL-COL is used to compute
that indentation estimate.
Returns a list of candidate POSITIONS.  First preferred positions are tried,
and if nil, then all positions are determined.  If no positions exist,
then it returns nil."
  (let* ((beg (line-beginning-position))
         (end (line-end-position))
         ;; estimate the indentation of the line after breaking it, we need
         ;; to make sure that the break point is before new indentation level
         ;; TODO: what kind of estimate do we really need here??
         ;; examples: single line statement, multiline statements, comments
         ;;           statement with trailing comment, ...
         (indent (save-excursion
                   (back-to-indentation)
                   (let ((node (treesit-node-at (point))))
                     (+ (point)
                        (cond
                         ((f90-ts--subsequent-line-of-continued-stmt-p (point))
                          1)
                         ((f90-ts--node-type-p node "comment")
                          0)
                         (t
                          f90-ts-indent-continued))))))
         (root (treesit-node-on beg end))
         (pos-prefer (f90-ts--find-breakpoint-collect
                      (f90-ts--find-breakpoint-sparse-tree
                       root indent end fill-col-select
                       #'f90-ts--find-breakpoint-prefer-p)))
         (positions (or pos-prefer
                        (f90-ts--find-breakpoint-collect
                         (f90-ts--find-breakpoint-sparse-tree
                          root indent end fill-col-select)))))

    (if (eq f90-ts-fill-select-breakpoint-by 'interactive)
        ;; when we have pos-prefer but suggested breakpoint is not in positions, then add it
        (let ((marker-pos (f90-ts--find-breakpoint-initial-pos pos-prefer fill-col)))
          (if (and marker-pos (not (member marker-pos positions)))
              (cl-sort (cons marker-pos positions) #'<)
            positions))
        positions)))


(defun f90-ts--find-breakpoint (fill-col allow-continue)
  "Find a break point on the current line.
A break point is any end position of a leaf node on the current line and at
column at most FILL-COL minus 2.  Returns the buffer position to break at,
or nil if no suitable break point exists.

The selection strategy is controlled by `f90-ts-fill-select-breakpoint-by'.

For interactive selection, the rightmost marker in
`f90-ts--breakpoint-seed-markers' that falls among the eligible positions is
used as the initial suggestion.
Interactive mode allows to select and break after FILL-COL.
ALLOW-CONTINUE is passed to `f90-ts--find-breakpoint-interactive' to
control whether SPC is offered to extend the fill region."
  (when (or (> (f90-ts--column-number-at-pos (line-end-position)) fill-col)
            (eq f90-ts-fill-select-breakpoint-by 'interactive))
    (let* ((fill-col-select (if (eq f90-ts-fill-select-breakpoint-by 'interactive)
                                most-positive-fixnum
                              fill-col))
           (positions (f90-ts--find-breakpoints-all fill-col fill-col-select)))
      (when positions
        (pcase f90-ts-fill-select-breakpoint-by
          ('rightmost
           (apply #'max positions))
          ('interactive
           (f90-ts--find-breakpoint-interactive positions
                                                fill-col
                                                allow-continue)))))))


(defun f90-ts--break-line-wrap (fill-col allow-continue)
  "Break the current line once if it exceeds FILL-COL.
Find a breakpoint via `f90-ts--find-breakpoint' according to
`f90-ts-find-breakpoint-select' and call `f90-ts-break-line' with position.
Returns non-nil if a break was performed, nil if the line already fits
or no breakpoint can be found.  The function assumes that the line has
no trailing blanks.

ALLOW-CONTINUE controls whether SPC is offered in interactive mode to
extend the fill region; when selected, returns the symbol `continue'.

Join markers in `f90-ts--breakpoint-seed-markers', which are before the
break point, are discarded; those beyond it are kept as candidates for
subsequent interactive break point selection."
  (cl-assert (= (line-end-position)
                (f90-ts--pos-last-nonspace (point)))
             nil "line has trailing blanks at buffer position %s" (point))
  (let ((pos (f90-ts--find-breakpoint fill-col allow-continue)))
    (cond
     ((null pos)          'skip)  ; no break point found or selected
     ((eq pos 'join-prev) 'join-prev)
     ((eq pos 'join-next) 'join-next)
     ((eq pos 'abort)     'abort) ; abort the fill operation
     ((eq pos 'continue)  'continue)
     ((or (= pos (line-end-position))
          (save-excursion
            (goto-char pos)
            (skip-chars-forward " \t")
            (f90-ts--node-type-p (f90-ts--node-on-pos (point) 'right)
                                 "&")))
      ;; do not break if at end of line or at continuation symbol ampersand
      'skip)
     (t ; position value determined by action 'confirm
      (goto-char pos)
      (f90-ts-break-line)
      ;; discard markers at or before the break point,
      ;; keep only those beyond it (still valid candidates)
      (let ((break-pos (point)))
        (f90-ts--seed-markers-invalidate-pos)
        (f90-ts--seed-markers-cleanup-before break-pos))
      'broken))))


(defun f90-ts--join-line-fill-p (join-col end-marker)
  "Return non-nil if current line should be joined with next line for filling.
It checks that the current line is shorter than JOIN-COL, that next line does
not start after END-MARKER and that neither the current nor next line is empty
or an empty comment.  This is done to preserve any comment structure.

Note: most checks whether lines can be joined are done in
`f90-ts--join-line-action-common', which returns an action symbol for deciding
whether a join operations fits the fill case.  This predicate provides a
pre-check to exclude column related cases and some specific corner-case."
  (not
   (or (>= (- (line-end-position)
              (line-beginning-position))
           join-col)
       (>= (save-excursion (forward-line 1) (point))
           end-marker)
       (f90-ts--next-line-empty-p (point))
       (f90-ts--line-empty-comment-p (point))
       (f90-ts--next-line-empty-comment-p (point)))))


(defun f90-ts--join-line-fill (fill-col end-marker &optional requested)
  "Join current line with the next one, as part of a fill operation.
The join operation is performed as long as current line does not exceed
column FILL-COL and the next line does not start after END-MARKER.

In interactive mode, REQUESTED can be non-nil.  In this case, the fill
pre-check `f90-ts--join-line-fill-p' is bypassed and the full set of join
actions is accepted.
If REQUESTED is `join-prev' then `f90-ts-join-line-prev' is invoked.
If REQUESTED is `join-next' then `f90-ts-join-line-next' is invoked.

The function adds the position of the join in `f90-ts--breakpoint-seed-markers'
after each successful join."
  (cl-assert (memq requested '(nil join-prev join-next))
             nil "invalid join action, requested is %s" requested)
  (when (or requested (f90-ts--join-line-fill-p fill-col end-marker))
    (let* ((prev-p (eq requested 'join-prev))
           (pair (if prev-p
                     (f90-ts--join-line-prev-aux)
                   (f90-ts--join-line-next-aux)))
           (process-fn (car pair))
           (action     (cdr pair))
           (valid-actions (if prev-p
                              f90-ts--join-line-prev-valid-actions
                            f90-ts--join-line-next-valid-actions))
           (accepted-actions (if requested
                                 f90-ts--join-line-fill-interactive-actions
                               f90-ts--join-line-fill-auto-actions)))
      (cl-assert (member action valid-actions)
                 nil "invalid join action, got %s" action)
      (when (member action accepted-actions)
        (funcall process-fn)
        (f90-ts--seed-markers-push)
        ;; signal that a join took place
        t))))


(defun f90-ts--fill-region-update-end-overlay (ov end-marker)
  "Update OV to show the END-MARKER with an indicator.
END-MARKER is assumed to be at beginning of line position.
The overlay is placed on the end of the previous line, which is the
last line to be filled."
  (save-excursion
    (goto-char (marker-position end-marker))
    (if (eobp)
        (move-overlay ov (1- (point)) (point))
      (let ((pos (1- (point))))         ; newline character of preceding line
        (move-overlay ov (1- pos) pos)))
    ;; 25C4 is a left pointing filled triangle
    (overlay-put ov 'after-string (propertize " \u25C4" 'face 'warning))))


(defun f90-ts--fill-region-continue (end-marker end-overlay)
  "Advance END-MARKER past empty and empty-comment lines.
Called after a \\='continue action to position END-MARKER at the
first line where a break candidate can exist and interactive session
can resume.
The function updates END-OVERLAY to match the new end marker position."
  ;; assertion also works if at final line at eob with and without
  ;; trailing newline
  (cl-assert (= (marker-position end-marker) (line-beginning-position 2))
             nil "end-marker not at start of next line: marker=%s lbp2=%s"
             (marker-position end-marker) (line-beginning-position 2))
  (unless (= (marker-position end-marker) (point-max))
    (save-excursion
      (goto-char (line-beginning-position 2))
      (while (and (not (eobp))
                  (f90-ts--line-empty-p (point)))
        (forward-line 1))
      ;; either at end of buffer or at first non-empty-like line,
      ;; place marker at start of next line
      (forward-line 1)
      (set-marker end-marker (point)))
    (when end-overlay
      (f90-ts--fill-region-update-end-overlay end-overlay end-marker))))


(defun f90-ts--fill-region-join-step (broke end-marker fill-col)
  "Attempt to join the current line with its continuation.
BROKE is the result of the previous break step; when it is the symbol
`join', the user has requested a standard join with next line and fill
heuristics are bypassed.  END-MARKER is the region end marker and is moved
to the start of the next line if it falls inside the newly joined line, so that
the main loop's while condition does not abort prematurely.  FILL-COL is the
target fill column passed to `f90-ts--join-line-fill'.
Returns non-nil if a join was performed or signalled."
  (unless (f90-ts--point-on-empty-line-p)
    (let ((joined (f90-ts--join-line-fill fill-col end-marker
                                          (and (memq broke '(join-prev join-next))
                                               broke))))
      (when joined
        ;; if end-marker landed inside the newly joined line, move it to
        ;; the start of the next line so the while condition steps past cleanly
        (when (< (marker-position end-marker) (line-end-position))
          (set-marker end-marker (line-beginning-position 2))))
      ;; pass on the signal that a join took place (even if
      ;; f90-ts-join-line-next has not joined, but this skips any subsequent
      ;; actions in the main loop like the break step to be performed)
      joined)))


(defun f90-ts--fill-region-break-step (joined fill-col end-marker)
  "Attempt to break the current line if it exceeds the fill column FILL-COL.
JOINED is the result of the join step; if it is non-nil, or the current
line is empty, no break is attempted.  END-MARKER is used to determine
whether the `continue' action should be offered: it is only available
when END-MARKER is exactly at the start of the next line, avoiding
accidental region extension when the boundary is not visible.
Returns the result of `f90-ts--break-line-wrap', or nil if skipped."
  (unless (or joined (f90-ts--point-on-empty-line-p))
    (end-of-line)
    (delete-horizontal-space)
    (let ((allow-continue (= (marker-position end-marker)
                             (line-beginning-position 2))))
      (f90-ts--break-line-wrap fill-col allow-continue))))


(defun f90-ts--fill-region-advance ()
  "Advance past the current line and reset the join-marker list.
Called when neither a join nor a break was performed on the current line,
indicating it needed no modification and the loop should move on.
Clears `f90-ts--breakpoint-seed-markers' and moves point to the next line."
  (f90-ts--breakpoint-seed-markers-reset)
  (forward-line 1))


(defun f90-ts--fill-region-aux (beg end fill-col)
  "Fill every line in region BEG..END up to column FILL-COL.
Break overlong lines exceeding FILL-COL and join continued lines or
comments where possible.

For line-based fill operations, an initial break point marker for
interactive mode can be injected via `f90-ts--breakpoint-seed-markers'."
  ;; extend beg/end to canonical line-beginning positions
  (save-excursion
    (goto-char beg)
    (unless (bolp) (setq beg (line-beginning-position))))
  (save-excursion
    (goto-char end)
    (unless (bolp) (setq end (line-beginning-position 2))))

  (when (eq f90-ts-fill-select-breakpoint-by 'interactive)
    (deactivate-mark))

  (save-excursion
    (f90-ts--with-check-modified-region beg end
      (let (end-marker end-overlay)
        (unwind-protect
            (progn
              (setq end-marker (copy-marker end t))
              (when (eq f90-ts-fill-select-breakpoint-by 'interactive)
                (setq end-overlay (make-overlay 1 1))
                (f90-ts--fill-region-update-end-overlay end-overlay end-marker))

              (cl-loop
               ;; note: broke is initialised with nil, it is first accessed
               ;; in the next line, before first evaluated afterwards
               initially (goto-char beg)

               ;; at most one action per loop step: join, break or advance
               for joined = (f90-ts--fill-region-join-step broke end-marker fill-col)
               do (when end-overlay
                    (f90-ts--fill-region-update-end-overlay end-overlay end-marker))

               for broke = (f90-ts--fill-region-break-step joined fill-col end-marker)
               do (when (eq broke 'continue)
                    (f90-ts--fill-region-continue end-marker end-overlay))

               until (eq broke 'abort)
               unless (or joined (memq broke '(broken join-prev join-next)))
               do (f90-ts--fill-region-advance)
               while (or (< (point) end-marker)
                         (memq broke '(join-prev join-next)))))
          ;; clean up overlay and markers
          ;; (end-marker and prior breakpoint markers for join)
          (when end-overlay (delete-overlay end-overlay))
          (f90-ts--breakpoint-seed-markers-reset)
          (set-marker end-marker nil))))))


(defun f90-ts-fill-region ()
  "Fill active region or whole buffer up to `fill-column'."
  (interactive)
  (f90-ts--fill-region-aux
   (if (use-region-p) (region-beginning) (point-min))
   (if (use-region-p) (region-end)       (point-max))
   fill-column))


(defun f90-ts-fill-at-line ()
  "Break and join current line at point according to fill operations.
Joining is done in interactive mode and allows to combine current with
subsequent lines in multiline statements or comment blocks.
In interactive mode, the current point is used as the initial break point
suggestion."
  (interactive)
  (unwind-protect
      (progn
        (when (eq f90-ts-fill-select-breakpoint-by 'interactive)
          (f90-ts--seed-markers-set-pos (point)))
        (f90-ts--fill-region-aux (line-beginning-position)
                                 (line-end-position)
                                 fill-column))
    (f90-ts--breakpoint-seed-markers-reset)))


(defun f90-ts-fill-prev-line ()
  "Fill the current line and the previous line."
  (interactive)
  (let ((beg (save-excursion
               (forward-line -1)
               (line-beginning-position)))
        (end (line-end-position)))
    (f90-ts--fill-region-aux beg end fill-column)))


(defun f90-ts-fill-next-line ()
  "Fill the current line and the next line."
  (interactive)
  (let ((beg (line-beginning-position))
        (end (save-excursion
               (forward-line 1)
               (line-end-position))))
    (f90-ts--fill-region-aux beg end fill-column)))


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

(defun f90-ts--mark-region-reversed-p (region-order)
  "Return non-nil if region should be marked with point at start.
REGION-ORDER is as provided by `f90-ts-mark-region-order'."
  (pcase region-order
    ('start    t)
    ('end      nil)
    ('preserve (and (use-region-p) (> (mark) (point))))
    (_         nil)))


(defun f90-ts--mark-region (beg end &optional region-order)
  "Mark region BEG..END.
REGION-ORDER controls where point is placed after marking,
see `f90-ts-mark-region-order'."
  (let ((order (f90-ts--mark-region-reversed-p region-order)))
    (push-mark beg t t)
    (goto-char end)
    (when order
      (exchange-point-and-mark))))


(defun f90-ts--mark-region-node (node &optional region-order)
  "Mark the region spanned by NODE, trimmed of leading and trailing whitespace.
If REGION-ORDER is non-nil, then put point at start of region, otherwise point
is at end of region."
  (let ((beg (f90-ts--node-start-trimmed node))
        (end (f90-ts--node-end-trimmed   node)))
    (f90-ts--mark-region beg end region-order)))


(defun f90-ts--mark-region-node-or-extent (node-or-extent &optional region-order)
  "Mark region given by NODE-OR-EXTENT, trimmed of leading and trailing whitespace.
It is either a single NODE or a pair (FIRST . LAST).
If it is a pair, mark the whole region from start of FIRST to end of LAST.

If REGION-ORDER is non-nil, then put point at start of region, otherwise point
is at end of region."
  (if (consp node-or-extent)
      (f90-ts--mark-region (f90-ts--node-start-trimmed (car node-or-extent))
                           (f90-ts--node-end-trimmed   (cdr node-or-extent))
                           region-order)
    (f90-ts--mark-region-node node-or-extent region-order)))


(defun f90-ts--smallest-named-node-containing-region (beg end trim)
  "Return the smallest named node fully containing region from BEG to END.
The node must be strictly larger than the region (BEG END).
If TRIM is non-nil, then use trimmed span of named nodes for comparison
with BEG..END region."
  (when-let* ((node (treesit-node-on beg end))
              (cover (treesit-parent-until
                      node
                      (lambda (n)
                        (let ((nb (if trim
                                      (f90-ts--node-start-trimmed n)
                                    (treesit-node-start n)))
                              (ne (if trim
                                      (f90-ts--node-end-trimmed n)
                                    (treesit-node-end n))))
                          (and (treesit-node-check n 'named)
                               (<= nb beg)
                               (>= ne end)
                               (< (- end beg)
                                  (- ne nb)))))
                      t)))
    (f90-ts--largest-node-same-span cover)))


(defun f90-ts--nodes-same-group-p (node1 node2)
  "Return non-nil if NODE1 and NODE2 belong to the same navigation group.

Currently this predicate groups comment nodes sharing the same comment prefix."
  ;; even if not belonging to any kind of group, a node is at least grouped with itself,
  ;; this avoids any additional branches in other functions
  (or (treesit-node-eq node1 node2)
      (and (f90-ts--node-type-p node1 "comment")
           (f90-ts--node-type-p node2 "comment")
           (string= (f90-ts--comment-prefix node1 'trimmed)
                    (f90-ts--comment-prefix node2 'trimmed)))))


(defun f90-ts--group-block-extent (node)
  "Return (FIRST . LAST) nodes for the group containing NODE."
  (let* ((first (cl-loop
                 for cur = node then next
                 for next = (treesit-node-prev-sibling cur)
                 while (and next (f90-ts--nodes-same-group-p next node))
                 finally return cur))
         (last  (cl-loop
                 for cur = node then next
                 for next = (treesit-node-next-sibling cur)
                 while (and next (f90-ts--nodes-same-group-p next node))
                 finally return cur)))
    (cons first last)))


(defun f90-ts--node-aligned-at-beg (beg end named)
  "Return the largest node starting exactly at BEG and ending before END.
If NAMED is non-nil, consider only named nodes."
  (when-let* ((node (f90-ts--node-on-pos beg 'right named)))
    (treesit-parent-while
     node
     (lambda (n)
       (and (=  beg (f90-ts--node-start-trimmed n))
            (<= (f90-ts--node-end-trimmed n) end))))))


(defun f90-ts--node-aligned-at-end (beg end named)
  "Return the largest node ending exactly at END and starting after BEG.
If NAMED is non-nil, consider only named nodes."
  (when-let* ((node (f90-ts--node-on-pos end 'left named)))
    (treesit-parent-while
     node
     (lambda (n)
       (and (<= beg (f90-ts--node-start-trimmed n))
            (= (f90-ts--node-end-trimmed n) end))))))


(defun f90-ts--group-block-p (node-beg node-end)
  "Check whether NODE-BEG and NODE-END are within a node group.
This is the case if both are siblings (have the same parent),
belong to the same group, and all siblings in between the two
nodes also belong to the same group."
  (and node-beg
       node-end
       (treesit-node-eq (treesit-node-parent node-beg)
                        (treesit-node-parent node-end))
       (f90-ts--nodes-same-group-p node-beg node-end)
       (cl-loop for cur = node-beg then (treesit-node-next-sibling cur t)
                while (and cur (not (treesit-node-eq cur node-end)))
                always (f90-ts--nodes-same-group-p cur node-beg))))


(defun f90-ts--group-block-region-classify (beg end node-beg node-end)
  "Classify BEG..END within a confirmed group from NODE-BEG to NODE-END."
  (let* ((extent (f90-ts--group-block-extent node-beg))
         (node-first (car extent))
         (node-last (cdr extent))
         (first-beg (f90-ts--node-start-trimmed node-first))
         (last-end (f90-ts--node-end-trimmed node-last)))
    (cond
     ((and (treesit-node-eq node-beg node-end)
           (= beg first-beg)
           (= end last-end))
      (list 'single node-beg))
     ((and (= beg first-beg) (= end last-end))
      (list 'block node-first node-last))
     (t
      (list 'partial node-beg node-end)))))


(defun f90-ts--group-block-region (beg end)
  "Classify type of region BEG..END with respect to groups of nodes.

If nodes at BEG and END exists but do not form a group, return them marked
as disparate, as these nodes are still useful for further operations.

Returns a list:
  ('single    NODE)  region is exactly one node
  ('block     FN LN) region is exactly the full group from FN to LN
  ('partial   FN LN) region is within group but neither single nor full
  ('disparate FN LN) not a group, region starts and ends with disparate nodes
  nil                node at beg or end could not be determined"
  (let* ((node-beg (or (f90-ts--node-aligned-at-beg beg end 'named)
                       (f90-ts--node-on-pos beg 'left 'named)))
         (node-end (or (f90-ts--node-aligned-at-end beg end 'named)
                       (f90-ts--node-on-pos end 'right 'named))))
    (cond
     ((f90-ts--group-block-p node-beg node-end)
      (f90-ts--group-block-region-classify beg end node-beg node-end))
     ((and node-beg node-end)
      (list 'disparate node-beg node-end))
     (t
      nil))))


(defun f90-ts--group-block-eq (group1 group2)
  "Determine whether two groups GROUP1 and GROUP2 of nodes are equal.
Note that equality of the two first nodes is equivalent to the
equality of the two last nodes.
If at least one group is nil, return value is nil as well."
  (and group1
       group2
       (treesit-node-eq (car group1) (car group2))))


(defun f90-ts-mark-region-enlarge-active ()
  "Expand active region to next larger node."
  (cl-assert (use-region-p)
             nil
             "active region required")

  (let* ((region (f90-ts--region-trimmed))
         (beg (car region))
         (end (cdr region))
         (group (f90-ts--group-block-region beg end)))
    (cl-destructuring-bind (&optional gkind reg-first _) group
      (if (eq gkind 'partial)
          ;; single comment line: expand to full block
          (let* ((extent (f90-ts--group-block-extent reg-first))
                 (ext-first (car extent))
                 (ext-last  (cdr extent)))
            (if (treesit-node-eq ext-first ext-last)
                ;; block is just one line, fall through to tree-sitter ascent
                (if-let ((node (f90-ts--smallest-named-node-containing-region beg end 'trim)))
                    (f90-ts--mark-region-node node f90-ts-mark-region-order)
                  (message "no tree-sitter node found enlarging current region"))
              (f90-ts--mark-region (f90-ts--node-start-trimmed ext-first)
                                   (f90-ts--node-end-trimmed   ext-last)
                                   f90-ts-mark-region-order)))
        (if-let ((node (f90-ts--smallest-named-node-containing-region beg end 'trim)))
            (f90-ts--mark-region-node node f90-ts-mark-region-order)
          (message "no tree-sitter node found enlarging current region"))))))


(defun f90-ts-mark-region-enlarge-initial ()
  "Mark region of smallest named node at point.
This operation assumes that no region is active."
  (cl-assert (not (use-region-p))
             nil
             "active region already present")

  (let* ((pos (f90-ts--pos-nonspace (point)))
         (node-at (treesit-node-at pos)))
    (if (f90-ts--node-type-p node-at "comment")
        (f90-ts--mark-region-node node-at f90-ts-mark-region-order)
      (if-let* ((node-on (f90-ts--node-on-pos pos 'right 'named))
                (node    (f90-ts--largest-node-same-span node-on)))
          (f90-ts--mark-region-node node f90-ts-mark-region-order)
        (message "no tree-sitter node found at point")))))


(defun f90-ts-mark-region-enlarge ()
  "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.
If current node is a comment belonging to a block of comments all
starting with the same comment prefix enlarge to the block of comments.
The comment prefix is matched by `f90-ts-openmp-prefix-regexp' and
`f90-ts-comment-prefix-regexp'."
  (interactive)
  (if (use-region-p)
      (f90-ts-mark-region-enlarge-active)
    (f90-ts-mark-region-enlarge-initial)))


(defun f90-ts--mark-region-shrink-child (comment-selector child-index child-name)
  "Core routine for shrinking region to a child node.
Find smallest node covering region.  Then reduce region to its child determined
by CHILD-INDEX.  If there are further grand-children with the same span, return
the smallest grandchild in the tree.
COMMENT-SELECTOR is `car' or `cdr', selecting from a cons of (first . last)
comment nodes.  CHILD-INDEX is passed to `treesit-node-child' (0 for first
and -1 for last).  CHILD-NAME is a name like \"first\" or \"last\"
which is used for an error message if the child is not found."
  (if (use-region-p)
      (let* ((region (f90-ts--region-trimmed))
             (beg    (car region))
             (end    (cdr region))
             (group  (f90-ts--group-block-region beg end)))
        (cl-destructuring-bind (&optional gkind first last) group
          (if (eq gkind 'block)
              (f90-ts--mark-region-node (funcall comment-selector (cons first last))
                                        f90-ts-mark-region-order)
            (if-let* ((node-on (treesit-node-on beg end))
                      (node    (f90-ts--smallest-node-same-span node-on))
                      (child   (treesit-node-child node child-index t)))
                (f90-ts--mark-region-node child f90-ts-mark-region-order)
              (message "no tree-sitter %S child found for current region" child-name)))))
    (message "no active region")))


(defun f90-ts-mark-region-shrink-child-first ()
  "Core routine for shrinking region to a child node.
Find smallest node covering region.  Then reduce region to its first child.
If there are further grand-children with the same span, return the smallest
grandchild in the tree."
  (interactive)
  (f90-ts--mark-region-shrink-child #'car 0 "no tree-sitter child0 found for current region"))


(defun f90-ts-mark-region-shrink-child-last ()
  "Core routine for shrinking region to a child node.
Find smallest node covering region.  Then reduce region to its last child.
If there are further grand-children with the same span, return the smallest
grandchild in the tree."
  (interactive)
  (f90-ts--mark-region-shrink-child #'cdr -1 "no tree-sitter child9 found for current region"))


(defun f90-ts--group-block-anchor (group direction)
  "Return the anchor node from GROUP classification for DIRECTION.
DIRECTION is `backward' or `forward'.
GROUP is a list as returned by `f90-ts--group-block-region'."
  (cond
   ((member (car group) '(block partial disparate))
    (if (eq direction 'backward)
        (cadr group)
      (caddr group)))
   ((eq (car group) 'single)
    (cadr group))
   (t
    nil)))


(defun f90-ts--relative-or-group (anchor get-relative)
  "Return the relative of ANCHOR via GET-RELATIVE and group handling.
If the relative returned by GET-RELATIVE is in the same group as ANCHOR,
return the relative node itself, and do not extent to their group.
Otherwise return the full group extent of the relative.

Note that each node always forms a \"group\" on its own if it does not
belong to any proper block."
  (when-let* ((relative      (funcall get-relative anchor))
              (group-anchor   (f90-ts--group-block-extent anchor))
              (group-relative (f90-ts--group-block-extent relative)))
    (if (f90-ts--group-block-eq group-anchor group-relative)
        relative
      group-relative)))


(defun f90-ts--mark-region-relative (get-relative direction)
  "Mark relative of node determined by current active region and GET-RELATIVE.
DIRECTION is `backward' or `forward', used to resolve the anchor node when the
region spans a full group block.
For `backward' the first node of the group is used as anchor for GET-RELATIVE.
For `forward' the last node of the group is used as anchor for GET-RELATIVE.

First find smallest node covering currently active region.
If the node spans the current region, then mark its relative determined
by GET-RELATIVE.  GET-RELATIVE may return a node or a cons (FIRST . LAST).
Otherwise mark the region spanned by the node itself (like enlarge-region)."
  (cl-assert (member direction '(backward forward))
             nil "direction is not backward or forward")
  (if (use-region-p)
      (if-let* ((region (f90-ts--region-trimmed))
                (beg (car region))
                (end (cdr region))
                (node-on (treesit-node-on beg end))
                (node (f90-ts--largest-node-same-span node-on))
                (group (f90-ts--group-block-region beg end))
                (anchor (f90-ts--group-block-anchor group direction)))
          (let ((node-mark (or (f90-ts--relative-or-group anchor get-relative)
                               node)))
            (f90-ts--mark-region-node-or-extent node-mark f90-ts-mark-region-order))
        (message "tree-sitter relative not found for current region"))
    (message "no active region")))


(defun f90-ts-mark-region-first-sibling ()
  "Mark first sibling of node determined by current active region.
If the node spans the current region, then mark its first sibling.
Otherwise mark the region spanned by the node itself (like enlarge-region)."
  (interactive)
  (f90-ts--mark-region-relative
   (lambda (node)
     (when-let ((parent (treesit-node-parent node)))
       (treesit-node-child parent 0 t)))
   'backward))


(defun f90-ts-mark-region-prev-sibling ()
  "Mark prev sibling of node determined by current active region.
If the node spans the current region, then mark its prev sibling.
Otherwise mark the region spanned by the node itself (like enlarge-region)."
  (interactive)
  (f90-ts--mark-region-relative
   (lambda (node)
     (treesit-node-prev-sibling node t))
   'backward))


(defun f90-ts-mark-region-next-sibling ()
  "Mark next sibling of node determined by current active 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)
  (f90-ts--mark-region-relative
   (lambda (node)
     (treesit-node-next-sibling node t))
   'forward))


(defun f90-ts-mark-region-last-sibling ()
  "Mark last sibling of node determined by current active region.
If the node spans the current region, then mark its last sibling.
Otherwise mark the region spanned by the node itself (like enlarge-region)."
  (interactive)
  (f90-ts--mark-region-relative
   (lambda (node)
     (when-let ((parent (treesit-node-parent node)))
       (treesit-node-child parent -1 t)))
   'forward))


;;;-----------------------------------------------------------------------------
;;; 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-keymap f90-ts-nav-mode-map
  :doc "Keymap for `f90-ts-nav-mode'."
  "RET" #'f90-ts-nav-buffer-jump
  "SPC" #'f90-ts-nav-buffer-preview
  "n"   #'next-line
  "p"   #'previous-line
  "g"   #'f90-ts-nav-buffer-refresh
  "q"   #'f90-ts-nav-buffer-quit
  "C-g" #'f90-ts-nav-buffer-quit)


;;;-----------------------------------------------------------------------------
;;; 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))


;;;-----------------------------------------------------------------------------
;;; about and documentation for menu

(defun f90-ts--snapshot-version-p ()
  "Return non-nil if this is a snapshot version."
  (string-suffix-p "-snapshot" f90-ts-mode-version))


(defun f90-ts--github-raw-url ()
  "Return the github url for raw content."
  (string-replace "github.com" "raw.githubusercontent.com" f90-ts--github-url))


(defun f90-ts--git-ref ()
  "Return the git reference used for online documentation.
For snapshot version use the main branch (which might be out of sync with
current version), otherwise use the tag derived from version.
The tag is version string prefixed by \"v\"."
  (if (f90-ts--snapshot-version-p)
      "main"
    (concat "v" f90-ts-mode-version)))


(defun f90-ts--strip-markdown-links ()
  "Replace Markdown links [text](url) by plain text.
This is done as neither internal nor external links currently work
in `markdown-view-mode'."
  (goto-char (point-min))
  (while (re-search-forward
          "\\[\\([^]]+\\)\\](\\([^)]*\\))"
          nil t)
    (replace-match "\\1" t nil)))


(defun f90-ts--browse-doc (doc-name)
  "Open the online document DOC-NAME from the github repository.
If `markdown-view-mode' or github variant `gfm-view-mode' from the
package `markdown-mode' are available, then use these."
  (when (f90-ts--snapshot-version-p)
    (message "Opening %s from the current development branch main." doc-name))

  (let ((md-view-mode (cond
                       ((fboundp 'gfm-view-mode)      'gfm-view-mode)
                       ((fboundp 'markdown-view-mode) 'markdown-view-mode))))
    (if md-view-mode
      (let ((url (format "%s/%s/%s"
                         (f90-ts--github-raw-url)
                         (f90-ts--git-ref)
                         doc-name))
            (buffer-name (format "*f90-ts-mode %s*" doc-name)))
        (with-current-buffer (get-buffer-create buffer-name)
          (erase-buffer)
          (url-insert-file-contents url)
          (f90-ts--strip-markdown-links)
          ;; use markdown-mode if available
          (funcall md-view-mode)
          (pop-to-buffer (current-buffer))))
      ;; open browser
      (message "Install markdown-mode to view %s directly in a buffer." doc-name)
      (browse-url
       (format "%s/blob/%s/%s"
               f90-ts--github-url
               (f90-ts--git-ref)
               doc-name)))))


(defun f90-ts--browse-readme ()
  "Open the online document \"README.md\" from the github repository."
  (interactive)
  (f90-ts--browse-doc "README.md"))


(defun f90-ts--browse-manual ()
  "Open the online document \"MANUAL.md\" from the github repository."
  (interactive)
  (f90-ts--browse-doc "MANUAL.md"))


(defun f90-ts-mode-about ()
  "Display information about `f90-ts-mode'."
  (interactive)
  (with-help-window "*About f90-ts-mode*"
    (princ (format "f90-ts-mode %s\n\n" f90-ts-mode-version))
    (princ f90-ts--about-text)
    (princ "\nRepository:\n")
    (princ f90-ts--github-url)

    (insert "\n\nDocumentation")
    (insert
     (if (f90-ts--snapshot-version-p)
         "  (current development branch: main)\n\n"
       (format "  (release %s)\n\n" f90-ts-mode-version)))

    (insert-text-button
     "Open README from github"
     'follow-link t
     'action (lambda (_)
               (f90-ts--browse-doc "README.md")))
    (insert "\n")

    (insert-text-button
     "Open MANUAL from github"
     'follow-link t
     'action (lambda (_)
               (f90-ts--browse-doc "MANUAL.md")))
    (insert "\n")))


;;;-----------------------------------------------------------------------------
;;; 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)])
    ("Mark region"
     ["Enlarge"               f90-ts-mark-region-enlarge            :active t]
     ["Shrink to first child" f90-ts-mark-region-shrink-child-first :active (region-active-p)]
     ["Shrink to last child"  f90-ts-mark-region-shrink-child-last  :active (region-active-p)]
     ["First sibling"         f90-ts-mark-region-first-sibling      :active (region-active-p)]
     ["Previous sibling"      f90-ts-mark-region-prev-sibling       :active (region-active-p)]
     ["Next sibling"          f90-ts-mark-region-next-sibling       :active (region-active-p)]
     ["Last sibling"          f90-ts-mark-region-last-sibling       :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]
    ["About f90-ts-mode" f90-ts-mode-about t]
    ["README (GitHub)"   f90-ts--browse-readme t]
    ["MANUAL (GitHub)"   f90-ts--browse-manual 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.")))

  ;; set font-lock feature list
  (setq-local treesit-font-lock-feature-list
              '((comment preproc error)                          ; level 1
                (builtin keyword string type)                    ; level 2
                (constant number)                                ; level 3
                (function variable operator bracket delimiter))) ; level 4

  ;; set font-lock and indentation rules
  (setq-local treesit-font-lock-settings (f90-ts-font-lock-rules))
  (setq-local treesit-simple-indent-rules (f90-ts-indent-rules))

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

  ;; set Defun stuff
  (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)

  ;; this setup function must be called after setting 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)

  ;;(setq-local treesit--font-lock-verbose t)
  ;;(setq-local treesit--indent-verbose t)

  ;; provide mode name
  (setq-local mode-name "F90-TS"))


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

(provide 'f90-ts-mode)

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