;;; theme-d-el --- Theme-D editing mode

;; Copyright (C) 2014  Tommi Höynälänmaa

;; This file is based on the Scheme mode source code in GNU Emacs.
;; The authors of the original code are:
;;   Author: Bill Rozas <jinx@martigny.ai.mit.edu>
;;   Adapted-by: Dave Love <d.love@dl.ac.uk>
;;   Keywords: languages, lisp
;; This file is distributed under the GNU General Public License,
;; either version 3 of the License, or (at your option) any later
;; version.

;;; Code:

(require 'lisp-mode)

(defvar theme-d-mode-syntax-table
  (let ((st (make-syntax-table))
	(i 0))

    ;; Default is atom-constituent.
    (while (< i 256)
      (modify-syntax-entry i "_   " st)
      (setq i (1+ i)))

    ;; Word components.
    (setq i ?0)
    (while (<= i ?9)
      (modify-syntax-entry i "w   " st)
      (setq i (1+ i)))
    (setq i ?A)
    (while (<= i ?Z)
      (modify-syntax-entry i "w   " st)
      (setq i (1+ i)))
    (setq i ?a)
    (while (<= i ?z)
      (modify-syntax-entry i "w   " st)
      (setq i (1+ i)))

    ;; Whitespace
    (modify-syntax-entry ?\t "    " st)
    (modify-syntax-entry ?\n ">   " 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)

    ;; Commented out by TH.
    ;; (modify-syntax-entry ?\| "\" 23bn" st)

    ;; Guile allows #! ... !# comments.
    ;; But SRFI-22 defines the comment as #!...\n instead.
    ;; Also Guile says that the !# should be on a line of its own.
    ;; It's too difficult to get it right, for too little benefit.
    ;; (modify-syntax-entry ?! "_ 2" st)

    ;; Other atom delimiters
    (modify-syntax-entry ?\( "()  " st)
    (modify-syntax-entry ?\) ")(  " st)
    ;; It's used for single-line comments as well as for #;(...) sexp-comments.
    (modify-syntax-entry ?\; "< 2 " st)
    (modify-syntax-entry ?\" "\"   " st)
    (modify-syntax-entry ?' "'   " st)
    (modify-syntax-entry ?` "'   " st)

    ;; Special characters
    (modify-syntax-entry ?, "'   " st)
    (modify-syntax-entry ?@ "'   " st)
    (modify-syntax-entry ?# "' 14b" st)
    (modify-syntax-entry ?\\ "\\   " st)
    st))

(defvar theme-d-mode-abbrev-table nil)
(define-abbrev-table 'theme-d-mode-abbrev-table ())

(defvar theme-d-imenu-generic-expression
      '((nil
	 "^(define\\(\\|-\\(generic\\(\\|-procedure\\)\\|method\\)\\)*\\s-+(?\\(\\sw+\\)" 4)
	("Types"
	 "^(define-class\\s-+(?\\(\\sw+\\)" 1)
	("Macros"
	 "^(\\(defmacro\\|define-macro\\|define-syntax\\)\\s-+(?\\(\\sw+\\)" 2))
  "Imenu generic expression for Theme-D mode.  See `imenu-generic-expression'.")

(defun theme-d-mode-variables ()
  (set-syntax-table theme-d-mode-syntax-table)
  (setq local-abbrev-table theme-d-mode-abbrev-table)
  (make-local-variable 'paragraph-start)
  (setq paragraph-start (concat "$\\|" page-delimiter))
  (make-local-variable 'paragraph-separate)
  (setq paragraph-separate paragraph-start)
  (make-local-variable 'paragraph-ignore-fill-prefix)
  (setq paragraph-ignore-fill-prefix t)
  (make-local-variable 'fill-paragraph-function)
  (setq fill-paragraph-function 'lisp-fill-paragraph)
  ;; Adaptive fill mode gets in the way of auto-fill,
  ;; and should make no difference for explicit fill
  ;; because lisp-fill-paragraph should do the job.
  (make-local-variable 'adaptive-fill-mode)
  (setq adaptive-fill-mode nil)
  (make-local-variable 'indent-line-function)
  (setq indent-line-function 'lisp-indent-line)
  (make-local-variable 'parse-sexp-ignore-comments)
  (setq parse-sexp-ignore-comments t)
  (make-local-variable 'outline-regexp)
  (setq outline-regexp ";;; \\|(....")
  (make-local-variable 'comment-start)
  (setq comment-start ";")
  (set (make-local-variable 'comment-add) 1)
  (make-local-variable 'comment-start-skip)
  ;; Look within the line for a ; following an even number of backslashes
  ;; after either a non-backslash or the line beginning.
  (setq comment-start-skip "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+[ \t]*")
  (set (make-local-variable 'font-lock-comment-start-skip) ";+ *")
  (make-local-variable 'comment-column)
  (setq comment-column 40)
  (make-local-variable 'parse-sexp-ignore-comments)
  (setq parse-sexp-ignore-comments t)
  (make-local-variable 'lisp-indent-function)
  (setq lisp-indent-function 'theme-d-indent-function)
  (setq mode-line-process '("" theme-d-mode-line-process))
  (set (make-local-variable 'imenu-case-fold-search) t)
  (setq imenu-generic-expression theme-d-imenu-generic-expression)
  (set (make-local-variable 'imenu-syntax-alist)
	'(("+-*/.<>=?!$%_&~^:" . "w")))
  (set (make-local-variable 'font-lock-defaults)
       '((theme-d-font-lock-keywords
          theme-d-font-lock-keywords-1 theme-d-font-lock-keywords-2)
         nil t (("+-*/.<>=!?$%_&~^:" . "w") (?#. "w 14"))
         beginning-of-defun
         (font-lock-mark-block-function . mark-defun)
         (font-lock-syntactic-face-function
          . theme-d-font-lock-syntactic-face-function)
         (parse-sexp-lookup-properties . t)
         (font-lock-extra-managed-props syntax-table)))
  (set (make-local-variable 'lisp-doc-string-elt-property)
       'theme-d-doc-string-elt))

(defvar theme-d-mode-line-process "")

(defvar theme-d-mode-map
  (let ((smap (make-sparse-keymap))
	(map (make-sparse-keymap "Scheme")))
    (set-keymap-parent smap lisp-mode-shared-map)
    (define-key smap [menu-bar scheme] (cons "Scheme" map))
    (define-key map [run-scheme] '("Run Inferior Scheme" . run-scheme))
    (define-key map [uncomment-region]
      '("Uncomment Out Region" . (lambda (beg end)
                                   (interactive "r")
                                   (comment-region beg end '(4)))))
    (define-key map [comment-region] '("Comment Out Region" . comment-region))
    (define-key map [indent-region] '("Indent Region" . indent-region))
    (define-key map [indent-line] '("Indent Line" . lisp-indent-line))
    (put 'comment-region 'menu-enable 'mark-active)
    (put 'uncomment-region 'menu-enable 'mark-active)
    (put 'indent-region 'menu-enable 'mark-active)
    smap)
  "Keymap for Scheme mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")

;; Used by cmuscheme
(defun theme-d-mode-commands (map)
  ;;(define-key map "\t" 'indent-for-tab-command) ; default
  (define-key map "\177" 'backward-delete-char-untabify)
  (define-key map "\e\C-q" 'indent-sexp))

;;;###autoload
(defun theme-d-mode ()
  "Major mode for editing Scheme code.
Editing commands are similar to those of `lisp-mode'.

In addition, if an inferior Scheme process is running, some additional
commands will be defined, for evaluating expressions and controlling
the interpreter, and the state of the process will be displayed in the
modeline of all Scheme buffers.  The names of commands that interact
with the Scheme process start with \"xscheme-\" if you use the MIT
Scheme-specific `xscheme' package; for more information see the
documentation for `xscheme-interaction-mode'.  Use \\[run-scheme] to
start an inferior Scheme using the more general `cmuscheme' package.

Commands:
Delete converts tabs to spaces as it moves back.
Blank lines separate paragraphs.  Semicolons start comments.
\\{theme-d-mode-map}
Entry to this mode calls the value of `theme-d-mode-hook'
if that value is non-nil."
  (interactive)
  (kill-all-local-variables)
  (use-local-map theme-d-mode-map)
  (setq major-mode 'theme-d-mode)
  (setq mode-name "Theme-D")
  (theme-d-mode-variables)
  (run-mode-hooks 'theme-d-mode-hook))

(defgroup theme-d nil
  "Editing Scheme code."
  :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces)
  :group 'lisp)

(defcustom theme-d-mode-hook nil
  "Normal hook run when entering `theme-d-mode'.
See `run-hooks'."
  :type 'hook
  :group 'theme-d)

(defcustom theme-d-program-name "theme-d"
  "*Program invoked by the `run-scheme' command."
  :type 'string
  :group 'theme-d)

(defconst theme-d-font-lock-keywords-1
  (eval-when-compile
    (list
     (list (concat "(\\(\\(define\\)"
		   "\\|\\(define-mutable\\)"
		   "\\|\\(define-volatile\\)"
		   "\\|\\(define-class\\)"
		   "\\|\\(define-param-class\\)"
		   "\\|\\(define-param-logical-type\\)"
		   "\\|\\(define-simple-method\\)"
		   "\\|\\(define-static-simple-method\\)"
		   "\\|\\(define-param-method\\)"
		   "\\|\\(define-static-param-method\\)"
		   "\\|\\(define-generic-proc\\)"
		   "\\|\\(define-simple-proc\\)"
		   "\\|\\(define-param-proc\\)"
		   "\\|\\(define-param-proc-alt\\)"
		   "\\|\\(define-proper-program\\)"
		   "\\|\\(define-script\\)"
		   "\\|\\(define-interface\\)"
		   "\\|\\(define-body\\)"
		   "\\|\\(define-prim-class\\)"
		   "\\|\\(define-goops-class\\)"
		   "\\|\\(define-normal-goops-class\\)"
		   "\\|\\(define-signature\\)"
		   "\\|\\(define-param-signature\\)"
		   "\\|\\(define-syntax\\)"
		   "\\|\\(declare\\)"
		   "\\|\\(declare-method\\)"
		   "\\|\\(declare-static-method\\)"
		   "\\|\\(declare-mutable\\)"
		   "\\|\\(declare-volatile\\)"
		   "\\|\\(add-method\\)"
		   "\\|\\(add-static-method\\)\\)"
		   "\\>"
		   ;; Any whitespace and declared object.
		   "[ \t]*(?"
		   "\\(\\sw+\\)?")
	   '(1 font-lock-keyword-face)
	   '(15 (cond ((match-beginning 3) font-lock-function-name-face)
		      ((match-beginning 5) font-lock-variable-name-face)
		      (t font-lock-type-face))
	       nil t))
     ))
  "Subdued expressions to highlight in Scheme modes.")


(defconst theme-d-font-lock-keywords-2
  (append theme-d-font-lock-keywords-1
   (eval-when-compile
     (list
      ;;
      ;; Control structures.
      (cons
       (concat
	"(" (regexp-opt
	     '(
;;	       "add-method"
	       "and" "begin"
	       "call-with-current-continuation"
	       "call/cc"
	       "call-with-current-continuation-nonpure"
	       "call/cc-nonpure"
	       "call-with-current-continuation-without-result"
	       "call/cc-without-result"
;;	       "call-with-input-file" "call-with-output-file"
	       "case" "case-objects" "case-contents"
	       "cast"
	       "cast-mutable-value-vector"
	       "cast-mutable-value-vector-metaclass"
	       "cast-mutable-vector"
	       "cast-mutable-vector-metaclass"
	       "cast-value-vector"
	       "cast-value-vector-metaclass"
	       "cast-vector"
	       "cast-vector-metaclass"
	       "cond"
	       "constructor"
;;	       "declare" "declare-method"
;;	       "delay"
	       "do" "else"
	       "exec/cc"
	       "execute-with-current-continuation"
	       "exec/cc-nonpure"
	       "execute-with-current-continuation-nonpure"
	       "exec/cc-without-result"
	       "execute-with-current-continuation-without-result"
	       "field-set!" "field-ref"
;;	       "force"
	       "force-pure-expr"
	       "generic-proc-dispatch"
	       "generic-proc-dispatch-without-result"
	       "guard" "guard-general"
	       "guard-nonpure" "guard-general-nonpure"
	       "guard-without-result" "guard-general-without-result"
	       "if"
	       "import" "import-and-reexport"
	       "join-tuple-types"
	       "lambda"
	       "lambda-automatic"
	       "let" "let*" "letrec" "letrec*"
	       "let-mutable" "let*-mutable" "letrec-mutable" "letrec*-mutable"
	       "let-volatile" "let*-volatile" "letrec-volatile" "letrec*-volatile"
	       ;; SRFI 11 usage comes up often enough.
;;	       "let-values" "let*-values"
	       "make"
	       "match-type"
	       "match-type-strong"
	       "or"
	       "param-lambda"
	       "param-lambda-automatic"
	       "param-prim-proc"
	       "param-proc-cond-appl"
	       "param-proc-instance" "param-proc-dispatch"
	       "prelink-body"
	       "prevent-stripping"
	       "prim-proc" "raise" "reexport" "rest" "set!" "splice"
	       "quasiquote" "quote"
	       "static-cast"
	       "static-type-of"
	       "syntax" "syntax-case" "syntax-rules"
	       "this" "try-cast" "type-loop"
	       "unchecked-param-prim-proc"
	       "unchecked-prim-proc" "until"
	       "unquote" "unquote-splicing"
	       "use"
	       "if-object" "cond-object" "and-object" "or-object"
	       ) t)
	"\\>") 1)
      ;;
      ;; It wouldn't be Scheme w/o named-let.
      ;; Commented out by TH.
;;      '("(let\\s-+\\(\\sw+\\)"
;;        (1 font-lock-function-name-face))
      ;;
      ;; David Fox <fox@graphics.cs.nyu.edu> for SOS/STklos class specifiers.
      '("\\<<\\sw+>\\>" . font-lock-type-face)
      ;;
      ;; Scheme `:' and `#:' keywords as builtins.
      '("\\<#?:\\sw+\\>" . font-lock-builtin-face)
      )))
   "Gaudy expressions to highlight in Scheme modes.")

(defvar theme-d-font-lock-keywords theme-d-font-lock-keywords-1
  "Default expressions to highlight in Theme-D mode.")

(defconst theme-d-sexp-comment-syntax-table
  (let ((st (make-syntax-table theme-d-mode-syntax-table)))
    (modify-syntax-entry ?\; "." st)
    (modify-syntax-entry ?\n " " st)
    (modify-syntax-entry ?#  "'" st)
    st))

(put 'lambda 'scheme-doc-string-elt 2)
;; Docstring's pos in a `define' depends on whether it's a var or fun def.
(put 'define 'scheme-doc-string-elt
     (lambda ()
       ;; The function is called with point right after "define".
       (forward-comment (point-max))
       (if (eq (char-after) ?\() 2 0)))

(defun theme-d-font-lock-syntactic-face-function (state)
  (when (and (null (nth 3 state))
             (eq (char-after (nth 8 state)) ?#)
             (eq (char-after (1+ (nth 8 state))) ?\;))
    ;; It's a sexp-comment.  Tell parse-partial-sexp where it ends.
    (save-excursion
      (let ((pos (point))
            (end
             (condition-case err
                 (let ((parse-sexp-lookup-properties nil))
                   (goto-char (+ 2 (nth 8 state)))
                   ;; FIXME: this doesn't handle the case where the sexp
                   ;; itself contains a #; comment.
                   (forward-sexp 1)
                   (point))
               (scan-error (nth 2 err)))))
        (when (< pos (- end 2))
          (put-text-property pos (- end 2)
                             'syntax-table theme-d-sexp-comment-syntax-table))
        (put-text-property (- end 1) end 'syntax-table '(12)))))
  ;; Choose the face to use.
  (lisp-font-lock-syntactic-face-function state))


(defvar calculate-lisp-indent-last-sexp)

;; Copied from lisp-indent-function, but with gets of
;; scheme-indent-{function,hook}.
(defun theme-d-indent-function (indent-point state)
  (let ((normal-indent (current-column)))
    (goto-char (1+ (elt state 1)))
    (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t)
    (if (and (elt state 2)
             (not (looking-at "\\sw\\|\\s_")))
        ;; car of form doesn't seem to be a symbol
        (progn
          (if (not (> (save-excursion (forward-line 1) (point))
                      calculate-lisp-indent-last-sexp))
              (progn (goto-char calculate-lisp-indent-last-sexp)
                     (beginning-of-line)
                     (parse-partial-sexp (point)
					 calculate-lisp-indent-last-sexp 0 t)))
          ;; Indent under the list or under the first sexp on the same
          ;; line as calculate-lisp-indent-last-sexp.  Note that first
          ;; thing on that line has to be complete sexp since we are
          ;; inside the innermost containing sexp.
          (backward-prefix-chars)
          (current-column))
      (let ((function (buffer-substring (point)
					(progn (forward-sexp 1) (point))))
	    method)
	(setq method (or (get (intern-soft function) 'theme-d-indent-function)
			 (get (intern-soft function) 'theme-d-indent-hook)))
	(cond ((or (eq method 'defun)
		   (and (null method)
			(> (length function) 3)
			(string-match "\\`def" function)))
	       (lisp-indent-defform state indent-point))
	      ((integerp method)
	       (lisp-indent-specform method state
				     indent-point normal-indent))
	      (method
		(funcall method state indent-point normal-indent)))))))


;;; Let is different in Scheme

(defun would-be-symbol (string)
  (not (string-equal (substring string 0 1) "(")))

(defun next-sexp-as-string ()
  ;; Assumes that it is protected by a save-excursion
  (forward-sexp 1)
  (let ((the-end (point)))
    (backward-sexp 1)
    (buffer-substring (point) the-end)))

;; This is correct but too slow.
;; The one below works almost always.
;;(defun scheme-let-indent (state indent-point)
;;  (if (would-be-symbol (next-sexp-as-string))
;;      (scheme-indent-specform 2 state indent-point)
;;      (scheme-indent-specform 1 state indent-point)))

(defun theme-d-let-indent (state indent-point normal-indent)
  (skip-chars-forward " \t")
  (if (looking-at "[-a-zA-Z0-9+*/?!@$%^&_:~]")
      (lisp-indent-specform 2 state indent-point normal-indent)
    (lisp-indent-specform 1 state indent-point normal-indent)))

;; (put 'begin 'theme-d-indent-function 0), say, causes begin to be indented
;; like defun if the first form is placed on the next line, otherwise
;; it is indented like any other form (i.e. forms line up under first).

(put '$define 'theme-d-indent-function 1)
(put '$lambda 'theme-d-indent-function 1)
(put '$let 'theme-d-indent-function 'theme-d-let-indent)
(put 'begin 'theme-d-indent-function 0)
(put 'case 'theme-d-indent-function 1)
;; (put 'delay 'theme-d-indent-function 0)
(put 'define-simple-method 'theme-d-indent-function 2)
(put 'define-simple-proc 'theme-d-indent-function 2)
(put 'define-param-proc 'theme-d-indent-function 3)
(put 'define-param-method 'theme-d-indent-function 3)
(put 'define-signature 'theme-d-indent-function 2)
(put 'define-param-signature 'theme-d-indent-function 3)
(put 'do 'theme-d-indent-function 2)
(put 'exec/cc 'theme-d-indent-function 2)
(put 'lambda 'theme-d-indent-function 1)
(put 'let 'theme-d-indent-function 'theme-d-let-indent)
(put 'let* 'theme-d-indent-function 1)
(put 'letrec 'theme-d-indent-function 1)
(put 'letrec* 'theme-d-indent-function 1)
(put 'let-mutable 'theme-d-indent-function 'theme-d-let-indent)
(put 'let*-mutable 'theme-d-indent-function 1)
(put 'letrec-mutable 'theme-d-indent-function 1)
(put 'letrec*-mutable 'theme-d-indent-function 1)
(put 'let-volatile 'theme-d-indent-function 'theme-d-let-indent)
(put 'let*-volatile 'theme-d-indent-function 1)
(put 'letrec-volatile 'theme-d-indent-function 1)
(put 'letrec*-volatile 'theme-d-indent-function 1)
(put 'match-type 'theme-d-indent-function 1)
(put 'match-type-strong 'theme-d-indent-function 1)
(put 'guard-general 'theme-d-indent-function 1)
(put 'param-lambda 'theme-d-indent-function 2)
(put 'syntax-case 'theme-d-indent-function 2)
(put 'syntax-rules 'theme-d-indent-function 1)
(put 'until 'theme-d-indent-function 1)

;; (put 'let-values 'theme-d-indent-function 1) ; SRFI 11
;; (put 'let*-values 'theme-d-indent-function 1) ; SRFI 11
;; (put 'sequence 'theme-d-indent-function 0) ; SICP, not r4rs
;; (put 'let-syntax 'theme-d-indent-function 1)
;; (put 'letrec-syntax 'theme-d-indent-function 1)
;; (put 'syntax-rules 'theme-d-indent-function 1)
;; (put 'syntax-case 'theme-d-indent-function 2) ; not r5rs

;; (put 'call-with-input-file 'theme-d-indent-function 1)
;; (put 'with-input-from-file 'theme-d-indent-function 1)
;; (put 'with-input-from-port 'theme-d-indent-function 1)
;; (put 'call-with-output-file 'theme-d-indent-function 1)
;; (put 'with-output-to-file 'theme-d-indent-function 1)
;; (put 'with-output-to-port 'theme-d-indent-function 1)
;; (put 'call-with-values 'theme-d-indent-function 1) ; r5rs?
;; (put 'dynamic-wind 'theme-d-indent-function 3) ; r5rs?


(provide 'theme-d)

;; arch-tag: a8f06bc1-ad11-42d2-9e36-ce651df37a90
;;; scheme.el ends here
