;;; racket-common.el -*- lexical-binding: t; -*-

;; Copyright (c) 2013-2019 by Greg Hendershott.
;; Portions Copyright (C) 1985-1986, 1999-2013 Free Software Foundation, Inc.

;; Author: Greg Hendershott
;; URL: https://github.com/greghendershott/racket-mode

;; License:
;; This 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 2, or (at your option)
;; any later version. This 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. See
;; http://www.gnu.org/licenses/ for details.

;; Things used by both racket-mode and racket-repl-mode

(require 'cl-lib)
(require 'thingatpt)
(require 'racket-custom)
(require 'racket-keywords-and-builtins)
(require 'racket-font-lock)
(require 'racket-indent)
(require 'racket-parens)
(require 'racket-ppss)
(require 'racket-util)

(declare-function racket-complete-at-point "racket-complete.el" (&optional predicate))

(defvar racket-mode-abbrev-table nil)
(define-abbrev-table 'racket-mode-abbrev-table ())

;;; syntax-table and syntax-propertize-function

(defvar racket-mode-syntax-table
  (let ((st (make-syntax-table))
	(i 0))
    ;; Symbol constituents
    (while (< i ?0)
      (modify-syntax-entry i "_   " st)
      (setq i (1+ i)))
    (setq i (1+ ?9))
    (while (< i ?A)
      (modify-syntax-entry i "_   " st)
      (setq i (1+ i)))
    (setq i (1+ ?Z))
    (while (< i ?a)
      (modify-syntax-entry i "_   " st)
      (setq i (1+ i)))
    (setq i (1+ ?z))
    (while (< i 128)
      (modify-syntax-entry i "_   " st)
      (setq i (1+ i)))

    ;; Whitespace (except ?\n, see below in comment section)
    (modify-syntax-entry ?\t "    " st)
    (modify-syntax-entry ?\f "    " st)
    (modify-syntax-entry ?\r "    " st)
    (modify-syntax-entry ?\s "    " st)

    ;; These characters are delimiters but otherwise undefined.
    ;; Brackets and braces balance for editing convenience.
    (modify-syntax-entry ?\( "()  " st)
    (modify-syntax-entry ?\) ")(  " st)
    (modify-syntax-entry ?\[ "(]  " st)
    (modify-syntax-entry ?\] ")[  " st)
    (modify-syntax-entry ?{  "(}  " st)
    (modify-syntax-entry ?}  "){  " st)

    ;; Other atom delimiters
    (modify-syntax-entry ?\" "\"   " st)
    (modify-syntax-entry ?'  "'   " st)
    (modify-syntax-entry ?`  "'   " st)
    (modify-syntax-entry ?,  "'   " st)
    (modify-syntax-entry ?@  "'   " st)
    (modify-syntax-entry ?\\ "\\   " st)

    ;; Comment related
    (modify-syntax-entry ?\; "<   " st) ;line comments but NOT sexp #;
    (modify-syntax-entry ?\n ">   " st)

    (modify-syntax-entry ?#  "w 14" st) ;not necessarily prefix
    (modify-syntax-entry ?|  "_ 23bn" st)

    st))

(defun racket-syntax-propertize-function (start end)
  (goto-char start)
  (racket--syntax-propertize-here-string end)
  (funcall
   (syntax-propertize-rules
    ;; here strings: The main responsibility here is to set the "|"
    ;; char syntax around the "body" so it's treated as a string for
    ;; indent, nav, font-lock. Think of the \n in #<<ID\n as the open
    ;; | quote and the \n in ^ID\n as the close | quote.
    ((rx "#<<" (group (+? (not (any blank ?\n)))) (group ?\n))
     (2 (racket--syntax-propertize-open-here-string
         (match-beginning 0)
         (match-string-no-properties 1)
         (match-beginning 2))))
    ((rx (syntax string-delimiter))
     (0 (ignore (racket--syntax-propertize-here-string end))))
    ;; sexp comments should LOOK like comments but NOT ACT like
    ;; comments: Give the #; itself the syntax class "prefix" [1], but
    ;; allow the following sexp to get the usual syntaxes. That way
    ;; things like indent and sexp nav work within the sexp. Only
    ;; font-lock handles the sexp specially; see racket-font-lock.el.
    ;;
    ;; [1]: Although it's tempting to use punctuation -- so things like
    ;; `backward-sexp' and `racket-send-last-sexp' ignore the #; --
    ;; that would mess up indentation of things following the sexp
    ;; comment. Instead special-case `racket-send-last-sexp'.
    ((rx "#;")
     (0 "'"))
    ;; Treat "complex" reader literals as a single sexp for nav and
    ;; indent, by marking the stuff after the # as prefix syntax.
    ;; Racket predefines reader literals like #"" #rx"" #px"" #hash()
    ;; #hasheq() #fx3(0 1 2) #s() and so on. I think these -- plus any
    ;; user defined reader extensions -- can all be covered with the
    ;; following general rx. Also it seems sufficient to look for just
    ;; the opening delimiter -- the ( [ { or " -- here.
    ((rx (group ?#
                (*?
                 (and (not (any ?|))  ;not multiline comment; see #362
                      (or (syntax symbol)
                          (syntax word)))))
         (or ?\" ?\( ?\[ ?\{))
     (1 "'"))
    ;; Syntax quoting
    ((rx ?# (or ?` ?' ?,))
     (0 "'"))
    ;; Treat '|symbol with spaces| as word syntax
    ((rx ?' ?| (*? (not (any ?\" ?\r ?\n))) ?|)
     (0 "w"))
    ;; Treat |identifier with spaces| -- but not #|comment|# -- as
    ;; word syntax
    ((rx (not (any ?#))
         (group ?| (*? (not (any ?\" ?\r ?\n))) ?|)
         (not (any ?#)))
     (1 "w")))
   (point)
   end))

(defun racket--syntax-propertize-open-here-string (start string eol)
  "Determine the syntax of the \\n after a #<<HERE
START is the position of #<<.
STRING is the actual word used as delimiter (e.g. \"HERE\").
EOL is the position of the \\n.
Point is at the beginning of the next line.

This sets the open | syntax and sets a 'racket-here-string
property whose value is STRING. The close | syntax is set by
`racket--syntax-propertize-here-string'."
  (unless (save-excursion
            (let ((ppss (syntax-ppss start)))
              (or (racket--ppss-string-p ppss)
                  (racket--ppss-comment-p ppss))))
    (let ((ppss (save-excursion (syntax-ppss eol))))
      (if (racket--ppss-comment-p ppss)
          ;; The \n not only starts the heredoc but also closes a comment.
          ;; Let's close the comment just before the \n.
          (put-text-property (1- eol) eol 'syntax-table '(12))) ;">"
      (if (or (racket--ppss-quote-p ppss)
              (< 1 (count-lines start eol)))
          ;; If we matched several lines, make sure we refontify them
          ;; together. Furthermore, if the \n is quoted, it means the
          ;; right \n is actually further down. Don't bother fixing it
          ;; now, but place a multiline property so that when
          ;; jit-lock-context-* refontifies the rest of the buffer, it
          ;; also refontifies the current line with it.
          (put-text-property start (1+ eol) 'syntax-multiline t))
      (put-text-property eol (1+ eol) 'racket-here-string string)
      (goto-char (+ 3 start))
      (string-to-syntax "|"))))

(defun racket--syntax-propertize-here-string (end)
  "If in a here string that ends before END, add | syntax for its close."
  (let ((ppss (syntax-ppss)))
    (when (eq (racket--ppss-string-p ppss) t) ;t as opposed to ?" or ?'
      (let ((key (get-text-property (racket--ppss-string/comment-start ppss)
                                    'racket-here-string)))
        (when (and key
                   (re-search-forward (concat "^" (regexp-quote key) "\\(\n\\)")
                                      end t))
          (let ((eol (match-beginning 1)))
            (put-text-property eol (1+ eol)
                               'syntax-table
                               (string-to-syntax "|"))))))))

;;;

(defun racket--common-variables ()
  "Set variables common to `racket-mode' and `racket-repl-mode'."
  ;;; Syntax
  (set-syntax-table racket-mode-syntax-table)
  (setq-local multibyte-syntax-as-symbol t)
  (setq-local parse-sexp-ignore-comments t)
  (setq-local syntax-propertize-function #'racket-syntax-propertize-function)
  (syntax-propertize (point-max)) ;for e.g. paredit: see issue #222
  ;; -----------------------------------------------------------------
  ;; Font-lock
  (setq-local font-lock-defaults
              (list racket-font-lock-keywords ;keywords
                    nil                       ;keywords-only?
                    nil                       ;case-fold?
                    nil                       ;syntax-alist
                    nil                       ;syntax-begin
                    ;; Additional variables:
                    (cons 'font-lock-mark-block-function #'mark-defun)
                    (cons 'parse-sexp-lookup-properties t)
                    (cons 'font-lock-multiline t)
                    (cons 'font-lock-syntactic-face-function
                          #'racket-font-lock-syntactic-face-function)
                    (list 'font-lock-extend-region-functions
                          #'font-lock-extend-region-wholelines
                          #'font-lock-extend-region-multiline)))
  ;; -----------------------------------------------------------------
  ;; Comments. Mostly borrowed from lisp-mode and/or scheme-mode
  (setq-local comment-start ";")
  (setq-local comment-add 1)        ;default to `;;' in comment-region
  (setq-local comment-start-skip ";+ *")
  (setq-local comment-column 40)
  (setq-local comment-multi-line t) ;for auto-fill-mode and #||# comments
  ;; Font lock mode uses this only when it knows a comment is starting:
  (setq-local font-lock-comment-start-skip ";+ *")
  ;; -----------------------------------------------------------------
  ;; Indent
  (setq-local indent-line-function #'racket-indent-line)
  (racket--set-indentation)
  (setq-local indent-tabs-mode nil)
  ;; -----------------------------------------------------------------
  ;;; Misc
  (setq-local local-abbrev-table racket-mode-abbrev-table)
  (setq-local paragraph-start (concat "$\\|" page-delimiter))
  (setq-local paragraph-separate paragraph-start)
  (setq-local paragraph-ignore-fill-prefix t)
  (setq-local fill-paragraph-function #'lisp-fill-paragraph)
  (setq-local adaptive-fill-mode nil)
  (setq-local outline-regexp ";;; \\|(....")
  (setq-local completion-at-point-functions (list #'racket-complete-at-point))
  (setq-local eldoc-documentation-function nil)
  (setq-local beginning-of-defun-function #'racket--beginning-of-defun-function))


;;; Insert lambda char (like DrRacket)

(defconst racket-lambda-char (make-char 'greek-iso8859-7 107)
  "Character inserted by `racket-insert-labmda'.")

(defun racket-insert-lambda ()
  "Insert λ.

To insert Unicode symbols generally, see `racket-unicode-input-method-enable'."
  (interactive)
  (insert-char racket-lambda-char 1))
(put 'racket-insert-lambda 'delete-selection t)


;;; racket--beginning-of-defun

(defun racket--beginning-of-defun-function ()
  "Like `beginning-of-defun' but aware of Racket module forms."
  (let ((orig (point)))
    (racket--escape-string-or-comment)
    (pcase (racket--module-level-form-start)
      (`() (ignore-errors (backward-sexp 1)))
      (pos (goto-char pos)))
    (/= orig (point))))

(defun racket--module-level-form-start ()
  "Start position of the module-level form point is within.

A module-level form is the outermost form not nested in a Racket
module form.

If point is not within a module-level form, returns nil.

If point is already exactly at the start of a module-level form,
-- i.e. on the opening ?\( -- returns nil.

If point is within a string or comment, returns nil.

This is NOT suitable for the variable `syntax-begin-function'
because it (i) doesn't move point, and (ii) doesn't know how to
find the start of a string or comment."
  (save-excursion
    (ignore-errors
      (let ((pos nil)
            (parse-sexp-ignore-comments t))
        (while (ignore-errors
                 (goto-char (scan-lists (point) -1 1))
                 (unless (looking-at racket-module-forms)
                   (setq pos (point)))
                 t))
        (and pos
             (or (racket--sexp-comment-start pos)
                 pos))))))

(defun racket--sexp-comment-start (pos)
  "Start pos of sexp comment (if any) immediately before POS.

Allows #; to be followed by zero or more space or newline chars."
  (save-excursion
    (goto-char pos)
    (while (memq (char-before) '(32 ?\n))
      (goto-char (1- (point))))
    (when (string= "#;" (buffer-substring-no-properties (- (point) 2) (point)))
      (- (point) 2))))


;;; racket--what-to-run

(defun racket--what-to-run ()
  (cons (racket--buffer-file-name)
        (racket--submod-path)))

(defun racket--submod-path ()
  (and (racket--lang-p)
       (racket--modules-at-point)))

(defun racket--lang-p ()
  "Is #lang the first sexpr in the file, after an optional shebang?"
  (save-excursion
    (goto-char (point-min))
    (ignore-errors
      (forward-sexp)
      (backward-sexp)
      (when (looking-at (rx "#!"))
        (forward-line)
        (forward-sexp)
        (backward-sexp))
      (looking-at (rx "#lang")))))

(defun racket--modules-at-point ()
  "List of module names that point is within, from outer to inner.
Ignores module forms nested (at any depth) in any sort of plain
or syntax quoting, because those won't be valid Racket syntax."
  (let ((xs nil))
    (condition-case ()
        (save-excursion
          (save-match-data
            (racket--escape-string-or-comment)
            (while t
              (when (racket--looking-at-module-form)
                (push (intern (match-string-no-properties 1)) xs))
              (when (racket--looking-at-quoted-form)
                (push nil xs))
              (backward-up-list))))
      (scan-error xs))
    (racket--take-while xs #'identity)))

(defun racket--looking-at-module-form ()
  "Sets match data group 1 to the module name."
  (looking-at (rx ?\(
                  (or "module" "module*" "module+")
                  (1+ " ")
                  (group (+ (or (syntax symbol)
                                (syntax word)))))))

(defun racket--looking-at-quoted-form ()
  (or (memq (char-before) '(?\' ?\` ?\,))
      (and (eq (char-before (1- (point))) ?\,)
           (eq (char-before) ?\@))
      (looking-at
       (rx ?\(
           (or "quote" "quasiquote"
               "unquote" "unquote-splicing"
               "quote-syntax"
               "syntax" "syntax/loc"
               "quasisyntax" "quasisyntax/loc"
               "unsyntax" "unsyntax-splicing")
           " "))))

;;; Misc

(defun racket--escape-string-or-comment ()
  "If point is in a string or comment, move to its start.

Note that this can be expensive, as it uses `syntax-ppss' which
parses from the start of the buffer. Although `syntax-ppss' uses
a cache, that is invalidated after any changes to the buffer. As
a result, the worst case would be to call this function after
every character is inserted to a buffer."
  (pcase (racket--ppss-string/comment-start (syntax-ppss))
    (`() nil)
    (pos (goto-char pos))))

(defun racket-backward-up-list ()
  "Like `backward-up-list' but works when point is in a string or comment.

Typically you should not use this command in Emacs Lisp --
especially not repeatedly. Instead, initially use
`racket--escape-string-or-comment' to move to the start of a
string or comment, if any, then use normal `backward-up-list'
repeatedly."
  (interactive)
  (racket--escape-string-or-comment)
  (backward-up-list 1))

(provide 'racket-common)

;; racket-common.el ends here