;;; dorgygen.el --- Source code documentation in org-mode -*- lexical-binding: t; -*-

;; Copyright (C) 2024 Stefano Ghirlanda

;; Package-Version: 20260904.40
;; Package-Revision: 2548e715405d
;; Package-Requires: ((emacs "29.1"))
;; URL: https://github.com/drghirlanda/dorgygen
;; Keywords: tools, wp

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; Dorgygen pulls documentation from source files into org-mode
;; documents using tree-sitter.  Source code documentation is
;; embedded in comments with no special markup.  The org document
;; can contain additional documentation.
;;
;; Usage: Add a DORG_REX property to an org heading, then M-x dorgygen.
;; New languages can be added with `dorgygen-add-language'.
;; See https://github.com/drghirlanda/dorgygen for full documentation.

;;; Code:

(require 'cl-lib)
(require 'org)
(require 'treesit)

(defgroup dorgygen nil
  "Customizations for dorgygen."
  :group 'programming)

(defcustom dorgygen-attr-list ""
  "String prepended to dorgygen list, like \"#attr_latex: ...\"."
  :type 'string
  :group 'dorgygen)
  
(defun dorgygen--find (type node)
  "Find all descendants of type TYPE in the treesit tree rooted at NODE."
  (let (found found-child)
    (dolist (child (treesit-node-children node))
      (when (equal type (treesit-node-type child))
 	(push child found))
      (setq found-child (dorgygen--find type child))
      (when found-child
	(setq found (append (reverse found-child) found))))
    (reverse found))) ; reverse preserves file order

(defun dorgygen--end-of-section (section-pos)
  "Return where new generated content belongs in the section at SECTION-POS.
This is the end of the section's subtree, so that a newly generated
file heading is appended after whatever the section already holds.
Inserting at point instead would place generated content above any
user prose written under the section heading, and the next run,
which deletes from the first list item to the end of the section,
would then take that prose with it."
  (save-excursion
    (goto-char section-pos)
    (org-end-of-subtree t t)
    (point)))

(defun dorgygen--delete-non-user-content (heading-pos)
  "Delete auto-generated content within the heading at HEADING-POS.
Leaves point where new content should be inserted.  Deletes from
the first list item to the next heading or end of subtree,
preserving any user content between the heading and the list."
  (let* ((eos (save-excursion
		(goto-char heading-pos)
		(org-end-of-subtree)))
	 ;; outline-next-heading, not org-next-visible-heading: the latter
	 ;; skips folded headings, so in a buffer folded by #+startup: or by
	 ;; the user the bound jumps past the whole section and the deletion
	 ;; below takes everything in between with it
	 (nvh (save-excursion
		(goto-char heading-pos)
		(if (outline-next-heading) (point) (point-max))))
	 (bnd (min eos nvh)))
    (goto-char heading-pos)
    (forward-line)
    (if (>= (point) bnd)
	;; Empty subtree: nothing to delete, ensure a blank line for the caller.
	(progn (goto-char bnd) (insert "\n"))
      (let ((lst (save-excursion
		   (when (re-search-forward "^- " bnd t)
		     (line-beginning-position)))))
	(if lst
	    (progn
	      (goto-char lst)
	      (delete-region lst bnd)
	      (insert "\n"))
	  (goto-char bnd)
	  (insert "\n"))))))

(defvar dorgygen--language-alist nil
  "Alist mapping languages to their dorgygen configuration.
Each entry is (LANGUAGE . PLIST) where PLIST has keys:
  :extensions  - list of file extensions (e.g., (\"h\" \"c\"))
  :comments    - list of regexps to strip from comment text
  :file-level  - alist of (TREESIT-TYPE . HANDLER-FN) for list items
  :subheading  - alist of (TREESIT-TYPE . HANDLER-FN) for subheadings")

(defun dorgygen-add-language (language &rest props)
  "Register LANGUAGE for dorgygen.
PROPS is a plist with keys :extensions, :comments, :file-level, :subheading.
See `dorgygen--language-alist' for details."
  (setf (alist-get language dorgygen--language-alist) props))

(defun dorgygen-use-languages (&rest languages)
  "Load dorgygen support for LANGUAGES.
Each element is a symbol such as \\='c, \\='cpp, or \\='python.
This is the recommended way to enable language support."
  (dolist (lang languages)
    (require (intern (concat "dorgygen-" (symbol-name lang))))))

(defun dorgygen--cleanup-comment (node)
  "Get comment text from NODE, removing comment markers.

This function removes all start and end comment markers.  For
example, if a string starts with two comment markers, they will
both be deleted."
  (when-let* ((comm (treesit-node-text node t))
	      (lang (treesit-node-language node))
	      (dels (plist-get (cdr (assoc lang dorgygen--language-alist))
			       :comments)))
    (save-match-data
      (dolist (d dels)
	(when (string-match d comm)
	  (setq comm (replace-match "" t t comm)))))
    (setq comm (string-trim-right comm))
    (unless (string-empty-p (string-trim comm)) comm)))

(defun dorgygen--comment-about (this &rest after)
  "Find a comment about THIS (a treesit node).
If AFTER is nil, look before THIS, if non-nil, look after THIS."
  (let ((sibl (if after
		  (treesit-node-next-sibling this t)
		(treesit-node-prev-sibling this t))))
    (when (and sibl (equal "comment" (treesit-node-type sibl)))
      (let ((comm (dorgygen--cleanup-comment sibl))
	    (more (if after
		     (dorgygen--comment-about sibl t)
		   (dorgygen--comment-about sibl))))
	(if (null comm)
	    more  ; blank comment: skip it, return what's beyond
	  (let ((comm (concat (upcase (substring comm 0 1))
			      (substring comm 1))))
	    (if more
		(if after
		    (concat comm "\n" more)
		  (concat more "\n" comm))
	      comm)))))))

(defun dorgygen--format-comment (text)
  "Format multi-line comment TEXT for an org-mode list item.
Lines with leading whitespace become sub-list items (prefixed with
\"  - \").  Other continuation lines are indented by two spaces to
stay inside the parent list item."
  (let* ((lines (split-string text "\n"))
	 (lines (seq-filter
		 (lambda (l) (not (string-empty-p (string-trim l)))) lines))
	 (first t))
    (mapconcat
     (lambda (l)
       (if first
	   (prog1 (string-trim l) (setq first nil))
	 (if (string-match-p "^ " l)
	     (concat "  - " (string-trim l))
	   (concat "  " (string-trim l)))))
     lines "\n")))

(defun dorgygen--not-comment (node)
  "Return t if NODE is a comment, nil otherwise."
  (not (equal "comment" (treesit-node-type node))))

(defun dorgygen--normalize-newlines ()
  "Replace 3+ consecutive newlines with two, from point to end of buffer.
Also remove trailing whitespace from lines."
  (while (re-search-forward "[ \t]+$" nil t)
    (replace-match ""))
  (goto-char (point-min))
  (while (re-search-forward "\n\\{3,\\}" nil t)
    (replace-match "\n\n")))


(defun dorgygen--language (file)
  "Return programming language of FILE, or nil."
  (let ((lan (org-entry-get (point) "DORG_LAN"))
	(ext (file-name-extension file)))
    (if lan
	(intern lan)
      (cl-loop for (lang . props) in dorgygen--language-alist
	       when (member ext (plist-get props :extensions))
	       return lang))))

(defun dorgygen--heading (name)
  "Remove leading ./ from NAME and surround with ~."
  (concat "~" (string-remove-prefix "./" name) "~"))

(defun dorgygen ()
  "Pull documentation from source code files into an `org-mode' document."
  (interactive)
  (if (not (eq major-mode 'org-mode))
      (message "Not an org-mode buffer")
    (save-excursion
      (let ((dcs '())  ; file-level docs added to buffer
	    buf  ; file buffer
	    par  ; file parser
	    rtn  ; parser's root node
	    lan  ; file language
	    rex  ; regexp of source files to document
	    dir  ; source directory
	    kll  ; kill buffer only if we opened it
	    hdn  ; org heading for current documentation entry
	    sec  ; position of the heading carrying DORG_REX
	    lvl) ; org level of file documentation headings
	;; find DORG_REX ascending the heading hierarcy, or abort
	(while (and
		(not (setq rex (org-entry-get (point) "DORG_REX")))
		(org-current-level))
	  (org-up-heading-safe))
	(unless rex
	  (error "dorgygen: Heading has no DORG_REX property"))
	(setq lvl (make-string (1+ (org-current-level)) ?*))
	(setq dir (or (file-name-directory rex) "./")
	      rex (file-name-nondirectory rex))
	;; remember where the section starts: new file headings are appended
	;; at its end, after any user prose, rather than inserted at point
	(setq sec (save-excursion (org-back-to-heading t) (point)))
	;; move past heading and properties drawer
	(org-end-of-meta-data t)
	;; loop through source files
	(dolist (fil (directory-files-recursively dir rex))
	  (unless (setq lan (dorgygen--language fil))
	    (error "dorgygen: Language %s unknown" lan))
	  (unless (treesit-language-available-p lan)
	    (error "dorgygen: Language %s not available in tree-sitter" lan))
	  ;; if fil has no buffer, kill it when we're done with it
	  (setq kll (not (get-file-buffer fil)))
	  (setq buf (find-file-noselect fil))
	  ;; ensure tree-sitter parser in buf via language mode
	  (with-current-buffer buf
	    (let* ((cfg (cdr (assoc lan dorgygen--language-alist)))
		   (mode-fn (or (plist-get cfg :mode)
				(intern (concat (symbol-name lan) "-ts-mode")))))
	      (funcall mode-fn)))
	  (unless (treesit-parser-list buf)
	    (error "dorgygen: Cannot create parser for %s" fil))
	  (setq par (car (treesit-parser-list buf))
		rtn (treesit-parser-root-node par)
		hdn (dorgygen--heading fil))
	  ;; if file has no docs insert heading, else go to heading
	  (let ((exs (org-find-exact-headline-in-buffer hdn)))
	    (if (not exs)
		(progn
		  (goto-char (dorgygen--end-of-section sec))
		  (insert lvl " " hdn "\n\n"))
	      (dorgygen--delete-non-user-content exs)))
	  ;; add heading to list of docs in file
	  (push hdn dcs)
	  ;; insert file-level docs (list items under file heading)
	  (let ((cfg (cdr (assoc lan dorgygen--language-alist))))
	    (when-let ((fl-entries (plist-get cfg :file-level)))
	      (let (has-items)
		(dolist (entry fl-entries)
		  (when-let ((nodes (dorgygen--find (car entry) rtn)))
		    (unless has-items
		      (unless (string-empty-p dorgygen-attr-list)
			(insert dorgygen-attr-list "\n"))
		      (setq has-items t))
		    (dolist (node nodes)
		      (funcall (cdr entry) node))))
		(when has-items (insert "\n"))))
	    ;; insert subheading docs
	    (dolist (entry (plist-get cfg :subheading))
	      (dolist (node (dorgygen--find (car entry) rtn))
		(let ((result (funcall (cdr entry) node (concat lvl "*"))))
		  ;; nil satisfies listp; (append nil dcs) is a no-op
		  (cond
		   ((stringp result) (push result dcs))
		   ((listp result) (setq dcs (append result dcs))))))))  ; add to found docs
	  ;; cleanup
	  (when kll (kill-buffer buf)) ; kill buf iff we created it
          ;; mark headings still in dcs as not found
	  (goto-char (org-find-exact-headline-in-buffer hdn))
	  (org-map-entries (lambda () (dorgygen--update-notfound dcs)) t 'tree))
	;; get rid of excessive newlines across all generated docs
	(goto-char (point-min))
	(dorgygen--normalize-newlines)))))

(defun dorgygen--update-notfound (docs)
  "Update the notfound header tags for the current header.
DOCS is a list of current documentation headers."
  (let* ((tags1  (delete "notfound" (org-get-tags)))
	 (found (member (org-get-heading t t t t) docs))
	 (tags2 (if found tags1 (append '("notfound") tags1))))
    (org-set-tags tags2)))
      
(provide 'dorgygen)

;;; dorgygen.el ends here
