hprpl-mode.el

;; hprpl-mode.el --- UserRPL mode for HP calculator programming
;; Copyright (C) 2025, 2026 GNU GPL v3  www.gnu.org/licenses/gpl-3.0.html

;; Author: David Cobac <david.cobac@gmail.com>
;; Assisted-by: Claude:claude-sonnet-4.6
;; Version: 0.1
;; Keywords: HP calculators, RPL, RPN
;; URL: https://github.com/cobacdavid/

;;; Commentary:

;; Long time project to code RPL using emacs
;; First code with help of Xah Lee's 'Emacs Lisp Write Python Mode' video:
;; https://www.youtube.com/watch?v=ANQNLuKodHA&t=71s
;; Since late 2025: use of Claude

;;; TODO

;; English translation
;; Complete RPL words
;; Enable different printer, and maybe official ones

;;; Contents
;; limit line for unicode version
;; indentation
;; comments
;; ascii <-> unicode
;; coloration
;; modules
;; shortcuts
;; major mode

(require 'cl-lib)
;; words
(require 'hprpl-words)
;; ql-700
(require 'hprpl-ql700)
;; x48 and x50ng
(require 'hprpl-x48)
;; snippets
(require 'hprpl-yasnippets)
;; limit line for unicode version
;;

;; Computes the ASCII column corresponding to unicode column TARGET in LINE.
;; In ASCII mode, trigraphs (e.g. \<< = 3 chars) count as 1 printed char.
(defun hprpl--ascii-col-for-unicode-col (line target)
  (let ((apos 0)
        (ucol 0)
        (len  (length line))
        ;; On ignore la première entrée (\\ → \\, identité) du tableau
        (trigraphs (mapcar #'cdr (cdr hprpl-unicode-to-tio))))
    (while (and (< apos len) (< ucol target))
      (let ((matched nil))
        (dolist (tri trigraphs)
          (unless matched
            (let ((tlen (length tri)))
              (when (and (<= (+ apos tlen) len)
                         (string= (substring line apos (+ apos tlen)) tri))
                (setq apos (+ apos tlen) ucol (1+ ucol) matched t)))))
        (unless matched
          (setq apos (1+ apos) ucol (1+ ucol)))))
    apos))

(defun hprpl-completion-at-point ()
  (let ((bounds (bounds-of-thing-at-point 'word)))
    (when bounds
      (list (car bounds)
            (cdr bounds)
            (append hprpl-words
                    hprpl-mathwords
                    hprpl-stackwords
                    hprpl-convwords
                    hprpl-hp50-words
                    hprpl-hp50-mathwords
                    hprpl-hp50-stackwords
                    hprpl-hp50-convwords
                    hprpl-module-words)))))

;;
;; indentation management with stacks
;;
(defun hprpl-indent-line ()
  (interactive)
  (let ((step 2)
        (cur-line-start (save-excursion (beginning-of-line) (point)))
        ;; prog-stack: indentation of the line containing each unclosed \<<
        (prog-stack nil)
        ;; loop-stack: indentation of the line containing each
        ;; unclosed opening keyword
        (loop-stack nil))
    ;; Phase 1: scan from the beginning of the buffer up to the start of
    ;; the current line in order to rebuild the stack state.
    (save-excursion
      (goto-char (point-min))
      (while (< (point) cur-line-start)
        (cond
         ;; --- programs: \<< opens, \>> closes ---
         ((looking-at "\\\\<<")
          (push (current-indentation) prog-stack)
          (forward-char 3))
         ((looking-at "\\\\>>")
          (when prog-stack (pop prog-stack))
          (forward-char 3))
         ;; --- structure-opening keywords ---
         ((looking-at (regexp-opt '("IF" "IFERR" "FOR" "START" "WHILE" "DO") 'words))
          (push (current-indentation) loop-stack)
          (forward-word))
         ;; --- closing keywords: pop the stack ---
         ((looking-at (regexp-opt '("NEXT" "END" "STEP") 'words))
          (when loop-stack (pop loop-stack))
          (forward-word))
         ;; --- mid-block keywords: pop then push the current indentation ---
         ((looking-at (regexp-opt '("THEN" "REPEAT" "ELSE" "UNTIL") 'words))
          (when loop-stack (pop loop-stack))
          (push (current-indentation) loop-stack)
          (forward-word))
         (t (forward-char 1)))))
    ;; Phase 2: compute the indentation to apply to the current line.
    (let ((cur-indent
           (save-excursion
             (beginning-of-line)
             (skip-chars-forward " \t")
             (cond
              ;; closing \>>: aligns with the start of the line of the matching \<<
              ((looking-at "\\\\>>")
               (or (car prog-stack) 0))
              ;; closing keyword aligns with the opening line
              ((looking-at (regexp-opt '("NEXT" "END" "STEP") 'words))
               (or (car loop-stack) 0))
              ;; mid-block: also aligns with its opening keyword
              ((looking-at (regexp-opt '("UNTIL" "THEN" "REPEAT" "ELSE") 'words))
               (or (car loop-stack) 0))
              ;; ordinary content: deepest opening (across all stacks)
              ;; + step; toplevel if no block is open
              (t
               (if (or prog-stack loop-stack)
                   (+ (max (or (car prog-stack) 0)
                           (or (car loop-stack) 0))
                      step)
                 0))))))
      (indent-line-to cur-indent))))

;;
;; insertion of stack-state comments at each line
;;
;; already-commented lines are skipped
;; they are also not taken into account when computing the position
(defun hprpl-add-stack-comments ()
  (interactive)
  (let* ((max-col (save-excursion
                    (goto-char (point-min))
                    (let ((m 0))
                      (while (not (eobp))
                        (beginning-of-line)
                        (unless (looking-at "\\s-*@")
                          (end-of-line)
                          (setq m (max m (current-column))))
                        (forward-line 1))
                      m)))
         (target-col (+ max-col 2)))
    (save-excursion
      (goto-char (point-min))
      (while (not (eobp))
        (beginning-of-line)
        (unless (looking-at "\\s-*@")
          (end-of-line)
          (unless (looking-back "@[^@]*" (line-beginning-position))
            (let ((pad (- target-col (current-column))))
              (insert (make-string (max pad 1) ?\s))
              (insert "@ "))))
        (forward-line 1)))))

;;
;; ascii <-> unicode
;;
(defun hprpl-ascii-to-unicode ()
  (interactive)
  (let ((case-fold-search nil))
    (save-excursion
      (dolist (pair (reverse hprpl-unicode-to-tio))
        (goto-char (point-min))
        (while (search-forward (cdr pair) nil t)
          (replace-match (car pair) t t))))))

(defun hprpl-unicode-to-ascii ()
  (interactive)
  (let ((case-fold-search nil))
    (save-excursion
      (dolist (pair hprpl-unicode-to-tio)
        (goto-char (point-min))
        (while (search-forward (car pair) nil t)
          (replace-match (cdr pair) t t))))))

(defvar-local hprpl--unicode-mode nil)

(defun hprpl--detect-unicode ()
  "Scans for any unicode character from `hprpl-unicode-to-tio'."
  (let ((case-fold-search nil)
        (found nil))
    (save-excursion
      (goto-char (point-min))
      ;; cdr drops the first entry (\\ → \\), identical in both modes
      (dolist (pair (cdr hprpl-unicode-to-tio))
        (unless found
          (goto-char (point-min))
          (when (search-forward (car pair) nil t)
            (setq found t)))))
    (when found
      (setq hprpl--unicode-mode t)
      (display-fill-column-indicator-mode 1))))

(defun hprpl-toggle-unicode ()
  (interactive)
  (if hprpl--unicode-mode
      (progn
        (hprpl-unicode-to-ascii)
        (setq hprpl--unicode-mode nil)
        (display-fill-column-indicator-mode -1)
        (font-lock-flush)
        (message "Mode ASCII (trigraphes)"))
    (progn
      (hprpl-ascii-to-unicode)
      (setq hprpl--unicode-mode t)
      (display-fill-column-indicator-mode 1)
      (font-lock-flush)
      (message "Mode Unicode"))))

;;
;; coloration
;;

;; Dynamic font-lock matcher: flags the overflow beyond unicode column 23
;; on each line, regardless of the mode (ASCII or unicode).
;; 23 is roughly the number of characters used on HP's original thermal
;; printer, as reproduced here
(defun hprpl--overflow-matcher (limit)
  (let (found)
    (while (and (not found) (< (point) limit))
      (let* ((bol (line-beginning-position))
             (eol (line-end-position))
             (overflow
              (if hprpl--unicode-mode
                  (+ bol 23)
                (+ bol (hprpl--ascii-col-for-unicode-col
                        (buffer-substring-no-properties bol eol) 23)))))
        (if (< overflow eol)
            (progn
              (set-match-data (list overflow eol))
              (goto-char (1+ eol))
              (setq found t))
          (forward-line 1))))
    found))

(defun hprpl--build-keywords ()
  "Build and return the `font-lock-keywords' list for hprpl-mode.
Called once at load time and again whenever modules are reloaded."
  (append
   (list
    ;; Warning: characters beyond column 23 (in unicode width).
    ;; The dynamic matcher accounts for trigraphs in ASCII mode.
    '(hprpl--overflow-matcher (0 font-lock-warning-face t))
    (cons hprpl-re-cv  'font-lock-type-face)
    (cons hprpl-re-ucv 'font-lock-type-face)
    (cons hprpl-re-mw  'font-lock-function-name-face)
    (cons hprpl-re-umw 'font-lock-function-name-face)
    (cons hprpl-re-w   'font-lock-keyword-face)
    (cons hprpl-re-uw  'font-lock-keyword-face)
    (cons hprpl-re-sw  'font-lock-builtin-face)
    ;; \<< \>> and their unicode equivalents « »
    (cons "\\\\<<\\|\\\\>>\\|«\\|»" 'font-lock-keyword-face)
    (cons "{.*?}"      'font-lock-constant-face)
    (cons "\\[.*?\\]"  'font-lock-constant-face)
    (cons "'.*?'"      'font-lock-constant-face)
    (cons "@.*"        'font-lock-comment-face)
    ;; \-> alone and its unicode equivalent → (standalone)
    (cons "\\\\->\\|→" 'font-lock-type-face)
    ;; HP50G: same colour as the category, distinctive background — override t
    (list hprpl-re-hp50-sw  '(0 'hprpl-hp50-stackwords-face t))
    (list hprpl-re-hp50-mw  '(0 'hprpl-hp50-mathwords-face t))
    (list hprpl-re-hp50-cw  '(0 'hprpl-hp50-convwords-face t))
    (list hprpl-re-hp50-ucw '(0 'hprpl-hp50-convwords-face t))
    (list hprpl-re-hp50-w   '(0 'hprpl-hp50-words-face t)))
   ;; Module words — appended last; override t so they appear over base rules
   (when hprpl-re-module-words
     (list (list hprpl-re-module-words '(0 'hprpl-module-words-face t))))))

;;
;; modules
;;
(defun hprpl--parse-module-file (path)
  "Return a list of words read from PATH.
One word per line; lines starting with `#' and blank lines are ignored."
  (when (file-readable-p path)
    (with-temp-buffer
      (insert-file-contents path)
      (let (words)
        (goto-char (point-min))
        (while (not (eobp))
          (let ((line (string-trim
                       (buffer-substring-no-properties
                        (line-beginning-position)
                        (line-end-position)))))
            ;; comment or empty => ignored
            (unless (or (string-empty-p line) (string-prefix-p "#" line))
              (push line words)))
          (forward-line 1))
        (nreverse words)))))

(defun hprpl--rebuild-keywords ()
  "Recompute `hprpl-keywords' and flush font-lock in all hprpl buffers."
  (setq hprpl-keywords (hprpl--build-keywords))
  (dolist (buf (buffer-list))
    (with-current-buffer buf
      (when (derived-mode-p 'hprpl-mode)
        (setq font-lock-set-defaults nil)
        (font-lock-set-defaults)
        (font-lock-flush)))))

(defun hprpl-reload-modules ()
  "Reload all files listed in `hprpl-module-files' and refresh font-lock."
  (interactive)
  (setq hprpl-module-words
        (cl-remove-duplicates
         (cl-mapcan #'hprpl--parse-module-file hprpl-module-files)
         :test #'string=))
  (setq hprpl-re-module-words
        (when hprpl-module-words
          (regexp-opt hprpl-module-words 'words)))
  (hprpl--rebuild-keywords)
  (message "hprpl modules: %d word(s) loaded from %d file(s)."
           (length hprpl-module-words)
           (length hprpl-module-files)))

(defun hprpl-load-module (file)
  "Add FILE to `hprpl-module-files', load it, and refresh font-lock.
If FILE is already in the list it is reloaded."
  (interactive "fModule file: ")
  (unless (member file hprpl-module-files)
    (setq hprpl-module-files (append hprpl-module-files (list file))))
  (hprpl-reload-modules))

(defun hprpl-unload-module (file)
  "Remove FILE from `hprpl-module-files' and refresh font-lock."
  (interactive
   (list (completing-read "Remove module: " hprpl-module-files nil t)))
  (setq hprpl-module-files (delete file hprpl-module-files))
  (hprpl-reload-modules))

;; defcustom for the file list — loading/unloading via Customize reloads automatically
(defcustom hprpl-module-files nil
  "List of file paths containing extra UserRPL word definitions.
Each file must list one word per line; lines beginning with `#' and
blank lines are ignored.  All words from all listed files are
highlighted with `hprpl-module-words-face'.

Use `hprpl-load-module' / `hprpl-unload-module' interactively, or
set this variable directly and call `hprpl-reload-modules'."
  :type '(repeat file)
  :group 'hprpl
  :set (lambda (sym val)
         (set-default sym val)
         ;; Guard: hprpl-reload-modules may not yet be defined at init
         (when (fboundp 'hprpl-reload-modules)
           (hprpl-reload-modules))))

(defvar hprpl-keywords (hprpl--build-keywords)
  "Font-lock keywords for hprpl-mode.
Rebuilt via `hprpl--build-keywords' whenever modules are loaded or unloaded.")

;;;
;; kbd shortcuts
;;
(defvar-keymap hprpl-prefix-map
  "c" #'hprpl-add-stack-comments
  "m" #'hprpl-load-module
  "M" #'hprpl-unload-module
  "u" #'hprpl-toggle-unicode
)

(defvar-keymap hprpl-mode-map
  "C-c h" hprpl-prefix-map)

;;
;; hprpl mode
;;
(defgroup hprpl nil
  "Major mode for UserRPL"
  :group 'languages)

(define-derived-mode hprpl-mode nil "HPRPL"
  "Major mode for UserRPL"
  :syntax-table (let ((st (make-syntax-table)))
                  (modify-syntax-entry ?@ "<" st)  ; comment start
                  (modify-syntax-entry ?\n ">" st)  ; comment end
                  (modify-syntax-entry ?\\ "w" st)  ; \ is part of words
                  st)
  (setq-local comment-start "@")
  (setq-local comment-start-skip "@+\\s-*")
  (setq-local tab-width 2)
  (setq-local font-lock-defaults '(hprpl-keywords))
  (setq-local indent-line-function #'hprpl-indent-line)
  ;; Visual indicator at 23 columns
  (setq-local fill-column 23)
  ;; The column indicator is only active in unicode mode.
  ;; In ASCII mode, the font-lock matcher hprpl--overflow-matcher handles
  ;; the per-line limit by accounting for trigraphs.
  (add-hook 'completion-at-point-functions #'hprpl-completion-at-point nil t)
  (add-hook 'hprpl-mode-hook #'indent-bars-mode)
  (add-hook 'hprpl-mode-hook
            (lambda ()
              (setq-local indent-tabs-mode nil)
              (setq-local indent-bars-spacing-override 2)))
  (add-hook 'hprpl-mode-hook #'hprpl--detect-unicode))

(add-to-list 'auto-mode-alist '("\\.hprpl$" . hprpl-mode))
(add-to-list 'auto-mode-alist '("\\.hp48$"  . hprpl-mode))
(add-to-list 'auto-mode-alist '("\\.hp49$"  . hprpl-mode))
(add-to-list 'auto-mode-alist '("\\.hp50$"  . hprpl-mode))

(provide 'hprpl-mode)
;;; hprpl-mode.el ends here