Download
(defgroup thesaurus nil
"Provides a facility to look up synonyms."
:group 'Editing)
(defcustom thesaurus-bhl-api-key nil
"The api key for connecting to BigHugeLabs.com.
Get one by visiting http://words.bighugelabs.com/getkey.php
"
:type 'string
:group 'thesaurus)
(defcustom thesaurus-prompt-mechanism 'x-popup-menu
"The mechanism used to prompt the user for his choice of
synonym. Options: 'x-popup-menu, or 'dropdown-list. When setting
this, set it to the symbol, not to the string or the actual
function. Eg
(setq thesaurus-prompt-mechanism 'x-popup-menu)
"
:type 'symbol
:options '('x-popup-menu 'dropdown-list)
:group 'thesaurus)
(defvar thesaurus---load-path (or load-file-name "~/thesaurus.el")
"For internal use only. ")
(defvar thesaurus-cache-dir (file-name-directory thesaurus---load-path))
(defvar thesaurus-cache-basefilename ".thesaurus.cache")
(defvar thesaurus-can-save-cache-p (or
(and (>= emacs-major-version 23)
(>= emacs-minor-version 1)
(null (string-match "23.1.1" (version))))
(> emacs-major-version 23))
"Whether it is possible to save the cache")
(defvar thesaurus-cache nil)
(defvar thesaurus-bounds-of-looked-up-word nil)
(defun thesaurus-cache-filename ()
(concat thesaurus-cache-dir thesaurus-cache-basefilename))
(defun thesaurus-cache-initialize ()
(make-hash-table :test 'equal))
(defun thesaurus-cache-get (key)
(gethash key thesaurus-cache))
(defun thesaurus-cache-put (key value)
(when value
(puthash key value thesaurus-cache)
(thesaurus-cache-save))
value)
(defun thesaurus-hashtable-to-alist (hash)
"Return an association-list representation of the hashtable HASH."
(let ((alist nil))
(maphash
(lambda (key value)
(setq alist (cons (cons key value) alist)))
hash)
alist))
(defun thesaurus-hashtable-from-alist (alist &rest options)
"Build a hashtable from the values in the association list ALIST."
(let ((ht (apply 'make-hash-table options)))
(mapc
(lambda (kv-pair) (puthash (car kv-pair) (cdr kv-pair) ht))
alist)
ht))
(defun thesaurus-cache-save ()
(with-temp-buffer
(let (print-level print-length)
(insert (pp-to-string (thesaurus-hashtable-to-alist thesaurus-cache)))
(write-region (point-min) (point-max) (thesaurus-cache-filename)))))
(defun thesaurus-cache-load ()
(thesaurus-hashtable-from-alist
(with-temp-buffer
(insert-file-contents (thesaurus-cache-filename))
(car (read-from-string (buffer-substring-no-properties
(point-min) (point-max)))))
:test 'equal))
(defun thesaurus-get-buffer-for-word (word)
"Retrieve a list of synonyms for the given word, from the
web service."
(thesaurus-get-buffer-for-word-bhl word))
(defun thesaurus-msgbox (msg)
"Display a message in a dialog box."
(if (thesaurus-want-msgbox-via-powershell)
(thesaurus-msgbox-via-powershell msg)
(message-box msg)))
(defun thesaurus-path-of-powershell-exe ()
"get location of powershell exe."
(concat
(or (getenv "windir") "c:\\windows")
"\\System32\\WindowsPowerShell\\v1.0\\powershell.exe"))
(defun thesaurus-want-msgbox-via-powershell ()
"Determine if we want to display a message box
using Windows powershell."
(and (eq system-type 'windows-nt)
(file-exists-p (thesaurus-path-of-powershell-exe))))
(defun thesaurus-msgbox-via-powershell (format-string &rest args)
"Display a message box via powershell and Windows Forms.
The `message-box' fn works poorly on Windows; it does not allow
the encoding of newlines and also the UI generally looks like a
silly toy.
This can be used in place of `message-box' on Windows.
This is used within `thesaurus.el' in only one case: to notify
the user that he needs to register for an API key.
"
(flet ((rris (a1 a2 s) (replace-regexp-in-string a1 a2 s)))
(let* ((msg (format format-string args))
(ps-cmd
(concat "[void][System.Reflection.Assembly]::LoadWithPartialName('System.Windows.Forms');"
"[Windows.Forms.MessageBox]::Show("
(mapconcat '(lambda (elt)
(rris (char-to-string 34)
(char-to-string 39)
(pp-to-string
(rris (char-to-string 34)
"'+[char]0x0022+'"
(rris (char-to-string 39)
"'+[char]0x0027+'"
elt)
))))
(split-string msg "\n" nil)
"+[char]0x000D+")
",'Message from Emacs',"
"[Windows.Forms.MessageBoxButtons]::OK,"
"[Windows.Forms.MessageBoxIcon]::Information)"))
(shell-command
(format "%s -Command %s"
(thesaurus-path-of-powershell-exe)
(concat "\"& {" ps-cmd "}\""))))
(shell-command-on-region (point) (point)
shell-command
nil nil nil))))
(defun thesaurus-get-buffer-for-word-bhl (word)
"retrieve a list of synonyms for the given word, from the
BigHugeLabs web service."
(if (not (and (boundp 'thesaurus-bhl-api-key)
(stringp thesaurus-bhl-api-key)))
(let ((msg (concat "You need to get an \"api key\" from BigHugeLabs.\n"
"Then, set it in your .emacs with a statement like:\n"
" (setq thesaurus-bhl-api-key \"XXXXXXXXXXXX\") \n")))
(thesaurus-msgbox msg)
(browse-url "http://words.bighugelabs.com/getkey.php")
nil)
(url-retrieve-synchronously
(concat "http://words.bighugelabs.com/api/2/"
thesaurus-bhl-api-key "/" word "/"))))
(defun thesaurus-process-http-headers ()
"In the buffer created by `url-retrieve-synchronously',
there are HTTP headers, and content. This fn removes the headers
from the buffer, parsing the Content-Length header to verify that
a substantive response was received.
This implementation deletes each line until finding a blank line,
which in correctly-formatted HTTP messages signals the end of the
headers and the beginning of the message content.
"
(let ((clength -1))
(while (/= (point) (line-end-position))
(when (and (< clength 0)
(re-search-forward "^[Cc]ontent-[Ll]ength ?: *\\(.*\\)$" (line-end-position) t))
(setq clength (string-to-number (match-string 1)))
(goto-char (line-beginning-position)))
(delete-region (point) (line-end-position))
(delete-char 1))
(delete-char 1)
clength))
(defun thesaurus-parse-one-line ()
"Parse one line in the buffer created by `url-retrieve-synchronously'.
The format of each line is expected to be:
form|flavor|word
where
form = {adjective,verb,noun,etc}
flavor = {syn,sim,ant,rel}
word = the actual word
The return value is a list, with those three items in it,
in that order.
"
(let (start end s parts)
(setq start (point)
end (line-end-position)
s (buffer-substring-no-properties start end)
parts (split-string s "|"))
(delete-region start end)
(delete-char 1)
parts))
(defun thesaurus-fetch-synonyms (word)
"fetch synonyms for the given word, from a remote source."
(let ((synonym-list nil)
(buf (thesaurus-get-buffer-for-word word)))
(if buf
(progn
(with-current-buffer buf
(rename-buffer (concat "*thesaurus* - " word) t)
(goto-char (point-min))
(if (> (thesaurus-process-http-headers) 0)
(while (not (= (point-min) (point-max)))
(let ((elt (thesaurus-parse-one-line)))
(if elt
(add-to-list 'synonym-list elt))))
(message-box "No synonyms found.")))
(kill-buffer buf)
(nreverse synonym-list)))))
(defun thesaurus-get-synonyms (word)
"retrieve synonyms for the given word, either from the cache,
or, if there is no cache hit, then from the remote service.
"
(or (thesaurus-cache-get word)
(thesaurus-cache-put word (thesaurus-fetch-synonyms word))))
(defun thesaurus-get-menu-position ()
"get the position for the popup menu"
(if (fboundp 'posn-at-point)
(let ((x-y (posn-x-y (posn-at-point (point)))))
(list (list (+ (car x-y) 10)
(+ (cdr x-y) 20))
(selected-window)))
t))
(defun thesaurus--generate-menu (candidates)
"Generate a menu suitable for use in `x-popup-menu' from the
list of candidates. Each item in the list of candidates is a
list, (FORM FLAVOR WORD), where FORM is one of {adjective, verb,
noun, etc}, FLAVOR is {syn, sim, rel, ant, etc}, and WORD is the
actual word.
The output is a list like this:
(\"Replace with...\"
(\"Ignored pane title\"
(\"thing 1 to display\" \"value to return if thing 1 is selected\")
(\"thing 2 to display\" \"value if thing 2 is selected\")))
"
(let ((items (mapcar '(lambda (elt)
(cons
(concat (nth 2 elt) " (" (nth 0 elt) ")")
(nth 2 elt)))
candidates)))
(setq items (cons "Ignored pane title" items))
(list "Replace with..." items)))
(defun thesaurus-prompt-user-with-choices (candidates)
"Prompt the user with the available replacement choices.
In this context the list of choices is the list of synonyms.
See `thesaurus-prompt-mechanism'.
"
(cond
((not candidates)
nil)
((and (eq thesaurus-prompt-mechanism 'dropdown-list)
(featurep 'dropdown-list))
(let ((choice-n (dropdown-list (mapcar '(lambda (elt) (nth 2 elt)) candidates))))
(if choice-n
(nth choice-n candidates)
(keyboard-quit))))
(t
(x-popup-menu (thesaurus-get-menu-position)
(thesaurus--generate-menu candidates)))))
(defun thesaurus-word-at-point ()
"Uses `bounds-of-thing-at-point', to find and return the word at point.
As a side effect, this fn stores the bounds of the word that is found.
This allows this module to delete the word later, when the user chooses
a replacement word.
"
(if (get 'word 'thing-at-point)
(funcall (get 'word 'thing-at-point))
(let ((bounds (bounds-of-thing-at-point 'word)))
(if bounds
(progn
(setq thesaurus-bounds-of-looked-up-word bounds)
(buffer-substring-no-properties (car bounds) (cdr bounds)))))))
(defun thesaurus-choose-synonym-and-replace (word)
"The main interactive entry point into the `thesaurus.el' capability.
Invoke this interactively, and the fn will prompt the user to
confirm the word to be looked up. It will then retrieve a list
of synonyms for the word, either from the cache or from a remote
service, and prompt the user with a list of possible
replacements. If the user chooses a replacement, the original
word in the buffer will be removed and the replacement will be
inserted in its place.
"
(interactive (list (read-string "word: " (thesaurus-word-at-point))))
(let ((chosen (thesaurus-prompt-user-with-choices
(thesaurus-get-synonyms word))))
(when chosen
(goto-char (car thesaurus-bounds-of-looked-up-word))
(delete-region (car thesaurus-bounds-of-looked-up-word)
(cdr thesaurus-bounds-of-looked-up-word))
(insert chosen))))
(defun thesaurus--trim-trailing-newlines (string)
(while (string-match "\\(.*\\)\\(\n\\|\r\\)$" string)
(setq string (substring string 0 -1)))
string)
(defun thesaurus-set-bhl-api-key-from-file (filename)
"A way to set the API key for BigHugeLabs with the contents of
a text file. That text file should contain the key obtained from
BHL during registration.
"
(interactive)
(setq thesaurus-bhl-api-key
(and (file-exists-p filename)
(thesaurus--trim-trailing-newlines
(with-temp-buffer
(insert-file-contents filename)
(buffer-substring-no-properties (point-min) (point-max)))))))
(defun thesaurus-install ()
"install `thesaurus.el'"
(setq thesaurus-cache
(if (file-exists-p (thesaurus-cache-filename))
(thesaurus-cache-load)
(thesaurus-cache-initialize))))
(eval-when-compile (require 'dropdown-list nil t))
(thesaurus-install)
(provide 'thesaurus)