scribble-mode.el

;;; scribble-mode.el --- Major mode for Scribble typesetting language. -*- lexical-binding: t -*-

;; Copyright (C) 2019  Alex Harsanyi

;; Author: Alex Harsanyi <AlexHarsanyi@gmail.com>
;; Keywords: tools

;; 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 <https://www.gnu.org/licenses/>.

(require 'racket-mode)
(require 'racket-common)
(require 'easy-mmode)
(require 'cl-lib)
(require 'array)

(defgroup scribble-mode nil
  "Major mode for editing text files in Scribble format."
  :prefix "scribble-"
  :group 'text)

(defvar scribble-syntax-table
  (let ((table (make-syntax-table)))
    ;; Make @, - and / word constituents -- they seem more useful as
    ;; such, especially in regexps
    (modify-syntax-entry ?@ "w 1" table)
    (modify-syntax-entry ?- "w" table)
    (modify-syntax-entry ?/ "w" table)
    (modify-syntax-entry ?* "w" table)
    (modify-syntax-entry ?\; ". 2" table)
    (modify-syntax-entry ?\n ">" 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)

    table)
  "Syntax table used in `scribble-mode'.")



;;................................................................ faces ....

(defface scribble-section-face
  '((t (:inherit font-lock-function-name-face :weight bold)))
  "Face for section (and sub-section) text."
  :group 'scribble-mode)
(defvar scribble-section-face 'scribble-section-face)

(defface scribble-italic-face
  '((t (:inherit italic)))
  "Face for italic text."
  :group 'scribble-mode)
(defvar scribble-italic-face 'scribble-italic-face)

(defface scribble-bold-face
  '((t (:inherit bold)))
  "Face for bold text."
  :group 'scribble-mode)
(defvar scribble-bold-face 'scribble-bold-face)

(defface scribble-racket-face
  '((t (:inherit font-lock-doc-face)))
  "Face for @racket sections."
  :group 'scribble-mode)
(defvar scribble-racket-face 'scribble-racket-face)

(defface scribble-code-face
  '((t (:inherit fixed-pitch)))
  "Face for @tt sections"
  :group 'scribble-mode)
(defvar scribble-code-face 'scribble-code-face)

;; NOTE: this does not seem to work -- the @;{...} comment is
;; highlighted briefly, than font-lock removes the comment highlight
;; from the region. @; comments seem to work fine.

(defun scribble-font-lock-sexp-comments (limit)
  "Find the region for Scribble comments @;... and @;{...}.
This function marks the beginning and end of such a block comment
in the match data, using `set-match-data' and it is indented to
be used in font-lock-keywords."
  (ignore-errors
    (when (re-search-forward "@;" limit 'noerror)
      (let ((md (match-data)))
        (goto-char (match-end 0))
        (if (looking-at "{")
            (forward-sexp 1)
          (end-of-line))
        ;; set (match-end 0) to the end of the comment
        (setf (elt md 1) (point-marker))
        (set-match-data md)
        t))))

(defun scribble-font-lock-text-style (text-style limit &optional skip-datum)
  (when (re-search-forward text-style limit 'noerror)
    ;; note `set-match-data' must receive a modified list produced by
    ;; `match-data'
    (let ((result (list (make-marker) (make-marker)
                        (make-marker) (make-marker)
                        (make-marker) (make-marker))))
      (set-marker (nth 0 result) (match-beginning 0))
      (set-marker (nth 2 result) (match-beginning 0))
      (set-marker (nth 3 result) (match-end 0))
      (goto-char (match-end 0))
      (when (and skip-datum (looking-at "\\["))
        (forward-sexp 1))
      (when (looking-at "{\\|\\[")
        (progn
          (set-marker (nth 4 result) (1+ (point)))
          (forward-sexp 1)
          ;; set (match-end 0) to the end of the comment
          (set-marker (nth 5 result) (1- (point)))
          (set-marker (nth 1 result) (point))))
      (set-match-data result)
      t)))

(defun scribble-font-lock-at-exp (limit)
  (when (re-search-forward "@(" limit 'noerror)
    (let ((result (list (make-marker) (make-marker)
                        (make-marker) (make-marker)
                        (make-marker) (make-marker))))
      (set-marker (nth 0 result) (match-beginning 0))
      (set-marker (nth 2 result) (match-beginning 0))
      (set-marker (nth 3 result) (1- (match-end 0)))
      (goto-char (match-end 0))
      (set-marker (nth 4 result) (point))
      (forward-char -1)
      (forward-sexp 1)
      (set-marker (nth 1 result) (point))
      (goto-char (nth 4 result))
      (forward-sexp 1)
      (set-marker (nth 5 result) (point))
      (set-match-data result)
      t)))

(defun scribble-font-lock-italic (limit)
  (scribble-font-lock-text-style "@\\(italic\\|emph\\)\\_>" limit))
(defun scribble-font-lock-bold (limit)
  (scribble-font-lock-text-style "@bold\\_>" limit))
(defun scribble-font-lock-tt (limit)
  (scribble-font-lock-text-style "@tt\\_>" limit))
(defun scribble-font-lock-racket (limit)
  (scribble-font-lock-text-style "@\\(racket\\|x?method\\)\\_>" limit))
(defun scribble-font-lock-sections (limit)
  (scribble-font-lock-text-style "@\\(author\\|title\\|\\(\\(sub\\)*\\*?section\\)\\)\\_>" limit 'skip-datum))

(defvar scribble-font-lock-keywords
  `(("@def\\sw+" (0 font-lock-keyword-face))
    (scribble-font-lock-at-exp
     . ((1 font-lock-keyword-face)
        (2 font-lock-function-name-face)))
    ;; Comments
    (,#'scribble-font-lock-sexp-comments
     (0 font-lock-comment-face append))

    ;; Keywords and symbols
    ("#:\\sw+" (0 font-lock-constant-face))
    ("\\B\\('\\sw+\\)" (1 font-lock-constant-face))

    ;; Document structure
    ("@include-section\\_>" . font-lock-keyword-face)
    (scribble-font-lock-sections . ((1 font-lock-keyword-face)
                                    (2 scribble-section-face)))

    ;; Blocks
    ("@\\(para\\|nested\\|centered\\|margin-note\\*?\\|itemlist\\|item\\|tabular\\|verbatim\\)\\_>"
     . (0 font-lock-constant-face))

    ;; Text style and Content
    ("@\\(elem\\|subscript\\|superscript\\|smaller\\|larger\\|literal\\)\\_>"
     . (0 font-lock-builtin-face))
    (scribble-font-lock-italic . ((1 font-lock-builtin-face)
                                  (2 scribble-italic-face t)))
    (scribble-font-lock-bold .((1 font-lock-builtin-face)
                               (2 scribble-bold-face)))
    (scribble-font-lock-tt . ((1 font-lock-builtin-face)
                              (2 scribble-code-face)))
    ;; Other
    ("@\\(image\\|linebreak\\|nonbreaking\\|hspace\\|hyperlink\\|url\\|[Ss]ecref\\|seclink\\|other-doc\\|elemtag\\|elemref\\|\\(as-\\|section-\\)?index\\*?\\|index-section\\|\\(local-\\)?table-of-contents\\)\\_>"
     . (0 font-lock-type-face))

    (scribble-font-lock-racket .((1 font-lock-function-name-face)
                                    (2 scribble-racket-face)))
    ;; Warning-Highlight space between the datum [], and body {} --
    ;; Scribble likes next to each other -- note that we highlight the
    ;; closing and opening brackets too, as highlighting just the
    ;; space is not very visible.
    ("\\]\\([ \t\n\r\f]+\\){"
     (0 font-lock-warning-face prepend))
    ;; Warning-Highlight space between the @command and the datum[] --
    ;; Scribble likes them next to each other -- note that we
    ;; highlight the entire command, since highlight just the space is
    ;; not very visible.
    ("@\\sw*\\([ \t\n\r\f]+\\)\\((\\|\\[\\|{\\)"
     (0 font-lock-warning-face prepend)))
  "Font lock definitions for `scribble-mode'.")


;;...................................................... syntax analysis ....

(cl-defstruct scribble-context
  kind                     ; 'comment, 'string 'at-expression 'at-command
  name                     ; name of the 'at-command
  start                    ; start position for the entire context
  section                  ; 'datum for inside [], 'body for inside {}
  place                    ; 'open, 'continuation, 'close
  anchor                   ; position of section start
  ppss                     ; result of syntax-ppss
  )

(defun scribble-context-of-line (&optional no-back-to-indentation)
  "Determine the syntax context of the current line of code.
Returns a list of `scribble-context' instances, inner-most
first."
  (save-excursion
    (unless no-back-to-indentation
      (back-to-indentation))
    (let ((start (point))
          (ppss (syntax-ppss (point)))
          (context '())
          (place nil))
      (cond
        ((nth 4 ppss)                   ; inside a comment
         (push (make-scribble-context
                :ppss ppss
                :kind 'comment
                :start (nth 8 ppss)
                :anchor (nth 8 ppss))
               context))
        ((nth 3 ppss)                   ; inside a string
         (push (make-scribble-context
                :ppss ppss
                :kind 'comment
                :start (nth 8 ppss)
                :anchor (nth 8 ppss))
               context))
        ((looking-at "\\(\\]\\|}\\)")
         ;; Whatever context we are in, this is the closing line
         (setq place 'close)))

      (goto-char start)

      (dolist (pos (reverse (nth 9 ppss)))
        (goto-char pos)
        (cond
          ((looking-at "(")
           (forward-char -1)
           (when (looking-at "@")
             (let ((canchor (point)))
               (goto-char start)
               (skip-chars-backward " \t\n\r\f\v")
               (if (eq (point) pos)
                   (setq place 'open)   ; override it
                 (unless place
                   (setq place 'continuation)))
               (push (make-scribble-context
                      :ppss ppss
                      :kind 'at-expression
                      :start canchor
                      :place place
                      :anchor pos)
                     context))))
          ((looking-at "\\[")
           (skip-chars-backward " \t\n\r\f\v")
           (skip-syntax-backward "w")
           (when (looking-at "\\(@\\w+\\)\\s-*\\[")
             (let ((cname (match-string-no-properties 1))
                   (canchor (point)))
               (goto-char start)
               (skip-chars-backward " \t\n\r\f\v")
               (forward-char -1)
               (if (eq (point) pos)
                   (setq place 'open)   ; override it
                 (unless place
                   (setq place 'continuation)))
               (push (make-scribble-context
                      :ppss ppss
                      :kind 'at-command
                      :name cname
                      :start canchor
                      :section 'datum
                      :place place
                      :anchor pos)
                     context))))
          ((looking-at "{")
           (forward-char -1)
           (skip-chars-backward " \t\n\r\f\v")
           (when (looking-at "\\]")     ; skip over [...]
             (forward-char 1)
             (forward-sexp -1))
           (skip-chars-backward " \t\n\r\f\v")
           (skip-syntax-backward "w")
           (when (looking-at "\\(@\\w+\\)\\s-*\\(\\[\\|{\\)")
             (let ((cname (match-string-no-properties 1))
                   (canchor (point)))
               (goto-char start)
               (skip-chars-backward " \t\n\r\f\v")
               (forward-char -1)
               (if (eq (point) pos)
                   (setq place 'open)   ; override it
                 (unless place
                   (setq place 'continuation)))
               (push (make-scribble-context
                      :ppss ppss
                      :kind 'at-command
                      :name cname
                      :start canchor
                      :section 'body
                      :place place
                      :anchor pos)
                     context))))))
      (reverse context))))

(defun scribble-current-atcommand-body-region ()
  "Find the region of the inner-most @command body at `point'.
Returns a (cons START END) of buffer positions, or nil if there
is no @command surrounding `point'"
  (let ((context (scribble-context-of-line 'no-back-to-indentation)))
    (when context
      (let ((item (car context)))
        (when (and (eq (scribble-context-kind item) 'at-command)
                   (eq (scribble-context-section item) 'body))
          (save-excursion
            (goto-char (scribble-context-anchor item))
            (condition-case _err
                (progn
                  (forward-sexp 1)
                  (cons (scribble-context-anchor item) (point)))
              (scan-error
               (cons (scribble-context-anchor item) (point-max))))))))))

(defun scribble-fill-paragaph (&optional justify region)
  "Fill the text in a Scribble paragraph.
This is intended to be used as `fill-paragraph-function' and will
limit the region to be filled to the @command body, so filling
works nicely inside {...} constructs.  The actual filling is done
by `fill-region' if point is inside an @command body, or
delegated back to `fill-paragraph' if outside."
  (let ((body-region (scribble-current-atcommand-body-region)))
    (if body-region
        (let* ((here (point))
               (pstart (max (1+ (car body-region))
                           (progn (forward-paragraph -1) (point))))
               (pend (min (1- (cdr body-region))
                          (progn (goto-char here) (forward-paragraph 1) (point)))))
          (goto-char here)
          (fill-region pstart pend justify))
      (let ((fill-paragraph-function nil)
            (fill-paragraph-handle-comment t))
        (fill-paragraph justify region)))))

(defun scribble-beginning-of-defun (&optional arg)
  "Move point to the beginning of the current @command."
  ;; NOTE: the implementation of this function needs to be somewhat
  ;; complex, as it needs to handle negative ARG values, and move to
  ;; the end of defun in such a case.  The "end-of-defun" movement is
  ;; done as a combination of calling this function with a negative
  ;; ARG followed by calling `end-of-defun-function'.  Thus
  ;; `end-of-defun-function' is called in a special context and only
  ;; needs to move over some sexps
  ;;
  ;; (message "scribble-beginning-of-defun: arg = %s" arg)
  (if (and (numberp arg) (< arg 0))
      (skip-chars-forward " \t\n\r\f\v")
    (progn
      (unless (equal (skip-chars-backward " \t\n\r\f\v") 0)
        (forward-char -1))
      (skip-syntax-backward "w")))

  (if (looking-at "\\(@\\w+\\)\\s-*\\(\\[\\|{\\)") ; already at start of defun
      (forward-sexp 1)
    (let ((context (scribble-context-of-line 'no-back-to-indentation)))
      (catch 'done
        (dolist (item context)
          (when (eq (scribble-context-kind item) 'at-command)
            ;; We are supposed to move point to the opening bracket,
            ;; not to the actual beginning of the defun.
            ;; `beginning-of-defun' will do the rest.
            (goto-char (scribble-context-anchor item)))
          (throw 'done t)))))

  ;; Negative arg indicates that we need to move to the end of defun
  ;; instead.
  (when (and (numberp arg) (< arg 0))
    (condition-case _err
        (forward-sexp 1)
      (scan-error
       (goto-char (point-max)))))

  (if (and (numberp arg) (/= arg -1) (/= arg 1) (/= arg 0))
      (scribble-beginning-of-defun (if (> arg 0) (1- arg) (1+ arg)))
    (point)))

(defun scribble-end-of-defun (&optional _arg)
  "Move point to the end of the current @command"
  ;; This implementation is very simple because `beginning-of-defun'
  ;; does most of the work, as it is called even when we need to move
  ;; to the end of defun.
  (when (looking-at "@")
    (forward-word 1))
  (when (looking-at ";")
    (forward-char 1))
  (when (looking-at "\\[")
    (forward-sexp 1))
  (when (looking-at "{")
    (forward-sexp 1)))


;;................................................................. rest ....

(defvar scribble-basic-offset 2)

(defun scribble-use-previous-line-indentation (context-item)
  "Return the indentation of the previous line.
If the start of the previous line is before the anchor of SYNTAX,
use the column of the anchor + 1."
  (let ((limit (scribble-context-anchor context-item))
        (ppss (scribble-context-ppss context-item)))
    (catch 'done
      (save-excursion
        (while t
          (if (< (point) limit)
              ;; We went beyond our anchor point, so take anchor + 1
              ;; as the indentation column.
	      (progn
                (goto-char limit)
                (throw 'done (1+ (current-column))))
            (if (= (forward-line -1) 0)
                (progn
                  (back-to-indentation)
                  (let ((ppss1 (syntax-ppss (point))))
                    ;; Only consider previous line if it is not empty
                    ;; and at the same PPSS context
                    (when (and (not (looking-at "\\s-*$"))
                               (eq (nth 3 ppss) (nth 3 ppss1))
                               (eq (nth 4 ppss) (nth 4 ppss1))
                               (eq (nth 0 ppss) (nth 0 ppss1)))
                      (throw 'done (current-column)))))
              ;; Forward-line didn't move, we must be at the start of
              ;; buffer
              (throw 'done (current-column)))))))))

(defun scribble-use-anchor-indentation (context-item)
  (save-excursion
    (goto-char (scribble-context-anchor context-item))
    (back-to-indentation)
    (current-column)))

(defun scribble-use-start-indentation (context-item)
  (save-excursion
    (goto-char (scribble-context-start context-item))
    (back-to-indentation)
    (current-column)))

(defun scribble-context-item-region (context-item)
  "Find the region of the CONTEXT-ITEM"
  (when (memq (scribble-context-section context-item) '(datum body))
    (save-excursion
      (goto-char (scribble-context-anchor context-item))
      (condition-case _err
          (progn
            (forward-sexp 1)
            (cons (scribble-context-anchor context-item) (point)))
        (scan-error
         (cons (scribble-context-anchor context-item) (point-max)))))))

(defun scribble-use-racket-indentation (context-item &optional base-indentation)
  (let ((region (scribble-context-item-region context-item))
        (cline (current-line)))
    (if region
        (save-excursion
          (let ((indent (save-restriction
                          (widen)
                          (narrow-to-region (1+ (car region)) (1- (cdr region)))
                          (racket--calculate-indent))))
            (if indent
                (progn
                  (goto-char (1+ (car region)))
                  (+ indent (if (or (= indent 0) (< (- cline (current-line)) 2))
                                (current-column)
                              0)))
              base-indentation)))
      base-indentation)))

(defun scribble-calculate-indentation (context &optional base-indentation)
  (if context
      (let ((context-item (car context)))
        (cond
          ((and (eq (scribble-context-kind context-item) 'at-command)
                (eq (scribble-context-section context-item) 'datum)
                (member (scribble-context-name context-item)
                        '("@interaction" "@defproc" "@defmethod" "@examples")))
           (scribble-use-racket-indentation context-item))
          ((memq (scribble-context-section context-item) '(datum body))
           (case (scribble-context-place context-item)
             ((open)
              (+ (scribble-use-start-indentation context-item)
                 scribble-basic-offset))
             ((continuation)
              (scribble-use-previous-line-indentation context-item))
             ((close)
              (scribble-use-start-indentation context-item))))
          (t base-indentation)))
    base-indentation))

(defun scribble-indent-line ()
  "Indent a Scribble line of code"
  (let* ((context (scribble-context-of-line))
	 (base-column (current-column))
         (indent-column (scribble-calculate-indentation context)))
    (when indent-column
      (back-to-indentation)
      (let ((offset (- base-column (current-column))))
	;; avoid modifying the buffer when the indentation does not
	;; have to change
	(unless (eq (current-column) indent-column)
	  (indent-line-to indent-column))
	(when (> offset 0)
	  (forward-char offset))))))

;;;###autoload
(define-derived-mode scribble-mode prog-mode
  "Scribble"
  "Major mode for editing Scribble documents"
  :syntax-table scribble-syntax-table

  (set (make-local-variable 'comment-start) "@;")
  (set (make-local-variable 'comment-start-skip) "@;\\s-*")
  (set (make-local-variable 'comment-end) "")
  (set (make-local-variable 'indent-line-function) #'scribble-indent-line)
  (set (make-local-variable 'beginning-of-defun-function) #'scribble-beginning-of-defun)
  (set (make-local-variable 'end-of-defun-function) #'scribble-end-of-defun)
  (set (make-local-variable 'font-lock-defaults)
       '((scribble-font-lock-keywords)
         nil nil nil nil
         (font-lock-multiline . t)
         (font-lock-mark-block-function . mark-defun)))
  (set (make-local-variable 'fill-paragraph-function) #'scribble-fill-paragaph)

  (define-key scribble-mode-map ")" #'racket-insert-closing)
  (define-key scribble-mode-map "]" #'racket-insert-closing)
  (define-key scribble-mode-map "}" #'racket-insert-closing)

  )

;;;###autoload
(add-to-list 'auto-mode-alist '("\\.scrbl\\'" . scribble-mode))

(provide 'scribble-mode)