Download
(require 'derived)
(require 'cl)
(require 'thingatpt)
(require 'scheme)
(defconst plt-completions-version "0.02")
(defconst plt-completions-author-email "rohan.nicholls at gmail.com")
(defconst plt-completions-legal-notice
"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. You
should have received a copy of the GNU General Public License along with Emacs;
see the file `COPYING'. If not, write to the Free Software Foundation, Inc.,
59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.")
(define-derived-mode plt-completions-mode completion-list-mode "PLT Completions"
"Major mode for handling completions in plt scheme
Special commands:
\\{plt-completions-mode-map}"
)
(define-key plt-completions-mode-map (kbd "RET") 'plt-return-completion)
(define-key plt-completions-mode-map [(control return)] 'plt-goto-reference)
(load-library "utilities")
(defvar *plt-doc-dir* nil
"The root directory of the plt docs (usually found under the
PLTHOME directory) but not always as the debian package
installs them under /usr/share/plt/doc")
(defvar *plt-exclude-manuals*
'("beginning" "advanced" "beginning-abbr" "intermediate"
"intermediate-lambda" "profj-advanced" "profj-beginner"
"profj-intermediate" "release-notes" "teachpack" "teachpack-htdc"
"tour" "." "..")
"Directories for which you do not want to get completions from.
This will differ according to needs, but I have tried to remove ;
redundancies by excluding all the teaching languages.
Excluding as much as possible has the nice side effect of
really speeding things up as well")
(defvar *plt-match-all* t
"If t match any substrings that are given, if nil, only symbols
starting with this match. NOTE: NOT IMPLEMENTED YET - at the moment
it matches everything." )
(defvar *plt-doc-dirs* nil
"List of subdirectories within doc, minus anything found in
*plt-exclude-manuals*")
(defvar *plt-categories* nil
"A list of relative paths to the different directories that are
included in the matching")
(defvar *plt-completions* nil
"The complete list of keywords for all the documented parts of
plt. If you have installed new documentation and wish to reset
the completions so the new doc is added, just set this to nil,
and the next call for completions will repopulate the
database")
(defvar *plt-last-search* nil
"The last item searched for, if it matches the present search,
then do nice things with the display of completions rather than
looking for a new match")
(defvar *plt-active-buffer* nil
"The buffer for which the present completion is being searched")
(defvar *plt-buffer-split-horizontally* t
"If the completions buffer is created, split the frame
horizontally (side by side) or vertically (one above the
other). If non-nil the frame will split horizontally")
(defun plt-get-doc-dir (&optional plt-doc-dir)
"Obtain the location of the plt doc directory through various means"
(or plt-doc-dir
(let ((pltdocs (getenv "PLT_DOCS")))
(and pltdocs
(file-directory-p pltdocs)
pltdocs))
(let ((plthome (getenv "PLT_HOME")))
(and plthome
(file-directory-p (concat (file-name-as-directory (getenv "PLT_HOME")) "doc"))
(setenv "PLT_DOCS" (concat (file-name-as-directory plthome) "doc"))))
*plt-doc-dir*
(let ((obtained (read-file-name "Please let me know where the plt doc directory is: ")))
(setenv "PLT_DOCS" obtained))))
(defun plt-get-doc-dirs (&optional relative exclude-list)
"Obtain list of subdirectories within doc, minus anything found
in *plt-exclude-manuals*"
(let ((exclude (if exclude-list (remove-duplicates (append exclude-list
*plt-exclude-manuals*))
*plt-exclude-manuals*)))
(remove-if #'(lambda (f)
(member f (mapcar #'(lambda (dir)
(if relative
dir
(concat
(file-name-as-directory *plt-doc-dir*) dir)))
exclude)))
(directory-files *plt-doc-dir* (not relative)))))
(defun plt-get-keywords (dir)
"Collect the keywords from a keyword file in a particular directory"
(save-excursion
(let* ((file (concat dir "/keywords"))
(buf (and (file-exists-p file) (find-file-noselect file))))
(cond (buf
(goto-char (point-min))
(let ((keyword-list (condition-case tmp
(read buf)
(error nil))))
(kill-buffer buf)
(cons dir keyword-list)))))))
(defun plt-walk-the-list (word list &optional match-begin)
"Search for a partial match for word in the first element of
each sublist, and return the lists containing the matches as a
list, if match-begin is set to non-nil or *plt-match-all* is nil
then only finds matches that begin with the pattern"
(let ((search-for (if (or match-begin (eq *plt-match-all* nil))
(concat "^" word) word)))
(remove-if #'(lambda (elem)
(or (null elem)
(plt-one-elemp elem)
(not (consp elem))))
(mapcar (lambda (lst)
(cons
(if lst (format "%s" (file-name-nondirectory (car lst))))
(loop for item being each element of (cdr lst)
with lib = (car lst)
if (and (string-match search-for (car item))
(not (null item)))
collect (list (car item) lib item))))
list))))
(defun plt-os-dependent-url (base page anchor)
"Create a url that will work in the browser and on the platform
that is set in the browse-url package"
(let* ((windows-p (string-match "mingw" (emacs-version)))
(base-url (if windows-p
(delete-if #'(lambda (char)
(equal char ?\:)) base)
base)))
(format "file://%s/%s%s" base-url page
(if anchor (concat "#" anchor) ""))))
(defun plt-docs-url-for-symbol (symbol-list)
"Return the url to the documentation for the item named in the
first element of the symbol list"
(let* ((base-url (second symbol-list))
(item-detail (third symbol-list))
(html-page (third item-detail))
(anchor (if (not (equal (fourth item-detail) ""))
(fourth item-detail)))
(full-url (plt-os-dependent-url base-url html-page anchor)))
full-url))
(defun plt-completions-buffer-display (list)
"Display the results of searching for a match in a buffer, and
display the buffer either in an existing other window, or split
the window and display the buffer"
(plt-display-in-new-buffer
"*PLT Completions*"
plt-completions-mode
*plt-buffer-split-horizontally*
(progn
(loop for cat in list
concat (plt-format-category-matches cat)))))
(defun plt-format-category-matches (lst)
(let ((name (car lst))
(matches (cdr lst)))
(concat (format "%s\n" (upcase name))
(loop for match in matches
concat (let* ((func-name (car match))
(call-syntax (second (third match)))
(display-text (concat func-name " ::- " call-syntax))
(link (format "[[%s][%s]]\n" display-text
(plt-docs-url-for-symbol match))))
(put-text-property 0 2 'invisible t link)
(put-text-property (+ 2 (length display-text)) (- (length link) 1)
'invisible t link)
link))
"\n\n")))
(defun plt-completion-command ()
"Create a completion list in the plt-completions buffer and
display it"
(interactive)
(if (not *plt-completions*)
(progn
(setq *plt-doc-dir* (plt-get-doc-dir))
(setq *plt-doc-dirs* (plt-get-doc-dirs))
(setq *plt-completions* (mapcar #'plt-get-keywords *plt-doc-dirs*))))
(let ((search-for (thing-at-point 'symbol)))
(cond ((and (equal search-for *plt-last-search*)
(plt-buffer-showing-p "*plt completions*"))
(plt-scroll-buffer-or-point-min "*PLT Completions*"))
(t
(setq *plt-active-buffer* (current-buffer))
(plt-completions-buffer-display
(plt-walk-the-list (thing-at-point 'symbol)
*plt-completions*))
(setq other-window-scroll-buffer (get-buffer "*PLT Completions*"))
(setq *plt-last-search* search-for)))))
(defun plt-goto-reference ()
"When sitting on a line in the plt completions buffer, calling this will
take you to html documentation for that page."
(interactive)
(end-of-line)
(backward-char 2)
(if (thing-at-point 'url)
(progn
(print (format "%s" (thing-at-point 'url)))
(browse-url-at-point))))
(defun plt-extract-name (line)
"Extract the name from the text making up the completion"
(if (string-match "\\[\\[\\(.*\\) ::-" line)
(substring-no-properties line (match-beginning 1) (match-end 1))))
(defun plt-remove-replacement (replace)
"Very boring function. Given an object at point, remove it
from just behind point in the current buffer"
(interactive)
(let ((back (length replace)))
(set-mark (point))
(goto-char (- (point) back))
(kill-region (point) (mark))))
(defun plt-return-completion ()
"Take the entry for that line in the completions buffer, and insert it at point in the buffer calling for the completion, replacing the partial completion that had been searched for, and return to the calling buffer."
(interactive)
(let ((comp (plt-extract-name (thing-at-point 'line))))
(cond (comp
(switch-to-buffer-other-window *plt-active-buffer*)
(plt-remove-replacement *plt-last-search*)
(insert (format "%s" comp))))))
(defmacro plt-display-in-new-buffer (new-buf-name mode split-horiz &rest code)
"Display text in a new buffer. The buffer name and the mode it
should run are passed in as the first two arguments, the rest
of the arguments are spliced into an insert statement, so their
product should be a string. This is very simple, but does the
trick. The buffer that is displayed, either re-uses an already
open window, or creates a new window splitting the window
horizontally (equivalent of \"C-x 3\") "
`(progn
(interactive)
(let ((cur-buf (current-buffer)))
(save-excursion
(switch-to-buffer (get-buffer-create ,new-buf-name))
(,mode)
(erase-buffer)
(insert
,@code)
(if (<= (length (window-list)) 1)
(split-window nil nil ,split-horiz))
(switch-to-buffer cur-buf)
(other-window 1)
(switch-to-buffer ,new-buf-name)
(other-window -1)
(goto-char (point-min))))))
(defun plt-one-elemp (lst)
"Test if item is a list of one element"
(cond ((not (consp lst)) nil)
((and (consp lst)
(null (cdr lst))))
(t nil)))
(defun plt-buffer-showing-p (name)
"Is the buffer named by name showing in the current frame"
(member-if (lambda (w)
(string= (downcase(buffer-name (window-buffer w)))
(downcase name)))
(window-list)))
(defun plt-scroll-buffer-or-point-min (&optional buf)
"Scroll the buffer named buf, or if it is at the end of the
buffer, return point to the top"
(interactive)
(let* ((curr (current-buffer))
(buf (switch-to-buffer-other-window (or buf (current-buffer)))))
(unwind-protect
(if (pos-visible-in-window-p (point-max))
(goto-char (point-min))
(scroll-up nil))
(switch-to-buffer-other-window curr))))
(provide 'plt-completions)