平衡点

module foo

  ! some code
contains
  function bar
    ! some code
  end function bar

  subroutine baz
    ! some code
  end subroutine baz
end module foo

(leaf f90-ts-mode
  :vc (:url "git@github.com:mscfd/emacs-f90-ts-mode.git")
  :mode ("\\.f90\\'" "\\.F90\\'" "\\.f95\\'" "\\.F95\\'" "\\.F\\'")
  :defvar treesit-language-source-alist
  :bind (:f90-ts-mode-map
         ("C-c '" . separedit))
  :preface
;;;###autoload
  (defun my:install-fortran-grammar-with-generate ()
    "install 時に tree-sitter generateを実行してから install"
    (interactive)
    (let* ((lang 'fortran)
           (url "https://github.com/mscfd/tree-sitter-fortran")
           (revision "master")
           (tmp-dir (expand-file-name "tree-sitter-fortran-tmp" temporary-file-directory)))
      (when (file-exists-p tmp-dir)
        (delete-directory tmp-dir t))
      (message "Cloning %s..." url)
      (call-process "git" nil nil nil "clone" "-b" revision "--depth" "1" url tmp-dir)
      (message "Running tree-sitter generate...")
      (let ((default-directory tmp-dir))
        (call-process-shell-command "tree-sitter generate" nil nil nil))
      (let ((treesit-language-source-alist `((,lang ,tmp-dir nil "src"))))
        (treesit-install-language-grammar lang))
      (message "Fortran grammar installed successfully from generated source!")))
;;;###autoload
  (defun my:f90-ts-toggle-mode ()
    "Toggle between `f90-mode' (legacy) and `f90-ts-mode'."
    (interactive)
    (if (eq major-mode 'f90-ts-mode)
        (if (fboundp 'f90-mode)
            (f90-mode)
          (message "Legacy `f90-mode' not available"))
      (f90-ts-mode)))
;; function 関連の色付けルールがまだ熟れていないので, ちょっと修正する
(defvar my:f90-keywords
  '("allocated" "associated" "present" "allocate" "deallocate" "nullify"))
(defvar my:f90-builtins
  '("min" "max" "abs" "mod" "sqrt" "sum"
    "size" "shape" "len" "trim" "adjustl" "adjustr"
    "real" "int" "dble" "cmplx" "count" "any" "all"))
;;;###autoload
(defun my:f90-make-regex (word-list)
  (let ((patterns (mapcar (lambda (word)
                            (mapconcat (lambda (c)
                                         (format "[%c%c]" (upcase c) (downcase c)))
                                       word ""))
                          word-list)))
    (format "^\\(%s\\)$" (mapconcat #'identity patterns "\\|"))))
;;;###autoload
(defun my:fixed-f90-ts-rules-function ()
  "Fixed font-lock rules for functions and subroutines."
  (let ((regex-kw (my:f90-make-regex my:f90-keywords))
        (regex-bi (my:f90-make-regex my:f90-builtins)))
    (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)
       (function_result
        (identifier)                  @default)
       (subroutine_call
        subroutine: (identifier)      @font-lock-function-name-face)
       ;; --- 削除箇所 ---
       ;; (call_expression (identifier) @font-lock-function-name-face)
       ((call_expression (identifier) @font-lock-keyword-face)
        (:match ,regex-kw             @font-lock-keyword-face))
       ((call_expression (identifier) @font-lock-builtin-face)
        (:match ,regex-bi             @font-lock-builtin-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)
       ))))
;;;###autoload
  (defun my:fixed-f90-ts-rules-variable ()
    "Fixed font-lock rules for variables, declarations, and module control."
    (treesit-font-lock-rules
     :language 'fortran
     :feature 'variable
     '(
       ;; 1. 変数宣言 (integer :: nm, real :: x=1.0)
       (variable_declaration (init_declarator left: (identifier) @font-lock-variable-name-face))
       (variable_declaration (identifier) @font-lock-variable-name-face)
       (variable_declaration (sized_declarator (identifier) @font-lock-variable-name-face))
       ;; 2. SAVE
       (save_statement (identifier) @font-lock-variable-name-face)
       ;; 3. モジュール制御 (use, only, private, public)
       (use_statement (module_name) @font-lock-constant-face)
       (included_items (identifier) @font-lock-variable-name-face) ;; use ..., only: DP
       (public_statement (identifier) @font-lock-function-name-face)
       (private_statement (identifier) @font-lock-function-name-face)
       ;; 4. プログラム単位の名前
       (module_statement (name) @font-lock-function-name-face)
       (program_statement (name) @font-lock-function-name-face)
       ;; 5. 元のルール (self)
       ((identifier) @f90-ts-font-lock-special-var-face
        (:pred f90-ts-special-var-p @f90-ts-font-lock-special-var-face))
       )))
  ;;
  (add-to-list 'major-mode-remap-alist '(f90-mode . f90-ts-mode))
  :advice
  ((:override f90-ts--font-lock-rules-function my:fixed-f90-ts-rules-function)
   (:override f90-ts--font-lock-rules-variable my:fixed-f90-ts-rules-variable)
   )
  :custom-face
  (f90-ts-font-lock-intrinsic-face       . '((t :inherit font-lock-builtin-face)))
  (f90-ts-font-lock-delimiter-face       . '((t :inherit font-lock-delimiter-face)))
  (f90-ts-font-lock-operator-face        . '((t :inherit font-lock-operator-face)))
  (f90-ts-font-lock-openmp-face          . '((t :inherit font-lock-preprocessor-face)))
  (f90-ts-font-lock-bracket-face         . '((t :inherit font-lock-bracket-face)))
  (f90-ts-font-lock-special-var-face     . '((t :inherit font-lock-constant-face)))
  (f90-ts-font-lock-special-comment-face . '((t :inherit font-lock-doc-face)))
  :init
  (setq f90-ts-indent-block 2
        f90-ts-indent-contain 2
        f90-ts-indent-continued 2
        f90-ts-indent-toplevel 2
        f90-ts-indent-lists-region 'continued-line
        f90-ts-indent-lists-line   'continued-line
        )
  (setq f90-ts-indent-rules-openmp
        `(
          ((f90-ts--openmp-comment-is) prev-sibling 0)
          ((f90-ts--openmp-comment-is) parent-bol f90-ts-indent-block)))
  ;; :config
  :hook
  (f90-ts-mode-hook
   . (lambda ()
       (setq-local comment-start "!")
       (setq-local comment-start-skip "\\(!>\\|!+\\)[ \t]*")
       (font-lock-add-keywords
        nil
        '(("!>.*\\(\\*\\*\\(.*?\\)\\*\\*\\)" (1 'font-lock-bold-face prepend))
          ("!>.*\\(`\\(.*?\\)`\\)" (1 'font-lock-constant-face prepend))
          ("!>\\([ \t]*-[ \t]+\\)" (1 'font-lock-keyword-face prepend))
          ("!>\\([ \t]*#+ .*\\)$" (1 'font-lock-builtin-face prepend)))
        'append)
       (setq-local treesit-font-lock-level 5)
       (treesit-font-lock-recompute-features)
       (treesit-fold-mode)
       )
   )
  )

(leaf treesit-fold
  :if (executable-find "tree-sitter")
  :ensure t
  :bind (("C-c f" . treesit-fold-toggle)
         ("C-c F" . my:treesit-fold-toggle-all)
         )
  :preface
;;;###autoload
  (defun my:treesit-fold-toggle-all ()
    "Toggle between `treesit-fold-open-all' and `treesit-fold-close-all'."
    (interactive)
    (let ((found-folded nil))
      (save-excursion
        (dolist (ov (overlays-in (point-min) (point-max)))
          (when (eq (overlay-get ov 'invisible) 'treesit-fold)
            (setq found-folded t))))
      (if found-folded
          (progn
            (treesit-fold-open-all)
            (message "All nodes opened"))
        (progn
          (treesit-fold-close-all)
          (message "All nodes closed")))))
;;;###autoload
  (defun my:treesit-fold-toggle-override (&rest _args)
    "Toggle fold at point. If opening, open recursively."
    (interactive)
    (if-let* ((node (treesit-fold--foldable-node-at-pos))
              (ov (treesit-fold-overlay-at node)))
        (treesit-fold-open-recursively)
      (treesit-fold-close)))
  :advice
  (:override treesit-fold-toggle my:treesit-fold-toggle-override)
  :hook ((treesit-fold-mode-hook . treesit-fold-line-comment-mode)
         (emacs-lisp-mode-hook . (lambda () (treesit-parser-create 'elisp)))
         )
  :config
  ;; ---------------------------------------------------------------------------
  ;; Fortran Support Implementation
  ;; ---------------------------------------------------------------------------
  ;; Constants of fold target
  (defconst treesit-fold-fortran-declaration-nodes
    '("use_statement" "implicit_statement" "import_statement" "include_statement"
      "private_statement" "public_statement" "save_statement" "parameter_statement"
      "data_statement" "variable_declaration" "namelist_statement" "common_statement"
      "equivalence_statement" "entry_statement" "format_statement")
    "List of declaration node types in Fortran to be folded as a group.")
  ;; Check Sibling Node
  (defun treesit-fold-range-fortran--sibling (node next)
    "Find the nearest sibling of NODE.
If NEXT is non-nil, search forwards; otherwise, search backwards.
Skips comments, newlines, and end-of-statement markers."
    (let ((iter (if next (treesit-node-next-sibling node)
                  (treesit-node-prev-sibling node))))
      (while (and iter
                  (let ((type (treesit-node-type iter)))
                    (or (string-equal type "comment")
                        (string-equal type "\n")
                        (string-prefix-p "_end_of_" type)
                        (string-match-p "\\`\\s-*\\'" type))))
        (setq iter (if next (treesit-node-next-sibling iter)
                     (treesit-node-prev-sibling iter))))
      iter))
  ;; Range Parsers
  (defun treesit-fold-range-fortran-declarations (node offset)
    "Calculate the fold range for consecutive declaration blocks.
Merges adjacent declaration nodes into a single fold.
Also includes trailing comments (e.g. !$omp or normal comments) in the block."
    (let ((type (treesit-node-type node)))
      (when (member type treesit-fold-fortran-declaration-nodes)
        (let ((prev (treesit-fold-range-fortran--sibling node nil))
              (next (treesit-fold-range-fortran--sibling node t)))
          ;; Only fold from the first node in a sequence of declarations.
          (unless (and prev (member (treesit-node-type prev) treesit-fold-fortran-declaration-nodes))
            ;; 1. Determine the end of the strict declaration block
            (let ((last-node node)
                  (iter-node next))
              (while (and iter-node
                          (member (treesit-node-type iter-node) treesit-fold-fortran-declaration-nodes))
                (setq last-node iter-node)
                (setq iter-node (treesit-fold-range-fortran--sibling iter-node t)))
              ;; 2. Extend sibling range if it's a comment or line break.
              (let ((scan-node (treesit-node-next-sibling last-node)))
                (while (and scan-node
                            (let ((t-type (treesit-node-type scan-node)))
                              (or (string-equal t-type "comment")
                                  (string-equal t-type "\n")
                                  (string-match-p "\\`\\s-*\\'" t-type))))
                  (when (string-equal (treesit-node-type scan-node) "comment")
                    (setq last-node scan-node))
                  (setq scan-node (treesit-node-next-sibling scan-node))))
              ;; 3. Create fold if range is valid
              (when (not (eq node last-node))
                (treesit-fold--cons-add (cons (treesit-node-start node)
                                              (treesit-node-end last-node))
                                        offset))))))))
  ;; Comment block
  (defun treesit-fold-range-fortran-comment (node offset)
    "Calculate the fold range for consecutive comment blocks.
Skips empty lines and non-comment whitespace between comments."
    (when (string-equal (treesit-node-type node) "comment")
      (let ((prev (treesit-node-prev-sibling node))
            (is-continuation nil))
        ;; Check if this node is a continuation of a previous comment block.
        (while (and prev
                    (or (string-equal (treesit-node-type prev) "comment")
                        (string-match-p "\\`\\s-*\\'" (treesit-node-type prev))))
          (when (string-equal (treesit-node-type prev) "comment")
            (setq is-continuation t))
          (setq prev (treesit-node-prev-sibling prev)))
        ;; Only fold if this is the start of the block.
        (unless is-continuation
          (let ((next (treesit-node-next-sibling node))
                (last-comment node))
            ;; Find the end of the comment block.
            (while next
              (let ((type (treesit-node-type next)))
                (cond
                 ((string-equal type "comment")
                  (setq last-comment next)
                  (setq next (treesit-node-next-sibling next)))
                 ((string-match-p "\\`\\s-*\\'" type)
                  (setq next (treesit-node-next-sibling next)))
                 (t
                  (setq next nil)))))
            (when (not (eq last-comment node))
              (treesit-fold--cons-add (cons (treesit-node-start node)
                                            (treesit-node-end last-comment))
                                      offset)))))))
  ;; Normal fold blocks
  (defun treesit-fold-range-fortran-blocks (node offset)
    "Calculate the fold range for generic blocks (e.g., subroutines, loops).
Folds the content between the header (first child) and the footer (last child)."
    (let ((header (treesit-node-child node 0 t))
          (footer (treesit-node-child node -1 t)))
      (when (and header footer (not (eq header footer)))
        (treesit-fold--cons-add (cons (treesit-node-end header)
                                      (treesit-node-start footer))
                                offset))))
  ;; Summary Parser
  (defun treesit-fold-summary-fortran-doc (doc-str)
    "Extract summary from Fortran comments.
Handles Doxygen style (!>) and ignores code blocks or separator lines."
    (when (string-match-p "\\`\\s-*!" doc-str)
      ;; Ensure the content is strictly a comment block (no code lines).
      (unless (string-match-p "\n[ \t]*[^! \t\n]" doc-str)
        (let ((lines (split-string doc-str "\n"))
              (summary nil))
          (dolist (line lines)
            (unless summary
              ;; Remove '!', '!>', or whitespace.
              (let ((content (replace-regexp-in-string "\\`\\s-*!+>?\\s-*" "" line)))
                (cond
                 ((string-empty-p content) nil)
                 ((string-match-p "-[*]-" line) nil) ; Ignore mode lines
                 ((not (string-match-p "[[:alnum:]]" content)) nil) ; Ignore separators
                 (t (setq summary content))))))
          summary))))
  ;; Definition of Rules
  (defun treesit-fold-parsers-fortran ()
    "Return the folding rules for f90-ts-mode."
    `((subroutine                 . treesit-fold-range-fortran-blocks)
      (function                   . treesit-fold-range-fortran-blocks)
      (interface                  . treesit-fold-range-fortran-blocks)
      (derived_type_definition    . treesit-fold-range-fortran-blocks)
      (do_loop                    . treesit-fold-range-fortran-blocks)
      (if_statement               . treesit-fold-range-fortran-blocks)
      (select_case_statement      . treesit-fold-range-fortran-blocks)
      (select_type_statement      . treesit-fold-range-fortran-blocks)
      (block_construct            . treesit-fold-range-fortran-blocks)
      (associate_statement        . treesit-fold-range-fortran-blocks)
      (coarray_critical_statement . treesit-fold-range-fortran-blocks)
      (forall_statement           . treesit-fold-range-fortran-blocks)
      (where_statement            . treesit-fold-range-fortran-blocks)
      (module                     . treesit-fold-range-fortran-blocks)
      (program                    . treesit-fold-range-fortran-blocks)
      (submodule                  . treesit-fold-range-fortran-blocks)
      ,@(mapcar (lambda (type) (cons (intern type) 'treesit-fold-range-fortran-declarations))
                treesit-fold-fortran-declaration-nodes)
      (comment                    . treesit-fold-range-fortran-comment)))
  ;; Register summary parser for f90-ts-mode.
  (add-to-list 'treesit-fold-summary-parsers-alist
               '(f90-ts-mode . treesit-fold-summary-fortran-doc))
  ;; 以下は私の好み.
  ;; module や program が fold されると全部 fold されるので構造がわかりにくい.
  (add-to-list 'treesit-fold-range-alist
               (cons 'f90-ts-mode
                     (seq-remove (lambda (x)
                                   (memq (car x) '(module program submodule)))
                                 (treesit-fold-parsers-fortran))))
  )

(leaf separedit
  :ensure t
  :init
  (setq separedit-default-mode 'markdown-mode
        separedit-remove-trailing-spaces-in-comment t
        separedit-preserve-string-indentation t
        separedit-continue-fill-column t)
  :defer-config
  (push '(("!>" "!") . f90-ts-mode) separedit-comment-delimiter-alist)
  :advice (:around separedit my:speparedit-doxygen-fortran)
  :preface
;;;###autoload
(defun my:speparedit-doxygen-fortran (orig-fun &rest args)
  "Separate Edit for Doxygen Markdown (!>) and normal comment (!)"
  (if (derived-mode-p 'f90-ts-mode)
      (cond
       ;; -------------------------------------------------------------------
       ;; case A: Doxygen Markdown (!>) 
       ;; -------------------------------------------------------------------
       ((save-excursion (beginning-of-line) (looking-at-p "^[ \t]*!>"))
        (let ((beg (save-excursion
                     (beginning-of-line)
                     (while (and (not (bobp))
                                 (save-excursion
                                   (forward-line -1)
                                   (beginning-of-line)
                                   (looking-at-p "^[ \t]*!>")))
                       (forward-line -1))
                     (point)))
              (end (save-excursion
                     (end-of-line)
                     (while (and (not (eobp))
                                 (save-excursion
                                   (forward-line 1)
                                   (beginning-of-line)
                                   (looking-at-p "^[ \t]*!>")))
                       (forward-line 1))
                     (end-of-line)
                     (point))))
          (funcall orig-fun (list :beginning beg
                                  :end end
                                  :lang-mode 'markdown-mode
                                  :comment-delimiter "^[ \t]*!>[ \t]*"))))
       ;; -------------------------------------------------------------------
       ;; case B: nmormal comment(!) but not Doxygen Fortran (!> )
       ;; -------------------------------------------------------------------
       ((save-excursion (beginning-of-line) (looking-at-p "^[ \t]*![^>]"))
        (let ((beg (save-excursion
                     (beginning-of-line)
                     ;; Move up, stop "!>"
                     (while (and (not (bobp))
                                 (save-excursion
                                   (forward-line -1)
                                   (beginning-of-line)
                                   (and (looking-at-p "^[ \t]*!")
                                        (not (looking-at-p "^[ \t]*!>")))))
                       (forward-line -1))
                     (point)))
              (end (save-excursion
                     (end-of-line)
                     ;; Move down, stop "!>"
                     (while (and (not (eobp))
                                 (save-excursion
                                   (forward-line 1)
                                   (beginning-of-line)
                                   (and (looking-at-p "^[ \t]*!")
                                        (not (looking-at-p "^[ \t]*!>")))))
                       (forward-line 1))
                     (end-of-line)
                     (point))))
          (funcall orig-fun (list :beginning beg
                                  :end end
                                  :lang-mode 'markdown-mode
                                  :comment-delimiter "^[ \t]*![ \t]*"))))
       ;; -------------------------------------------------------------------
       ;; default: other case
       ;; -------------------------------------------------------------------
       (t (apply orig-fun args)))
    ;; not f90-ts-mode
    (apply orig-fun args)))
)