Last edit
Sammanfattning: include X-URL
Ändrad:
< ;; X-URL:
till
> ;; X-URL: https://raw.github.com/DinoChiesa/dpchiesa-elisp/master/thesaurus.el
;;; thesaurus.el --- replace a word with a synonym looked up in a web service. ;; ;; Author: Dino Chiesa, Alex Henning ;; Created: Thu, 29 Mar 2012 09:18 ;; Package-Requires: () ;; URL: http://www.emacswiki.org/cgi-bin/wiki/thesaurus.el ;; X-URL: https://raw.github.com/DinoChiesa/dpchiesa-elisp/master/thesaurus.el ;; Version: 2012.11.25 ;; Keywords: thesaurus synonym ;; License: New BSD ;;; Commentary: ;; This module allows a user to look up synonyms for a word in ;; a web-accessible thesaurus. ;; This code started with a basic version posted without license at ;; http://alexhenning.github.com/blog/2010/11/01/synonym.el/ ;; I standardized the naming, re-factored, wrote some documentation, ;; introduced the dependency on dropdown-list.el and x-popup-menu, added ;; a license, introduced some error handling, and polished it. ;; Right now it depends on a web service from Big Huge Labs. It ;; is not tied to that service, and could be expanded to use other ;; services, and to even dynamically choose which service to access. ;; To use, first go to http://words.bighugelabs.com/ and register (no ;; cost) to get an API key. Then, put thesaurus.el in your emacs load ;; path and modify your .emacs to do this: ;; (require 'thesaurus) ;; (setq thesaurus-bhl-api-key "XXXXXXXXXXXX") ;; from registration ;; -or- ;; (require 'thesaurus) ;; (thesaurus-set-bhl-api-key-from-file "~/BigHugeLabs.apikey.txt") ;; Optionally, set a key binding: ;; (define-key global-map (kbd "C-x t") 'thesaurus-choose-synonym-and-replace) ;; This module currently relies on a BigHugeLabs thesaurus service. The ;; service is currently free, and has a limit of 10,000 lookups per ;; day. If the service changes, or becomes unavailable, or if anyone ;; exceeds the limit, it shouldn't be difficult to expand this module to ;; support other online thesaurus services. Wolfram Alpha is one ;; possible option; theirs is a free API. Wordnik has a free synonyms API. ;; ;; eg: ;; http://api.wordnik.com//v4/word.json/awry/relatedWords?relationshipTypes=synonym ;; ;; I think Bing has one. Probably there are others. This module would need ;; to be modified to support one of those. ;; ;; If you want to proxy the URL calls, then use this: ;; (setq url-proxy-services (list (cons "http" "proxyHost:proxyPort"))) ;; ;;; Revisions: ;; ;; 2012.11.25 2012-November-25 Dino Chiesa ;; Add the helper method `thesaurus-set-bhl-api-key-from-file'. ;; A few doc changes. ;; ;; 2012.4.7 2012-April-07 Dino Chiesa ;; Fixup the customization group. ;; Also serialize and de-serialize the cache as a list, not as a ;; hash. To avoid the problem reported by Takafumi Arakaki. (Thanks!) ;; ;; 1.0.4 2012-March-30 Dino Chiesa ;; use message-box to notify users when they need to acquire an api ;; key, and pop a browser to do so. Use a special message-box on ;; Windows. Also, handle the case where no synonyms are found - for ;; example, when looking up a mis-spelled or non-existent word. ;; ;; 1.0.3 2012-March-30 Dino Chiesa ;; include x-popup-menu as the default prompting mechanism. ;; dropdown-list is sort of a pain to work with. I don't know ;; what this means for tty users. ;; ;; 1.0.2 2012-March-29 Dino Chiesa ;; tiny doc change ;; ;; 1.0.1 2012-March-29 Dino Chiesa ;; Initial version ;; ;;; License ;; ;; This code is distributed under the New BSD License. ;; ;; Copyright (c) 2008-2012, Dino Chiesa ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; ;; Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; ;; Neither the name of the author or any contributors, nor the names of ;; any organizations they belong to, may be used to endorse or promote ;; products derived from this software without specific prior written ;; permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, ;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS ;; OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED ;; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY ;; WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ;; POSSIBILITY OF SUCH DAMAGE. ;; (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) ;; saving the cache may get expensive as it gets larger (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." ;; could insert a chooser function here (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 ;; This is a command to be passed on the cmd.exe line. ;; Newlines encoded as \n or `n do not display properly. This ;; code transforms splits the string on newlines, then joins, ;; using [char]0x000D as the "glue". Also - need to perform ;; special escaping of single and double quotes. All this ;; because we are passing a script to powershell on the ;; command line. ;; ;; creating a file with script code in it, then passing ;; that file to powershell, would avoid the need for ;; special escaping. But that is not feasible, since by ;; default powershell prohibits executing scripts. But ;; powershell allows running script passed as -Command. So. (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))))) ;;;###autoload (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))) ;; this works with x-popup-menu (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 ;; NB: ;; x-popup-menu displays in the proper location, near ;; the cursor. ;; ;; x-popup-dialog always displays in the center ;; of the frame, which makes for an annoying ;; user-experience. (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))))))) ;;;###autoload (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))) ;; remove newline string) ;;;###autoload (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) ;;; thesaurus.el ends here