al-scheme.el 6.1 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156
  1. ;;; al-scheme.el --- Additional functionality for `scheme-mode'
  2. ;; Copyright © 2015–2017 Alex Kost
  3. ;; This program is free software; you can redistribute it and/or modify
  4. ;; it under the terms of the GNU General Public License as published by
  5. ;; the Free Software Foundation, either version 3 of the License, or
  6. ;; (at your option) any later version.
  7. ;;
  8. ;; This program is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. ;; GNU General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU General Public License
  14. ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
  15. ;;; Code:
  16. (defvar al/scheme-imenu-generic-expression
  17. `((nil
  18. ,(rx bol "(define"
  19. (zero-or-one "*")
  20. (zero-or-one "-public")
  21. (one-or-more space)
  22. (zero-or-one "(")
  23. (group (one-or-more (or word (syntax symbol)))))
  24. 1)
  25. ("Methods"
  26. ,(rx bol "(define-"
  27. (or "generic" "method" "accessor")
  28. (one-or-more space)
  29. (zero-or-one "(")
  30. (group (one-or-more (or word (syntax symbol)))))
  31. 1)
  32. ("Classes"
  33. ,(rx bol "(define-class"
  34. (one-or-more space)
  35. (zero-or-one "(")
  36. (group (one-or-more (or word (syntax symbol)))))
  37. 1)
  38. ("Records"
  39. ,(rx bol "(define-record-type"
  40. (zero-or-one "*")
  41. (one-or-more space)
  42. (group (one-or-more (or word (syntax symbol)))))
  43. 1)
  44. ("Conditions"
  45. ,(rx bol "(define-condition-type"
  46. (one-or-more space)
  47. (group (one-or-more (or word (syntax symbol)))))
  48. 1)
  49. ("Modules"
  50. ,(rx bol "(define-module"
  51. (one-or-more space)
  52. (group "(" (one-or-more any) ")"))
  53. 1)
  54. ("Macros"
  55. ,(rx bol "("
  56. (or (and "defmacro"
  57. (zero-or-one "*")
  58. (zero-or-one "-public"))
  59. "define-macro" "define-syntax" "define-syntax-rule")
  60. (one-or-more space)
  61. (zero-or-one "(")
  62. (group (one-or-more (or word (syntax symbol)))))
  63. 1))
  64. "Improved substitution for `scheme-imenu-generic-expression'.")
  65. (defvar calculate-lisp-indent-last-sexp)
  66. ;; The following code of `al/scheme-indent-function' originates from
  67. ;; <http://www.netris.org/~mhw/scheme-indent-function.el>.
  68. (defun al/scheme-indent-function (indent-point state)
  69. "Scheme mode function for the value of the variable `lisp-indent-function'.
  70. This function is the same as `scheme-indent-function' except it
  71. indents property lists properly and names starting with 'default'."
  72. (let ((normal-indent (current-column)))
  73. (goto-char (1+ (elt state 1)))
  74. (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t)
  75. (if (and (elt state 2)
  76. (not (looking-at "\\sw\\|\\s_")))
  77. ;; car of form doesn't seem to be a symbol
  78. (progn
  79. (if (not (> (save-excursion (forward-line 1) (point))
  80. calculate-lisp-indent-last-sexp))
  81. (progn (goto-char calculate-lisp-indent-last-sexp)
  82. (beginning-of-line)
  83. (parse-partial-sexp (point)
  84. calculate-lisp-indent-last-sexp 0 t)))
  85. ;; Indent under the list or under the first sexp on the same
  86. ;; line as calculate-lisp-indent-last-sexp. Note that first
  87. ;; thing on that line has to be complete sexp since we are
  88. ;; inside the innermost containing sexp.
  89. (backward-prefix-chars)
  90. (current-column))
  91. (let ((function (buffer-substring (point)
  92. (progn (forward-sexp 1) (point))))
  93. method)
  94. (setq method (or (get (intern-soft function) 'scheme-indent-function)
  95. (get (intern-soft function) 'scheme-indent-hook)))
  96. (cond ((or (eq method 'defun)
  97. (and (null method)
  98. (> (length function) 3)
  99. ;; The original regexp is "\\`def" but it will
  100. ;; mess indentation with such names as
  101. ;; 'default-...'.
  102. (string-match "\\`define" function)))
  103. (lisp-indent-defform state indent-point))
  104. ;; This next cond clause is the only change -mhw
  105. ((and (null method)
  106. (> (length function) 1)
  107. ;; The '#' in '#:' seems to get lost, not sure why
  108. (string-match "\\`:" function))
  109. (let ((lisp-body-indent 1))
  110. (lisp-indent-defform state indent-point)))
  111. ((integerp method)
  112. (lisp-indent-specform method state
  113. indent-point normal-indent))
  114. (method
  115. (funcall method state indent-point normal-indent)))))))
  116. ;;; Docstrings highlighting
  117. ;; Although `scheme-mode' has all the functionality to highlight
  118. ;; docstrings properly (with `font-lock-doc-face', not with
  119. ;; `font-lock-string-face'!), it doesn't do it. The only missing thing
  120. ;; needed to fix it, is setting `font-lock-syntactic-face-function'.
  121. ;; XXX This is definitely an Emacs bug, and I should report about it! I
  122. ;; think it was introduced by
  123. ;; <http://git.savannah.gnu.org/cgit/emacs.git/commit/?id=0a5cfeeecb9e1038f9df3b34b61b797e56213a7b>.
  124. ;; Another miss is that "scheme.el" contains "docstring rules" only for
  125. ;; `define' and `lambda*', while there are other things to highlight:
  126. (put 'define* 'scheme-doc-string-elt 2)
  127. (put 'lambda* 'scheme-doc-string-elt 2)
  128. (put 'case-lambda 'scheme-doc-string-elt 1)
  129. (put 'case-lambda* 'scheme-doc-string-elt 1)
  130. (put 'define-syntax-rule 'scheme-doc-string-elt 2)
  131. (put 'syntax-rules 'scheme-doc-string-elt 2)
  132. (defun al/scheme-fix-docstring-font-lock ()
  133. "Fix highlighting of the Scheme docstrings.
  134. This function is intended to be added to `scheme-mode-hook'."
  135. (setq-local font-lock-syntactic-face-function
  136. 'lisp-font-lock-syntactic-face-function))
  137. (provide 'al-scheme)
  138. ;;; al-scheme.el ends here