855 lines
32 KiB
EmacsLisp
855 lines
32 KiB
EmacsLisp
;;; sclang-language.el --- IDE for working with SuperCollider -*- coding: utf-8;
|
|
;;
|
|
;; Copyright 2003 stefan kersten <steve@k-hornz.de>
|
|
|
|
;;; License:
|
|
|
|
;; 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 2 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, write to the Free Software
|
|
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
|
|
;; USA
|
|
|
|
|
|
;;; Commentary:
|
|
;; Utilities for SuperCollider syntax
|
|
|
|
(require 'cl-lib)
|
|
(require 'sclang-browser)
|
|
(require 'sclang-interp)
|
|
(require 'sclang-util)
|
|
|
|
;; ===================================================================
|
|
;; regexp utilities
|
|
;; ===================================================================
|
|
|
|
;;; Code:
|
|
|
|
(defun sclang-regexp-group (regexp &optional addressable)
|
|
"Enclose REGEXP in grouping parentheses.
|
|
|
|
If ADDRESSABLE is non-nil the group match data can be addressed
|
|
separately after matching."
|
|
(concat "\\(" (unless addressable "?:") regexp "\\)"))
|
|
|
|
(defun sclang-regexp-concat (&rest regexps)
|
|
"Concatenate REGEXPS by grouping.
|
|
|
|
The expressions are joined as alternatives with the \\| operator."
|
|
(mapconcat 'sclang-regexp-group regexps "\\|"))
|
|
|
|
;; ===================================================================
|
|
;; some useful regular expressions
|
|
;; ===================================================================
|
|
|
|
(defconst sclang-symbol-regexp
|
|
"\\(?:\\sw\\|\\s_\\)*"
|
|
"Regular expression matching symbols.")
|
|
|
|
(defconst sclang-identifier-regexp
|
|
(concat "[a-zA-Z]" sclang-symbol-regexp)
|
|
"Regular expression matching valid identifiers.")
|
|
|
|
(defconst sclang-method-name-special-chars
|
|
"-!%&*+/<=>?@|"
|
|
"Regular expression matching special method name characters.")
|
|
|
|
(defconst sclang-method-name-plain-regexp
|
|
(concat sclang-identifier-regexp "_?")
|
|
"Regular expression matching regular method names.")
|
|
|
|
(defconst sclang-method-name-special-regexp
|
|
(concat
|
|
"[" (regexp-quote sclang-method-name-special-chars) "]+")
|
|
"Regular expression matching method names composed of special characters.")
|
|
|
|
(defconst sclang-method-name-regexp
|
|
(sclang-regexp-concat
|
|
sclang-method-name-special-regexp
|
|
sclang-method-name-plain-regexp)
|
|
"Regular expression matching method names.")
|
|
|
|
(defconst sclang-class-name-regexp
|
|
"\\<\\(?:Meta_\\)?[A-Z]\\(?:\\sw\\|\\s_\\)*"
|
|
"Regular expression matching class names.")
|
|
|
|
(defconst sclang-primitive-name-regexp
|
|
(concat "_[A-Z]" sclang-symbol-regexp)
|
|
"Regular expression matching primitive names.")
|
|
|
|
(defconst sclang-symbol-name-regexp
|
|
(sclang-regexp-concat
|
|
sclang-method-name-regexp
|
|
sclang-class-name-regexp)
|
|
"Regular expression matching class and method names.")
|
|
|
|
(defconst sclang-class-definition-regexp
|
|
(concat "^\\s *\\("
|
|
sclang-class-name-regexp
|
|
"\\)\\(?:\\s *:\\s *\\("
|
|
sclang-class-name-regexp
|
|
"\\)\\)?[[:space:]]*{")
|
|
"Regular expression matching class definitions.")
|
|
|
|
(defconst sclang-method-definition-regexp
|
|
(concat "^\\s *\\*?\\(" sclang-method-name-regexp "\\)\\s *{")
|
|
"Regular expression matching method definitions.")
|
|
|
|
(defconst sclang-block-regexp
|
|
"^\\((\\)\\s *\\(?:/[/*]?.*\\)?"
|
|
"Regular expression matching the beginning of a code block.
|
|
|
|
A block is enclosed by parentheses where the opening parenthesis must
|
|
be at the beginning of a line to avoid ambiguities.")
|
|
|
|
(defconst sclang-beginning-of-defun-regexp
|
|
(sclang-regexp-concat
|
|
sclang-class-definition-regexp
|
|
sclang-block-regexp)
|
|
"Regular expression matching the beginning of defuns.
|
|
|
|
The match is either the start of a class definition
|
|
\(`sclang-class-definition-regexp') or the beginning of a code block
|
|
enclosed by parenthesis (`sclang-block-regexp').")
|
|
|
|
(defconst sclang-method-definition-spec-regexp
|
|
(concat (sclang-regexp-group sclang-class-name-regexp t)
|
|
"-"
|
|
(sclang-regexp-group sclang-method-name-regexp t))
|
|
"Regular expression matching definition specifications.
|
|
|
|
A specification is of the form <class-name>-<method-name>.")
|
|
|
|
;; ===================================================================
|
|
;; regexp building
|
|
;; ===================================================================
|
|
|
|
(defun sclang-make-class-definition-regexp (name)
|
|
"Return a regular expression matching the class definition NAME."
|
|
(concat "\\(" (regexp-quote name) "\\)"
|
|
"\\(?:\\s *:\\s *\\(" sclang-class-name-regexp "\\)\\)?"
|
|
"[[:space:]]*{"))
|
|
|
|
(defun sclang-make-class-extension-regexp (name)
|
|
"Return a regular expression matching the class extension NAME."
|
|
(concat "\\+\\s *\\(" (regexp-quote name) "\\)"
|
|
"\\s *{"))
|
|
|
|
(defun sclang-make-method-definition-regexp (name)
|
|
"Return a regular expression matching the method definition NAME."
|
|
(concat "\\(" (regexp-quote name) "\\)\\s *{"))
|
|
|
|
;; ===================================================================
|
|
;; string matching
|
|
;; ===================================================================
|
|
|
|
(defun sclang-string-match (regexp string)
|
|
"Match REGEXP with STRING while preserving case."
|
|
(let ((case-fold-search nil))
|
|
(string-match regexp string)))
|
|
|
|
(defun sclang-symbol-match (symbol-regexp string)
|
|
"Match SYMBOL-REGEXP in STRING."
|
|
(sclang-string-match (concat "^" symbol-regexp "$") string))
|
|
|
|
;; ===================================================================
|
|
;; symbol name predicates
|
|
;; ===================================================================
|
|
|
|
(defun sclang-class-name-p (string)
|
|
"Is STRING an sclang class name?"
|
|
(sclang-symbol-match sclang-class-name-regexp string))
|
|
|
|
(defun sclang-meta-class-name-p (string)
|
|
"Is STRING an sclang meta class name?"
|
|
(and (sclang-class-name-p string)
|
|
(sclang-string-match "^Meta_" string)))
|
|
|
|
(defun sclang-method-name-p (string)
|
|
"Is STRING an sclang method name?"
|
|
(sclang-symbol-match sclang-method-name-regexp string))
|
|
|
|
(defun sclang-symbol-name-p (string)
|
|
"Is STRING an sclang symbol name?"
|
|
(sclang-symbol-match sclang-symbol-name-regexp string))
|
|
|
|
(defun sclang-method-name-setter-p (method-name)
|
|
"Is METHOD-NAME an sclang method name setter?"
|
|
(string-match "_$" method-name))
|
|
|
|
(defun sclang-method-name-getter-p (method-name)
|
|
"Is METHOD-NAME an sclang method name getter?"
|
|
(not (sclang-method-name-setter-p method-name)))
|
|
|
|
;; ===================================================================
|
|
;; symbol name manipulation
|
|
;; ===================================================================
|
|
|
|
(defun sclang-method-name-setter (method-name)
|
|
"Return a method name setter for METHOD-NAME."
|
|
(if (sclang-method-name-setter-p method-name)
|
|
method-name
|
|
(concat method-name "_")))
|
|
|
|
(defun sclang-method-name-getter (method-name)
|
|
"Return a method name getter for METHOD-NAME."
|
|
(if (sclang-method-name-setter-p method-name)
|
|
(substring method-name 0 (1- (length method-name)))
|
|
method-name))
|
|
|
|
;; ===================================================================
|
|
;; symbol table access
|
|
;; ===================================================================
|
|
|
|
(defcustom sclang-use-symbol-table t
|
|
"*Retrieve symbol table upon library initialization.
|
|
|
|
Symbol table retrieval is performed each time the library is
|
|
recompiled. This takes some time and the symbol table has to be held
|
|
in memory, so it might be necessary to disable this option on
|
|
low-resource systems."
|
|
:group 'sclang-interface
|
|
:version "21.3"
|
|
:type 'boolean)
|
|
|
|
(defvar sclang-symbol-table nil
|
|
"List of all defined symbols.")
|
|
|
|
(defvar sclang-class-list nil
|
|
"List of all defined classes.")
|
|
|
|
(defvar sclang-symbol-history nil
|
|
"List of recent symbols read from the minibuffer.")
|
|
|
|
(defvar sclang-symbol-table-file nil)
|
|
|
|
(sclang-set-command-handler
|
|
'symbolTable
|
|
(lambda (arg)
|
|
(when (and sclang-use-symbol-table arg)
|
|
(setq sclang-symbol-table (sort arg 'string-lessp))
|
|
(setq sclang-class-list (cl-remove-if
|
|
(lambda (x) (or (not (sclang-class-name-p x))
|
|
(sclang-string-match "^Meta_" x)))
|
|
sclang-symbol-table))
|
|
(sclang-update-font-lock))))
|
|
|
|
(add-hook 'sclang-library-startup-hook
|
|
(lambda ()
|
|
(when sclang-use-symbol-table
|
|
(let ((file (make-temp-file "sclang-symbol-table.")))
|
|
(when (and file (file-exists-p file))
|
|
(setq sclang-symbol-table-file file)
|
|
(sclang-perform-command 'symbolTable file))))))
|
|
|
|
(add-hook 'sclang-library-shutdown-hook
|
|
(lambda ()
|
|
(setq sclang-symbol-table nil)
|
|
(sclang-update-font-lock)))
|
|
|
|
(defun sclang-get-symbol-completion-table ()
|
|
"Get symbol completion table."
|
|
(mapcar (lambda (s) (cons s nil)) sclang-symbol-table))
|
|
|
|
(defun sclang-make-symbol-completion-predicate (predicate)
|
|
"Make symbol completion PREDICATE."
|
|
(and predicate (lambda (assoc) (funcall predicate (car assoc)))))
|
|
|
|
(defun sclang-get-symbol (string)
|
|
"Get symbol named STRING."
|
|
(if (and sclang-use-symbol-table sclang-symbol-table)
|
|
(car (member string sclang-symbol-table))
|
|
string))
|
|
|
|
(defun sclang-read-symbol (prompt &optional default predicate require-match inherit-input-method)
|
|
"Read symbol PROMPT (options DEFAULT PREDICATE REQUIRE-MATCH and INHERIT-INPUT-METHOD)."
|
|
(if sclang-use-symbol-table
|
|
(cl-flet ((make-minibuffer-local-map
|
|
(parent-keymap)
|
|
(let ((map (make-sparse-keymap)))
|
|
(set-keymap-parent map parent-keymap)
|
|
;; override keys bound to valid symbols
|
|
(define-key map [??] 'self-insert-command)
|
|
map)))
|
|
(let ((symbol (sclang-get-symbol default))
|
|
(minibuffer-local-completion-map (make-minibuffer-local-map
|
|
minibuffer-local-completion-map))
|
|
(minibuffer-local-must-match-map (make-minibuffer-local-map
|
|
minibuffer-local-completion-map)))
|
|
(completing-read (sclang-make-prompt-string prompt symbol)
|
|
(sclang-get-symbol-completion-table)
|
|
(sclang-make-symbol-completion-predicate predicate)
|
|
require-match nil
|
|
'sclang-symbol-history symbol
|
|
inherit-input-method)))
|
|
(read-string (sclang-make-prompt-string prompt default) nil
|
|
'sclang-symbol-history default inherit-input-method)))
|
|
|
|
;; ===================================================================
|
|
;; buffer movement
|
|
;; ===================================================================
|
|
|
|
(defun sclang-point-in-comment-p ()
|
|
"Return non-nil if point is inside a comment."
|
|
(if (and (boundp 'font-lock-mode) (eval 'font-lock-mode))
|
|
;; use available information in font-lock-mode
|
|
(eq (get-text-property (point) 'face) 'font-lock-comment-face)
|
|
;; else parse from the beginning
|
|
(save-excursion
|
|
(let ((beg (point)))
|
|
(beginning-of-defun)
|
|
(not (null (nth 4 (parse-partial-sexp (point) beg))))))))
|
|
|
|
(defun sclang-beginning-of-defun (&optional arg)
|
|
"Move to beginning of function (optionally ARG)."
|
|
(interactive "p")
|
|
(let ((case-fold-search nil)
|
|
(arg (or arg (prefix-numeric-value current-prefix-arg)))
|
|
(orig (point))
|
|
(success t))
|
|
(while (and success (> arg 0))
|
|
(setq success (re-search-backward sclang-beginning-of-defun-regexp
|
|
nil 'move))
|
|
(when (and success (not (sclang-point-in-comment-p)))
|
|
(goto-char (match-beginning 0))
|
|
(setq arg (1- arg))))
|
|
(while (and success (< arg 0))
|
|
(setq success (re-search-forward sclang-beginning-of-defun-regexp nil t))
|
|
(when (and success (not (sclang-point-in-comment-p)))
|
|
(goto-char (match-end 0))
|
|
(setq arg (1+ arg))))
|
|
(when success
|
|
(beginning-of-line)
|
|
(cond ((looking-at sclang-block-regexp) (goto-char (1- (match-end 1))))
|
|
((looking-at sclang-class-definition-regexp) (goto-char (1- (match-end 0)))))
|
|
t)))
|
|
|
|
(defun sclang-point-in-defun-p ()
|
|
"Return non-nil if point is inside a defun.
|
|
Return value is nil or (beg end) of defun."
|
|
(save-excursion
|
|
(let ((orig (point))
|
|
beg end)
|
|
(and (progn (end-of-line) (beginning-of-defun-raw 1) t)
|
|
(setq beg (point))
|
|
(condition-case nil (forward-list 1) (error nil))
|
|
(setq end (point))
|
|
(list beg end)))))
|
|
|
|
(defun sclang-end-of-defun (&optional arg)
|
|
"Move to end of function (optionally ARG)."
|
|
(interactive "p")
|
|
(let ((case-fold-search nil)
|
|
(arg (or arg (prefix-numeric-value current-prefix-arg)))
|
|
(success t)
|
|
n cur)
|
|
(while (and success (> arg 0))
|
|
(setq n (if (sclang-point-in-defun-p) 1 -1))
|
|
(setq cur (point))
|
|
(if (and (sclang-beginning-of-defun n)
|
|
(condition-case nil (forward-list 1) (error nil)))
|
|
(progn
|
|
(setq arg (1- arg)))
|
|
(goto-char cur)
|
|
(setq success nil)))
|
|
(while (and success (< arg 0))
|
|
(setq n (if (sclang-point-in-defun-p) 2 1))
|
|
(setq cur (point))
|
|
(if (and (sclang-beginning-of-defun n)
|
|
(condition-case nil (forward-list 1) (error nil)))
|
|
(progn
|
|
(backward-char 1)
|
|
(setq arg (1+ arg)))
|
|
(goto-char cur)
|
|
(setq success nil)))
|
|
(when success
|
|
(forward-line 1) t)))
|
|
|
|
;; ===================================================================
|
|
;; buffer object access
|
|
;; ===================================================================
|
|
|
|
(defun sclang-symbol-at-point (&optional symbol-name-regexp)
|
|
"Return the symbol at point, or nil if not a valid symbol.
|
|
|
|
The argument SYMBOL-NAME-REGEXP can be used to specify the type of
|
|
symbol matched, candidates are `sclang-symbol-name-regexp' and
|
|
`sclang-primitive-name-regexp', the default is
|
|
`sclang-symbol-name-regexp'."
|
|
(save-excursion
|
|
(with-syntax-table sclang-mode-syntax-table
|
|
(let ((case-fold-search nil)
|
|
beg end)
|
|
(cond ((looking-at sclang-method-name-special-regexp)
|
|
(skip-chars-backward sclang-method-name-special-chars)
|
|
(setq beg (point))
|
|
(skip-chars-forward sclang-method-name-special-chars)
|
|
(setq end (point)))
|
|
(t
|
|
(skip-syntax-backward "w_")
|
|
(setq beg (point))
|
|
(skip-syntax-forward "w_")
|
|
(setq end (point))))
|
|
(goto-char beg)
|
|
(if (looking-at (or symbol-name-regexp sclang-symbol-name-regexp))
|
|
(buffer-substring-no-properties beg end))))))
|
|
|
|
(defun sclang-line-at-point ()
|
|
"Return the line at point."
|
|
(buffer-substring-no-properties (line-beginning-position) (line-end-position)))
|
|
|
|
(defun sclang-defun-at-point ()
|
|
"Return the defun at point.
|
|
|
|
A defun may either be a class definition or a code block, see
|
|
`sclang-beginning-of-defun-regexp'."
|
|
(save-excursion
|
|
(with-syntax-table sclang-mode-syntax-table
|
|
(cl-multiple-value-bind (beg end) (sclang-point-in-defun-p)
|
|
(and beg end (buffer-substring-no-properties beg end))))))
|
|
|
|
;; ===================================================================
|
|
;; symbol completion
|
|
;; ===================================================================
|
|
|
|
(defun sclang-complete-symbol (&optional predicate)
|
|
"Perform completion on symbol preceding point.
|
|
Compare that symbol against the known symbols.
|
|
|
|
When called from a program, optional arg PREDICATE is a predicate
|
|
determining which symbols are considered.
|
|
If PREDICATE is nil, the context determines which symbols are
|
|
considered. If the symbol starts with an upper case letter,
|
|
class name completion is performed, otherwise only selector names
|
|
are considered."
|
|
(interactive)
|
|
(let* ((buffer (current-buffer))
|
|
(end (point))
|
|
(beg (save-excursion
|
|
(backward-sexp 1)
|
|
(skip-syntax-forward "'")
|
|
(point)))
|
|
(pattern (buffer-substring-no-properties beg end))
|
|
(case-fold-search nil)
|
|
(table (sclang-get-symbol-completion-table))
|
|
(predicate (or predicate
|
|
(if (sclang-class-name-p pattern)
|
|
'sclang-class-name-p
|
|
'sclang-method-name-p)))
|
|
(completion (try-completion pattern table (lambda (assoc) (funcall predicate (car assoc))))))
|
|
(cond ((eq completion t))
|
|
((null completion)
|
|
(sclang-message "Can't find completion for '%s'" pattern)
|
|
(ding))
|
|
((not (string= pattern completion))
|
|
(delete-region beg end)
|
|
(insert completion))
|
|
(t
|
|
(sclang-message "Making completion list...")
|
|
(let* ((list (all-completions pattern table (lambda (assoc) (funcall predicate (car assoc)))))
|
|
(win (selected-window))
|
|
(buffer-name (sclang-make-buffer-name "Completions"))
|
|
(same-window-buffer-names (list buffer-name)))
|
|
(setq list (sort list 'string<))
|
|
(with-sclang-browser
|
|
buffer-name
|
|
(add-hook 'sclang-browser-show-hook (lambda () (sclang-browser-next-link)))
|
|
(setq sclang-browser-link-function
|
|
(lambda (arg)
|
|
(sclang-browser-quit)
|
|
(with-current-buffer (car arg)
|
|
(delete-region (car (cdr arg)) (point))
|
|
(insert (cdr (cdr arg))))))
|
|
;; (setq view-exit-action 'kill-buffer)
|
|
(insert (format "Completions for '%s':\n\n" pattern))
|
|
(dolist (x list)
|
|
(insert (sclang-browser-make-link x (cons buffer (cons beg x))))
|
|
(insert " \n"))))
|
|
(sclang-message "Making completion list...%s" "done")))))
|
|
|
|
(defun sclang-completion-at-point ()
|
|
"Function used for `completion-at-point-functions' in `sclang-mode'."
|
|
(let* ((end (point))
|
|
(beg (save-excursion
|
|
(backward-sexp 1)
|
|
(skip-syntax-forward "'")
|
|
(point)))
|
|
(pattern (buffer-substring-no-properties beg end))
|
|
(case-fold-search nil)
|
|
(predicate (if (sclang-class-name-p pattern)
|
|
#'sclang-class-name-p
|
|
#'sclang-method-name-p)))
|
|
(list beg
|
|
end
|
|
(all-completions pattern sclang-symbol-table predicate)
|
|
:exclusive 'no
|
|
:company-docsig #'identity)))
|
|
|
|
;; ===================================================================
|
|
;; introspection
|
|
;; ===================================================================
|
|
|
|
(defcustom sclang-definition-marker-ring-length 32
|
|
"*Length of marker ring `sclang-definition-marker-ring'."
|
|
:group 'sclang-interface
|
|
:version "21.3"
|
|
:type 'integer)
|
|
|
|
(defvar sclang-definition-marker-ring
|
|
(make-ring sclang-definition-marker-ring-length)
|
|
"Ring of markers which are locations from which \\[sclang-find-definitions] was invoked.")
|
|
|
|
;; really do that?
|
|
(add-hook 'sclang-library-startup-hook
|
|
(lambda ()
|
|
(setq sclang-definition-marker-ring
|
|
(make-ring sclang-definition-marker-ring-length))))
|
|
|
|
(defun sclang-open-definition (name file pos &optional pos-func)
|
|
"Open definition NAME in FILE at POS (optionally POS-FUNC)."
|
|
(let ((buffer (find-file file)))
|
|
(when (bufferp buffer)
|
|
(with-current-buffer buffer
|
|
(goto-char (or pos (point-min)))
|
|
(when (and nil (functionp pos-func))
|
|
(let ((pos (funcall pos-func name)))
|
|
(and pos (goto-char pos))))))
|
|
buffer))
|
|
|
|
(defun sclang-pop-definition-mark ()
|
|
"Pop back to where \\[sclang-find-definition] or \\[sclang-find-reference] was last invoked."
|
|
(interactive)
|
|
(unless (ring-empty-p sclang-definition-marker-ring)
|
|
(let ((marker (ring-remove sclang-definition-marker-ring 0)))
|
|
(switch-to-buffer (or (marker-buffer marker)
|
|
(error "The marked buffer has been deleted")))
|
|
(goto-char (marker-position marker))
|
|
(set-marker marker nil nil))))
|
|
|
|
(defun sclang-browse-definitions (name definitions buffer-name header &optional pos-func)
|
|
"Browse definitions. NAME DEFINITIONS BUFFER-NAME HEADER (optionally POS-FUNC)."
|
|
(if (cdr definitions)
|
|
(let ((same-window-buffer-names (list buffer-name)))
|
|
(with-sclang-browser
|
|
buffer-name
|
|
;; (setq view-exit-action 'kill-buffer)
|
|
(setq sclang-browser-link-function
|
|
(lambda (data)
|
|
(sclang-browser-quit)
|
|
(apply 'sclang-open-definition data)))
|
|
(add-hook 'sclang-browser-show-hook (lambda () (sclang-browser-next-link)))
|
|
(insert header)
|
|
(insert "\n")
|
|
(let ((max-width 0)
|
|
format-string)
|
|
(dolist (def definitions)
|
|
(setq max-width (max (length (file-name-nondirectory (nth 1 def))) max-width)))
|
|
(setq format-string (format "%%-%ds %%s" max-width))
|
|
(dolist (def definitions)
|
|
(let ((string (format format-string
|
|
(propertize (file-name-nondirectory (nth 1 def)) 'face 'bold)
|
|
(nth 0 def)))
|
|
(data (list name (nth 1 def) (nth 2 def) pos-func)))
|
|
(insert (sclang-browser-make-link string data))
|
|
(insert "\n"))))))
|
|
;; single definition: jump directly
|
|
(let ((def (car definitions)))
|
|
(sclang-open-definition name (nth 1 def) (nth 2 def) pos-func))))
|
|
|
|
(defun sclang-find-definitions (name)
|
|
"Find all definitions of symbol NAME."
|
|
(interactive
|
|
(list
|
|
(if current-prefix-arg
|
|
(read-string "Find definition: ")
|
|
(sclang-read-symbol "Find definitions of: "
|
|
(sclang-symbol-at-point) nil t))))
|
|
(if (sclang-symbol-match sclang-method-definition-spec-regexp name)
|
|
(sclang-perform-command 'openDefinition name)
|
|
(if (sclang-get-symbol name)
|
|
(progn
|
|
(ring-insert sclang-definition-marker-ring (point-marker))
|
|
(if (sclang-class-name-p name)
|
|
(sclang-perform-command 'classDefinitions name)
|
|
(sclang-perform-command 'methodDefinitions name)))
|
|
(sclang-message "'%s' is undefined" name))))
|
|
|
|
(sclang-set-command-handler
|
|
'openDefinition
|
|
(lambda (assoc)
|
|
(let ((name (car assoc))
|
|
(data (cdr assoc)))
|
|
(if data
|
|
(sclang-open-definition nil (car data) (cadr data))
|
|
(sclang-message "'%s' is undefined" name)))))
|
|
|
|
(sclang-set-command-handler
|
|
'classDefinitions
|
|
(lambda (assoc)
|
|
(let ((name (car assoc))
|
|
(data (cdr assoc)))
|
|
(if data
|
|
(sclang-browse-definitions
|
|
name data
|
|
"*Definitions*" (format "Definitions of '%s'\n" name)
|
|
(lambda (name)
|
|
(let ((case-fold-search nil))
|
|
;; point is either
|
|
;; - at a class definition
|
|
;; - inside a class extension
|
|
;; so jump to the class name
|
|
(when (or (looking-at (sclang-make-class-definition-regexp name))
|
|
(re-search-backward (sclang-make-class-extension-regexp name) nil t))
|
|
(match-beginning 1)))))
|
|
(sclang-message "No definitions of '%s'" name)))))
|
|
|
|
(sclang-set-command-handler
|
|
'methodDefinitions
|
|
(lambda (assoc)
|
|
(let ((name (car assoc))
|
|
(data (cdr assoc)))
|
|
(if data
|
|
(sclang-browse-definitions
|
|
name data
|
|
"*Definitions*" (format "Definitions of '%s'\n" name)
|
|
(lambda (name)
|
|
(let ((case-fold-search nil))
|
|
(when (re-search-forward (sclang-make-method-definition-regexp name))
|
|
(match-beginning 1)))))
|
|
(sclang-message "No definitions of '%s'" name)))))
|
|
|
|
(defun sclang-find-references (name)
|
|
"Find all references to symbol NAME."
|
|
(interactive
|
|
(list
|
|
(sclang-read-symbol "Find references to: "
|
|
(sclang-symbol-at-point) nil t)))
|
|
(if (sclang-get-symbol name)
|
|
(progn
|
|
(ring-insert sclang-definition-marker-ring (point-marker))
|
|
(sclang-perform-command 'methodReferences name))
|
|
(sclang-message "'%s' is undefined" name)))
|
|
|
|
(sclang-set-command-handler
|
|
'methodReferences
|
|
(lambda (assoc)
|
|
(let ((name (car assoc))
|
|
(data (cdr assoc)))
|
|
(if data
|
|
(sclang-browse-definitions
|
|
name data
|
|
"*References*" (format "References to '%s'\n" name)
|
|
(lambda (name)
|
|
(let ((case-fold-search nil))
|
|
(when (re-search-forward (regexp-quote name))
|
|
(match-beginning 0)))))
|
|
(sclang-message "No references to '%s'" name)))))
|
|
|
|
(defun sclang-show-method-args ()
|
|
"Show method args."
|
|
(interactive)
|
|
(let ((regexp (concat
|
|
sclang-class-name-regexp
|
|
"[ \t\n]*\\(?:\\.[ \t\n]*\\("
|
|
sclang-method-name-regexp
|
|
"\\)\\)?[ \t\n]*("))
|
|
(case-fold-search nil)
|
|
(beg (point)))
|
|
(save-excursion
|
|
(while (and (re-search-backward regexp nil t)
|
|
(let ((class (save-match-data (sclang-get-symbol (sclang-symbol-at-point)))))
|
|
(goto-char (1- (match-end 0)))
|
|
(if (condition-case nil
|
|
(save-excursion
|
|
(forward-list 1)
|
|
(> (point) beg))
|
|
(error t))
|
|
(let ((method (sclang-get-symbol (or (match-string-no-properties 1) "new"))))
|
|
(and class method
|
|
(sclang-perform-command 'methodArgs class method)
|
|
nil))
|
|
(goto-char (match-beginning 0)) t)))))))
|
|
|
|
(sclang-set-command-handler
|
|
'methodArgs
|
|
(lambda (args)
|
|
(and args (message "%s" args))))
|
|
|
|
(defun sclang-dump-full-interface (class)
|
|
"Dump interface of CLASS."
|
|
(interactive
|
|
(list
|
|
(let* ((symbol (sclang-symbol-at-point))
|
|
(class (and (sclang-get-symbol symbol)
|
|
(sclang-class-name-p symbol)
|
|
symbol)))
|
|
(sclang-read-symbol "Dump interface of: "
|
|
class 'sclang-class-name-p t))))
|
|
(sclang-eval-string (format "%s.dumpFullInterface" class)))
|
|
|
|
(defun sclang-dump-interface (class)
|
|
"Dump interface of CLASS."
|
|
(interactive
|
|
(list
|
|
(let* ((symbol (sclang-symbol-at-point))
|
|
(class (and (sclang-get-symbol symbol)
|
|
(sclang-class-name-p symbol)
|
|
symbol)))
|
|
(sclang-read-symbol "Dump interface of: "
|
|
class 'sclang-class-name-p t))))
|
|
(sclang-eval-string (format "%s.dumpInterface" class)))
|
|
|
|
;; ===================================================================
|
|
;; cscope interface
|
|
;; ===================================================================
|
|
|
|
(defcustom sclang-source-directory nil
|
|
"Toplevel SuperCollider source directory.
|
|
|
|
This variable is used by `sclang-find-primitive' to locate the cscope
|
|
database."
|
|
:group 'sclang-interface
|
|
:version "21.4.1"
|
|
:type 'directory
|
|
:options '(must-match))
|
|
|
|
(defun sclang-find-primitive (name)
|
|
"Find primitive NAME in a cscope database.
|
|
|
|
The database is searched in `sclang-source-directory', or the
|
|
current-directory, iff `sclang-source-directoy' is nil."
|
|
(interactive
|
|
(let ((default (sclang-symbol-at-point sclang-primitive-name-regexp)))
|
|
(list (read-string (sclang-make-prompt-string "Find primitive: " default)
|
|
nil nil default))))
|
|
(if (require 'xcscope nil t)
|
|
(let ((cscope-initial-directory sclang-source-directory))
|
|
;; only fboundp when xcscope is loaded
|
|
(cscope-find-this-text-string
|
|
(if (string-match "^_" name) name (concat "_" name))))
|
|
(sclang-message "cscope not available")))
|
|
|
|
;; ===================================================================
|
|
;; sc-code formatting
|
|
;; ===================================================================
|
|
|
|
(defun sclang-list-to-string (list)
|
|
"Convert sclang LIST to string."
|
|
(mapconcat 'sclang-object-to-string list ", "))
|
|
|
|
(defconst sclang-false 'false)
|
|
|
|
(defun sclang-object-to-string (obj)
|
|
"Convert sclang object OBJ to string."
|
|
(cond ((null obj)
|
|
"nil")
|
|
((eq sclang-false obj)
|
|
"false")
|
|
((eq t obj)
|
|
"true")
|
|
((symbolp obj)
|
|
(format "'%s'" obj))
|
|
((listp obj)
|
|
(format "[ %s ]" (sclang-list-to-string obj)))
|
|
(t (format "%S" obj))))
|
|
|
|
(defun sclang-format (string &rest args)
|
|
"Format STRING using ARGS.
|
|
%s - print string
|
|
%o - print object
|
|
%l - print argument list"
|
|
(let ((case-fold-search nil)
|
|
(i 0))
|
|
(save-match-data
|
|
(while (and (< i (length string))
|
|
(string-match "%[los%]" string i))
|
|
(let* ((start (car (match-data)))
|
|
(format (aref string (1+ start)))
|
|
(arg (if args
|
|
(pop args)
|
|
(error "Not enough arguments for format string")))
|
|
(repl (cond ((eq ?o format)
|
|
(sclang-object-to-string arg))
|
|
((eq ?l format)
|
|
(if (listp arg)
|
|
(sclang-list-to-string arg)
|
|
(sclang-object-to-string arg)))
|
|
((eq ?s format)
|
|
(format "%s" arg))
|
|
((eq ?% format)
|
|
(push arg args)
|
|
"%"))))
|
|
(setq string (replace-match repl t t string))
|
|
(setq i (+ start (length repl)))))))
|
|
string)
|
|
|
|
(defun sclang-format-pseq (items)
|
|
"Format ITEMS (a flat list of numbers or symbols) as a possibly nested Pseq.
|
|
Looks for all repetitive patterns in ITEMS recursively. Therefore, it is
|
|
computationally expensive, especially when ITEMS is a long list. If you don't
|
|
want smart pattern guessing, use `sclang-format' directly to format your Pseq."
|
|
(cl-labels ((find-reps (items)
|
|
(let (r)
|
|
(while items
|
|
(let ((ret (car items))
|
|
(skip 1)
|
|
(rep (length items)))
|
|
(catch 'match-found
|
|
(while (>= rep 2)
|
|
(let ((i (/ (length items) rep)))
|
|
(while (> i 0)
|
|
(let ((sublst (cl-subseq items 0 i)))
|
|
(when (catch 'equal
|
|
(let ((a items))
|
|
(cl-loop repeat rep do
|
|
(let ((b sublst))
|
|
(while b
|
|
(unless (eql (car b) (car a))
|
|
(throw 'equal nil))
|
|
(setq a (cdr a)
|
|
b (cdr b)))))
|
|
t))
|
|
(setq ret (cons rep (if (> i 5)
|
|
(find-reps sublst)
|
|
sublst))
|
|
skip (* i rep))
|
|
(throw 'match-found t))
|
|
(cl-decf i))))
|
|
(cl-decf rep)))
|
|
(accept-process-output nil 0 100)
|
|
;; invent better progress info
|
|
(message "Processed...%S" ret)
|
|
(setq r (append r (list ret))
|
|
items (nthcdr skip items))))
|
|
r))
|
|
(elem-to-string (elem)
|
|
(cond
|
|
((consp elem)
|
|
(concat "Pseq([ "
|
|
(mapconcat #'elem-to-string (cdr elem) ", ")
|
|
(format " ], %d)" (car elem))))
|
|
(t (sclang-object-to-string elem)))))
|
|
(let ((compressed (find-reps items)))
|
|
(if (and (= (length compressed) 1) (consp (car compressed)))
|
|
(elem-to-string (car compressed))
|
|
(concat "Pseq([ "
|
|
(mapconcat #'elem-to-string compressed ", ")
|
|
" ], 1)")))))
|
|
|
|
;; ===================================================================
|
|
;; module setup
|
|
;; ===================================================================
|
|
|
|
(provide 'sclang-language)
|
|
|
|
;;; sclang-language.el ends here
|