1758 lines
59 KiB
EmacsLisp
1758 lines
59 KiB
EmacsLisp
;;; langtool.el --- Grammar check utility using LanguageTool -*- lexical-binding: t -*-
|
|
|
|
;; Copyright (C) 2011-2020,2022-2023 Masahiro Hayashi
|
|
|
|
;; Author: Masahiro Hayashi <mhayashi1120@gmail.com>
|
|
;; Keywords: docs
|
|
;; URL: https://github.com/mhayashi1120/Emacs-langtool
|
|
;; Emacs: GNU Emacs 24 or later
|
|
;; Package-Version: 20230222.326
|
|
;; Package-Revision: 416abc7d1c1c
|
|
;; Package-Requires: ((emacs "24.3"))
|
|
|
|
;; 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 3, 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 GNU Emacs; see the file COPYING. If not, write to the
|
|
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
;; Boston, MA 02110-1301, USA.
|
|
|
|
;;; Commentary:
|
|
|
|
;; ## Install:
|
|
|
|
;; Install LanguageTool version 3.0 or later (and java)
|
|
;; https://languagetool.org/
|
|
;;
|
|
;; Put this file into load-path'ed directory, and byte compile it if
|
|
;; desired. And put the following expression into your ~/.emacs.
|
|
;;
|
|
;; (require 'langtool)
|
|
;;
|
|
;; Or use Melpa (https://melpa.org/)
|
|
|
|
;; ## NOTE (2023-01-25)
|
|
;;
|
|
;; Confirmed working on following environment
|
|
;;
|
|
;; ### Java
|
|
;;
|
|
;; `java --version`
|
|
;;
|
|
;; > openjdk 17.0.4 2022-07-19
|
|
;; > OpenJDK Runtime Environment (build 17.0.4+8-Debian-1deb11u1)
|
|
;; > OpenJDK 64-Bit Server VM (build 17.0.4+8-Debian-1deb11u1, mixed mode, sharing)
|
|
;;
|
|
;; ### LanguageTool
|
|
;;
|
|
;; Can be downloaded from [here](https://languagetool.org/download/)
|
|
;;
|
|
;; `java -jar languagetool-commandline.jar --version`
|
|
;;
|
|
;; > LanguageTool version 6.0 (2022-12-29 12:13:11 +0000, e44dbb0)
|
|
|
|
;; ## Settings (required):
|
|
;;
|
|
;; langtool.el have 3 types of client.
|
|
|
|
;; 1. Command line
|
|
;;
|
|
;; This setting should be set, if you use rest of clients, to get full of
|
|
;; completion support. And you should be set the variables before load
|
|
;; this library.
|
|
;;
|
|
;; (setq langtool-language-tool-jar "/path/to/languagetool-commandline.jar")
|
|
;; (require 'langtool)
|
|
;;
|
|
;; Alternatively, you can set the classpath where LanguageTool's jars reside
|
|
;; (e.g. ArchLinux):
|
|
;;
|
|
;; (setq langtool-java-classpath
|
|
;; "/usr/share/languagetool:/usr/share/java/languagetool/*")
|
|
;; (require 'langtool)
|
|
;;
|
|
;;
|
|
;; You can set a script that hold java setting (e.g. Gentoo):
|
|
;;
|
|
;; (setq langtool-bin "/path/to/your/langtool")
|
|
;; (require 'langtool)
|
|
|
|
;; 2. HTTP server & client
|
|
;;
|
|
;; You can use HTTP server implementation. This is very fast after listen server,
|
|
;; but has security risk if there are multiple user on a same host.
|
|
;;
|
|
;; (setq langtool-language-tool-server-jar "/path/to/languagetool-server.jar")
|
|
;;
|
|
;; You can change HTTP server port number like following.
|
|
;;
|
|
;; (setq langtool-server-user-arguments '("-p" "8082"))
|
|
|
|
;; 3. HTTP client
|
|
;;
|
|
;; If you have running HTTP LanguageTool server instance on any machine:
|
|
;;
|
|
;; (setq langtool-http-server-host "localhost"
|
|
;; langtool-http-server-port 8082)
|
|
;;
|
|
;; Now testing although, that running instance is working under HTTPSServer or via
|
|
;; general ssl support (e.g. nginx) following may be working. Again, this is now
|
|
;; testing, so please open issue when the ssl/tls connection is not working.
|
|
;;
|
|
;; (setq langtool-http-server-stream-type 'tls)
|
|
|
|
;; ## Optional settings
|
|
;;
|
|
;; * Key binding if you desired.
|
|
;;
|
|
;; (global-set-key "\C-x4w" 'langtool-check)
|
|
;; (global-set-key "\C-x4W" 'langtool-check-done)
|
|
;; (global-set-key "\C-x4l" 'langtool-switch-default-language)
|
|
;; (global-set-key "\C-x44" 'langtool-show-message-at-point)
|
|
;; (global-set-key "\C-x4c" 'langtool-interactive-correction)
|
|
|
|
;; * Default language is detected by LanguageTool automatically.
|
|
;; Please set `langtool-default-language` if you need specific language.
|
|
;;
|
|
;; (setq langtool-default-language "en-US")
|
|
;;
|
|
;; Otherwise, invoke `M-x langtool-check` with `C-u` (universal-argument)
|
|
|
|
;; * Currently GNU java version is not working.
|
|
;; Please change the variable to your favorite java executable.
|
|
;;
|
|
;; (setq langtool-java-bin "/path/to/java")
|
|
|
|
;; * Maybe your LanguageTool have launcher. (e.g. Gentoo)
|
|
;; You need to set `langtool-bin'.
|
|
;; See https://github.com/mhayashi1120/Emacs-langtool/issues/24
|
|
;;
|
|
;; (setq langtool-bin "/usr/bin/languagetool")
|
|
|
|
;; * Maybe you want to specify your mother tongue.
|
|
;;
|
|
;; (setq langtool-mother-tongue "en")
|
|
|
|
;; * To customize LanguageTool commandline arguments.
|
|
;;
|
|
;; (setq langtool-java-user-arguments '("-Dfile.encoding=UTF-8"))
|
|
;;
|
|
;; You can also make the variable to buffer local like following:
|
|
;;
|
|
;; (add-hook '**SOME**-mode-hook
|
|
;; (lambda () (set (make-local-variable 'langtool-java-user-arguments)
|
|
;; '("-Dfile.encoding=UTF-8"))))
|
|
;;
|
|
;; NOTE: Although there is no good example, `langtool-user-arguments' is
|
|
;; a similar custom variable.
|
|
|
|
;; ## Usage:
|
|
|
|
;; * To check current buffer and show warnings.
|
|
;;
|
|
;; M-x langtool-check
|
|
;;
|
|
;; Check with different language. You can complete supported language
|
|
;; with C-i/TAB
|
|
;;
|
|
;; C-u M-x langtool-check
|
|
|
|
;; * To correct marker follow LanguageTool suggestions.
|
|
;;
|
|
;; M-x langtool-correct-buffer
|
|
|
|
;; * Go to warning point you can see a report from LanguageTool.
|
|
;; Otherwise:
|
|
;;
|
|
;; M-x langtool-show-message-at-point
|
|
|
|
;; * You can optionally use extension package `langtool-popup` in this repository.
|
|
;; To show automatically popup the cursor.
|
|
|
|
;; * To finish checking. All langtool marker is removed.
|
|
;;
|
|
;; M-x langtool-check-done
|
|
|
|
;;; TODO:
|
|
|
|
;; * process coding system (test on Windows)
|
|
;; * check only docstring (emacs-lisp-mode)
|
|
;; or using (derived-mode-p 'prog-mode) and only string and comment
|
|
;; * java encoding <-> elisp encoding (No enough information..)
|
|
;; * change to --json argument to parse.
|
|
|
|
;;; Code:
|
|
|
|
|
|
(require 'cl-lib)
|
|
(require 'compile)
|
|
(require 'json)
|
|
(require 'pcase)
|
|
|
|
(defgroup langtool nil
|
|
"Customize langtool"
|
|
:prefix "langtool-"
|
|
:group 'applications)
|
|
|
|
;;;
|
|
;;; Variables / Faces
|
|
;;;
|
|
|
|
;;
|
|
;; constants
|
|
;;
|
|
|
|
(defconst langtool-output-regexp
|
|
(eval-when-compile
|
|
(concat
|
|
"^[0-9]+\\.) Line \\([0-9]+\\), column \\([0-9]+\\), Rule ID: \\(.*\\)\n"
|
|
"Message: \\(.*\\)\n"
|
|
"\\(?:Suggestion: \\(.*\\)\n\\)?"
|
|
;; As long as i can read
|
|
;; src/dev/de/danielnaber/languagetool/dev/wikipedia/OutputDumpHandler.java
|
|
"\\(\\(?:.*\\)\n\\(?:[ ^]+\\)\\)\n"
|
|
"\n?" ; last result have no new-line
|
|
)))
|
|
|
|
;;
|
|
;; externals
|
|
;;
|
|
|
|
(defvar current-prefix-arg)
|
|
(defvar unread-command-events)
|
|
(defvar locale-language-names)
|
|
|
|
;;
|
|
;; faces
|
|
;;
|
|
|
|
(defface langtool-errline
|
|
'((((class color) (background dark)) (:background "Firebrick4"))
|
|
(((class color) (background light)) (:background "LightPink"))
|
|
(t (:bold t)))
|
|
"Face used for marking error lines."
|
|
:group 'langtool)
|
|
|
|
(defface langtool-correction-face
|
|
'((((class mono)) (:inverse-video t :bold t :underline t))
|
|
(t (:background "red1" :foreground "yellow" :bold t)))
|
|
"Face used to visualize correction."
|
|
:group 'langtool)
|
|
|
|
;;
|
|
;; customize variables
|
|
;;
|
|
|
|
(defcustom langtool-java-bin "java"
|
|
"Executing java command."
|
|
:group 'langtool
|
|
:type 'file)
|
|
|
|
(defcustom langtool-bin nil
|
|
"Executing LanguageTool command."
|
|
:group 'langtool
|
|
:type 'file)
|
|
|
|
(defcustom langtool-java-user-arguments nil
|
|
"List of string which is passed to java command as arguments.
|
|
This java command holds LanguageTool process.
|
|
Otherwise, function which return above value.
|
|
|
|
e.g. ( Described at http://wiki.languagetool.org/command-line-options )
|
|
\(setq langtool-java-user-arguments \\='(\"-Dfile.encoding=UTF-8\"))"
|
|
:group 'langtool
|
|
:type '(choice
|
|
(repeat string)
|
|
function))
|
|
|
|
(defcustom langtool-language-tool-jar nil
|
|
"LanguageTool jar file.
|
|
|
|
No need to set this variable when `langtool-java-classpath' is set."
|
|
:group 'langtool
|
|
:type 'file)
|
|
|
|
(defcustom langtool-language-tool-server-jar nil
|
|
"LanguageTool server jar file.
|
|
Very fast, but do not use it if there is unreliable user on a same host."
|
|
:group 'langtool
|
|
:type 'file)
|
|
|
|
(defcustom langtool-http-server-host nil
|
|
"Normally should be \"localhost\" . Do not set the untrusted host/network.
|
|
Your post may not be encrypted application layer, so your privacy may be leaked.
|
|
|
|
Please set `langtool-http-server-port' either."
|
|
:group 'langtool
|
|
:type 'string)
|
|
|
|
(defcustom langtool-http-server-port nil
|
|
"See `langtool-http-server-host' ."
|
|
:group 'langtool
|
|
:type 'number)
|
|
|
|
(defcustom langtool-http-server-stream-type nil
|
|
"This is now testing and not enough tested yet. This value is passed to
|
|
`open-network-stream' `:type' argument.
|
|
Valid arguments are same to above except `nil'. This means `plain'."
|
|
:group 'langtool
|
|
:type 'symbol)
|
|
|
|
(defcustom langtool-java-classpath nil
|
|
"Custom classpath to use on special environment. (e.g. Arch Linux)
|
|
Do not set both of this variable and `langtool-language-tool-jar'.
|
|
|
|
https://github.com/mhayashi1120/Emacs-langtool/pull/12
|
|
https://github.com/mhayashi1120/Emacs-langtool/issues/8"
|
|
:group 'langtool
|
|
:type 'string)
|
|
|
|
(defcustom langtool-default-language nil
|
|
"Language name pass to LanguageTool command.
|
|
This is string which indicate locale or `auto' or nil.
|
|
Currently `auto' and nil is a same meaning."
|
|
:group 'langtool
|
|
:type '(choice
|
|
string
|
|
(const auto)
|
|
(const nil)))
|
|
|
|
(defcustom langtool-mother-tongue nil
|
|
"Your mothertongue Language name pass to LanguageTool."
|
|
:group 'langtool
|
|
:type 'string)
|
|
|
|
(defcustom langtool-disabled-rules nil
|
|
"Disabled rules pass to LanguageTool.
|
|
String that separated by comma or list of string."
|
|
:group 'langtool
|
|
:type '(choice
|
|
(list string)
|
|
string))
|
|
|
|
(defcustom langtool-user-arguments nil
|
|
"Similar to `langtool-java-user-arguments' except this list is appended
|
|
after `-jar' argument.
|
|
|
|
Valid values are described below:
|
|
http://wiki.languagetool.org/command-line-options
|
|
|
|
Do not change this variable if you don't understand what you are doing."
|
|
:group 'langtool
|
|
:type '(choice
|
|
(repeat string)
|
|
function))
|
|
|
|
(defcustom langtool-server-user-arguments nil
|
|
"`langtool-language-tool-server-jar' customize arguments.
|
|
You can pass `--config' option to the server that indicate java property file.
|
|
|
|
You can see all valid arguments with following command
|
|
(Replace path by yourself):
|
|
java -jar /path/to/languagetool-server.jar --help"
|
|
:group 'langtool
|
|
:type '(choice
|
|
(repeat string)
|
|
function))
|
|
|
|
(defcustom langtool-client-filter-query-function nil
|
|
"Filter function that accept one query form argument.
|
|
This query form is an alist will be encoded by `url-build-query-string'.
|
|
Call just before POST with `application/x-www-form-urlencoded'."
|
|
:group 'langtool
|
|
:type 'function)
|
|
|
|
(defcustom langtool-error-exists-hook
|
|
'(langtool-autoshow-ensure-timer)
|
|
"Hook run after LanguageTool process found any error(s)."
|
|
:group 'langtool
|
|
:type 'hook)
|
|
|
|
(defcustom langtool-noerror-hook nil
|
|
"Hook run after LanguageTool report no error."
|
|
:group 'langtool
|
|
:type 'hook)
|
|
|
|
(defcustom langtool-finish-hook
|
|
'(langtool-autoshow-cleanup-timer-maybe)
|
|
"Hook run after cleanup buffer."
|
|
:group 'langtool
|
|
:type 'hook)
|
|
|
|
;;
|
|
;; local variables
|
|
;;
|
|
|
|
(defvar langtool-local-disabled-rules nil)
|
|
(make-variable-buffer-local 'langtool-local-disabled-rules)
|
|
|
|
(defvar langtool-temp-file nil)
|
|
(make-variable-buffer-local 'langtool-temp-file)
|
|
|
|
(defvar langtool-buffer-process nil)
|
|
(make-variable-buffer-local 'langtool-buffer-process)
|
|
|
|
(defvar langtool-mode-line-message nil)
|
|
(make-variable-buffer-local 'langtool-mode-line-message)
|
|
(put 'langtool-mode-line-message 'risky-local-variable t)
|
|
|
|
(defvar langtool-mode-line-process nil)
|
|
(make-variable-buffer-local 'langtool-mode-line-process)
|
|
(put 'langtool-mode-line-process 'risky-local-variable t)
|
|
|
|
(defvar langtool-mode-line-server-process nil)
|
|
(put 'langtool-mode-line-server-process 'risky-local-variable t)
|
|
|
|
(defvar langtool-error-buffer-name " *LanguageTool Errors* ")
|
|
|
|
(defvar langtool--debug nil)
|
|
|
|
(defvar langtool--correction-keys
|
|
;; (q)uit, (c)lear, (e)dit, (i)gnore
|
|
[?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
|
|
;; suggestions may over 10.
|
|
;; define rest of alphabet just in case.
|
|
?a ?b ?d ?f ?g ?h ?j ?k ?l ?m ?n
|
|
?o ?p ?r ?s ?t ?u ?v ?w ?x ?y ?z])
|
|
|
|
;;;
|
|
;;; Internal functions
|
|
;;;
|
|
|
|
;;
|
|
;; basic functions
|
|
;;
|
|
|
|
(defun langtool-region-active-p ()
|
|
(cond
|
|
((fboundp 'region-active-p)
|
|
(funcall 'region-active-p))
|
|
(t
|
|
(and transient-mark-mode mark-active))))
|
|
|
|
(defun langtool--debug (key fmt &rest args)
|
|
(when langtool--debug
|
|
(let ((buf (get-buffer-create "*Langtool Debug*")))
|
|
(with-current-buffer buf
|
|
(goto-char (point-max))
|
|
(insert "---------- [" key "] ----------\n")
|
|
(insert (apply #'format fmt args) "\n")))))
|
|
|
|
(defun langtool--chomp (s)
|
|
(if (string-match "\\(?:\\(\r\n\\)+\\|\\(\n\\)+\\)\\'" s)
|
|
(substring s 0 (match-beginning 0))
|
|
s))
|
|
|
|
(defun langtool--make-temp-file ()
|
|
(make-temp-file "langtool-"))
|
|
|
|
;;
|
|
;; HTTP basic
|
|
;;
|
|
|
|
(defun langtool-http--parse-response-header ()
|
|
;; Not a exact parser. Just a necessary. ;-)
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(unless (re-search-forward "^\r\n" nil t)
|
|
(error "Parse error. Not found http header separator"))
|
|
(let (status headers body-start)
|
|
(setq body-start (point))
|
|
(forward-line -1)
|
|
(save-restriction
|
|
(narrow-to-region (point-min) (point))
|
|
(goto-char (point-min))
|
|
(unless (looking-at "^HTTP/[0-9.]+[\s\t]+\\([0-9]+\\)")
|
|
(error "Parse error. Not found HTTP status code"))
|
|
(setq status (string-to-number (match-string-no-properties 1)))
|
|
(forward-line)
|
|
(while (not (eobp))
|
|
(let (key value)
|
|
(unless (looking-at "^\\([^:]+\\):")
|
|
(error "Invalid header of HTTP response"))
|
|
(setq key (match-string-no-properties 1))
|
|
(goto-char (match-end 0))
|
|
(while (looking-at "[\s\t]+\\(.*\\)\r")
|
|
(setq value (concat value (match-string-no-properties 1)))
|
|
(forward-line 1))
|
|
(setq headers (cons (cons key value) headers))))
|
|
(list status headers body-start)))))
|
|
|
|
;;
|
|
;; handle error overlay
|
|
;;
|
|
|
|
;;FIXME
|
|
;;http://sourceforge.net/tracker/?func=detail&aid=3054895&group_id=110216&atid=655717
|
|
(defun langtool--fuzzy-search (context-regexp length)
|
|
(let* ((regexp (concat ".*?" context-regexp))
|
|
(default (cons (point) (+ (point) length))))
|
|
(or (and (null regexp)
|
|
(cons (point) (+ (point) length)))
|
|
(and (looking-at regexp)
|
|
(cons (match-beginning 1) (match-end 1)))
|
|
(let ((beg (min (line-beginning-position) (- (point) 20))))
|
|
(cl-loop while (and (not (bobp))
|
|
(<= beg (point)))
|
|
;; backward just sentence length to search sentence after point
|
|
do (condition-case nil
|
|
(backward-char length)
|
|
(beginning-of-buffer nil))
|
|
if (looking-at regexp)
|
|
return (cons (match-beginning 1) (match-end 1))))
|
|
default)))
|
|
|
|
;; TODO, FIXME remove _version completely. Previous version accept
|
|
;; difference output between another version
|
|
(defun langtool--compute-start&end (_version check)
|
|
(let ((line (nth 0 check))
|
|
(col (nth 1 check))
|
|
(len (nth 2 check))
|
|
(context (nth 7 check))
|
|
;; Only Server <-> Client have the data
|
|
(offset (nth 8 check)))
|
|
(cond
|
|
(offset
|
|
(let* ((start (+ (point-min) offset))
|
|
(end (+ start len)))
|
|
(cons start end)))
|
|
(context
|
|
;; Command-line client have a bug that point to wrong place.
|
|
(goto-char (point-min))
|
|
(forward-line (1- line))
|
|
;; 1. sketchy move to column that is indicated by LanguageTool.
|
|
;; 2. fuzzy match to reported sentence which indicated by ^^^ like string.
|
|
;; 3. restrict to the current line
|
|
(when (< 0 col)
|
|
(forward-char (1- col)))
|
|
(langtool--fuzzy-search context len))
|
|
(t
|
|
(goto-char (point-min))
|
|
(forward-line (1- line))
|
|
(forward-char col)
|
|
(cons (point) (+ (point) len))))))
|
|
|
|
(defun langtool--create-overlay (version check)
|
|
(cl-destructuring-bind (start . end)
|
|
(langtool--compute-start&end version check)
|
|
(let ((ov (make-overlay start end)))
|
|
(overlay-put ov 'langtool-simple-message (nth 4 check))
|
|
(overlay-put ov 'langtool-message (nth 5 check))
|
|
(overlay-put ov 'langtool-suggestions (nth 3 check))
|
|
(overlay-put ov 'langtool-rule-id (nth 6 check))
|
|
(overlay-put ov 'priority 1)
|
|
(overlay-put ov 'face 'langtool-errline))))
|
|
|
|
(defun langtool--clear-buffer-overlays ()
|
|
(mapc
|
|
(lambda (ov)
|
|
(delete-overlay ov))
|
|
(langtool--overlays-region (point-min) (point-max))))
|
|
|
|
(defun langtool--overlays-region (start end)
|
|
(sort
|
|
(remove
|
|
nil
|
|
(mapcar
|
|
(lambda (ov)
|
|
(when (overlay-get ov 'langtool-message)
|
|
ov))
|
|
(overlays-in start end)))
|
|
(lambda (ov1 ov2)
|
|
(< (overlay-start ov1) (overlay-start ov2)))))
|
|
|
|
(defun langtool--current-error-overlays ()
|
|
(remove nil
|
|
(mapcar
|
|
(lambda (ov)
|
|
(and (overlay-get ov 'langtool-message)
|
|
ov))
|
|
(overlays-at (point)))))
|
|
|
|
(defun langtool--expire-buffer-overlays ()
|
|
(mapc
|
|
(lambda (o)
|
|
(unless (overlay-get o 'face)
|
|
(delete-overlay o)))
|
|
(langtool--overlays-region (point-min) (point-max))))
|
|
|
|
(defun langtool--erase-overlay (ov)
|
|
(overlay-put ov 'face nil))
|
|
|
|
(defun langtool--next-overlay (current overlays)
|
|
(cl-loop for o in (cdr (memq current overlays))
|
|
if (overlay-get o 'face)
|
|
return o))
|
|
|
|
(defun langtool--prev-overlay (current overlays)
|
|
(cl-loop for o in (cdr (memq current (reverse overlays)))
|
|
if (overlay-get o 'face)
|
|
return o))
|
|
|
|
(defun langtool--goto-error (overlays predicate)
|
|
(catch 'done
|
|
(mapc
|
|
(lambda (ov)
|
|
(when (funcall predicate ov)
|
|
(goto-char (overlay-start ov))
|
|
(throw 'done t)))
|
|
overlays)
|
|
nil))
|
|
|
|
(defun langtool-working-p ()
|
|
(cl-loop with current = (current-buffer)
|
|
for buf in (buffer-list)
|
|
when (and (not (eq buf current))
|
|
(with-current-buffer buf
|
|
(langtool--overlays-region
|
|
(point-min) (point-max))))
|
|
return buf
|
|
finally return nil))
|
|
|
|
;;
|
|
;; utility
|
|
;;
|
|
|
|
(defun langtool-simple-error-message (overlays)
|
|
"Textify error messages as long as simple."
|
|
(mapconcat
|
|
(lambda (ov)
|
|
(format
|
|
"[%s] %s%s"
|
|
(overlay-get ov 'langtool-rule-id)
|
|
(overlay-get ov 'langtool-simple-message)
|
|
(if (overlay-get ov 'langtool-suggestions)
|
|
(concat
|
|
" -> ("
|
|
(mapconcat #'identity (overlay-get ov 'langtool-suggestions) ", ")
|
|
")")
|
|
"")))
|
|
overlays "\n"))
|
|
|
|
(defun langtool-details-error-message (overlays)
|
|
"Textify error messages."
|
|
(mapconcat
|
|
(lambda (ov)
|
|
(concat
|
|
(format "Rule ID: %s\n"
|
|
(overlay-get ov 'langtool-rule-id))
|
|
(format "Message: %s\n"
|
|
(overlay-get ov 'langtool-simple-message))
|
|
(if (overlay-get ov 'langtool-suggestions)
|
|
(concat
|
|
"Suggestions: "
|
|
(mapconcat
|
|
#'identity
|
|
(overlay-get ov 'langtool-suggestions)
|
|
"; "))
|
|
"")))
|
|
overlays
|
|
"\n\n"))
|
|
|
|
(defun langtool--current-error-messages ()
|
|
(mapcar
|
|
(lambda (ov)
|
|
(overlay-get ov 'langtool-message))
|
|
(langtool--current-error-overlays)))
|
|
|
|
;;;
|
|
;;; LanguageTool Process
|
|
;;;
|
|
|
|
;;
|
|
;; Process basic
|
|
;;
|
|
|
|
(defmacro langtool--with-java-environ (&rest form)
|
|
`(let ((coding-system-for-read langtool-process-coding-system))
|
|
(progn ,@form)))
|
|
|
|
(defun langtool--process-file-name (path)
|
|
"Correct the file name depending on the underlying platform.
|
|
|
|
PATH: The file-name path to be corrected.
|
|
|
|
Currently corrects the file-name-path when running under Cygwin."
|
|
(setq path (expand-file-name path))
|
|
(cond
|
|
((eq system-type 'cygwin)
|
|
;; no need to catch error. (e.g. cygpath is not found)
|
|
;; this failure means LanguageTools is not working completely.
|
|
(with-temp-buffer
|
|
(call-process "cygpath" nil t nil "--windows" path)
|
|
(langtool--chomp (buffer-string))))
|
|
(t
|
|
path)))
|
|
|
|
(defcustom langtool-process-coding-system
|
|
(cond
|
|
((eq system-type 'cygwin)
|
|
'dos)
|
|
(t nil))
|
|
"LanguageTool process coding-system.
|
|
Ordinary no need to change this."
|
|
:group 'langtool
|
|
:type 'coding-system)
|
|
|
|
(defun langtool--custom-arguments (var)
|
|
(let ((value (symbol-value var))
|
|
args)
|
|
(cond
|
|
((functionp value)
|
|
(setq args (funcall value)))
|
|
((consp value)
|
|
(setq args value)))
|
|
(copy-sequence args)))
|
|
|
|
;;
|
|
;; Command interaction
|
|
;;
|
|
|
|
(defun langtool--disabled-rules ()
|
|
(let ((custom langtool-disabled-rules)
|
|
(locals langtool-local-disabled-rules))
|
|
(cond
|
|
((stringp custom)
|
|
(mapconcat #'identity
|
|
(cons custom locals)
|
|
","))
|
|
(t
|
|
(mapconcat #'identity
|
|
(append custom locals)
|
|
",")))))
|
|
|
|
(defun langtool--basic-command&args ()
|
|
(cond
|
|
(langtool-bin
|
|
(list langtool-bin nil))
|
|
(t
|
|
(let (command args)
|
|
(setq command langtool-java-bin)
|
|
;; Construct arguments pass to java command
|
|
(setq args (langtool--custom-arguments 'langtool-java-user-arguments))
|
|
(cond
|
|
(langtool-java-classpath
|
|
(setq args (append
|
|
args
|
|
(list "-cp" langtool-java-classpath
|
|
"org.languagetool.commandline.Main")))
|
|
(list command args))
|
|
(langtool-language-tool-jar
|
|
(setq args (append
|
|
args
|
|
(list "-jar" (langtool--process-file-name langtool-language-tool-jar))))
|
|
(list command args))
|
|
(t nil))))))
|
|
|
|
(defun langtool--process-create-client-buffer ()
|
|
(generate-new-buffer " *Langtool* "))
|
|
|
|
(defun langtool--sentence-to-fuzzy (sentence)
|
|
(mapconcat #'regexp-quote
|
|
;; this sentence is reported by LanguageTool
|
|
(split-string sentence " +")
|
|
;; LanguageTool interpreted newline as space.
|
|
"[[:space:]\n]+?"))
|
|
|
|
(defun langtool--pointed-length (message)
|
|
(or
|
|
(and (string-match "\n\\( *\\)\\(\\^+\\)" message)
|
|
(length (match-string 2 message)))
|
|
;; never through here, but if return nil from this function make stop everything.
|
|
1))
|
|
|
|
;;FIXME sometimes LanguageTool reports wrong column.
|
|
(defun langtool--pointed-context-regexp (message)
|
|
(when (string-match "\\(.*\\)\n\\( *\\)\\(\\^+\\)" message)
|
|
(let* ((msg1 (match-string 1 message))
|
|
;; calculate marker "^" start at column
|
|
(pre (length (match-string 2 message)))
|
|
;; "^" marker length
|
|
(len (length (match-string 3 message)))
|
|
(end (+ pre len))
|
|
(sentence (substring msg1 pre end))
|
|
(regexp (cond
|
|
((string-match "^[[:space:]]+$" sentence)
|
|
;; invalid sentence only have whitespace,
|
|
;; search with around sentence.
|
|
(concat
|
|
"\\("
|
|
(let* ((count (length sentence))
|
|
(spaces (format "[[:space:]\n]\\{%d\\}" count)))
|
|
spaces)
|
|
"\\)"
|
|
;; considered truncated spaces that is caused by
|
|
;; `langtool--sentence-to-fuzzy'
|
|
"[[:space:]]*?"
|
|
;; to match the correct block
|
|
;; suffix of invalid spaces.
|
|
(langtool--sentence-to-fuzzy
|
|
(let ((from (min end (length msg1))))
|
|
;;TODO magic number.
|
|
(substring msg1 from (min (length msg1) (+ from 20)))))))
|
|
(t
|
|
(concat "\\("
|
|
(langtool--sentence-to-fuzzy sentence)
|
|
"\\)")))))
|
|
regexp)))
|
|
|
|
;;
|
|
;; Commandline / HTTP integration
|
|
;;
|
|
|
|
(defun langtool--checker-mode ()
|
|
;; NOTE: This priority is order by light weight.
|
|
(cond
|
|
((and langtool-http-server-host
|
|
langtool-http-server-port)
|
|
'http-client)
|
|
(langtool-language-tool-server-jar
|
|
'client-server)
|
|
((or langtool-language-tool-jar
|
|
langtool-java-classpath
|
|
langtool-bin)
|
|
'commandline)
|
|
(t
|
|
(error "There is no valid setting"))))
|
|
|
|
(defun langtool--apply-checks (proc checks)
|
|
(let ((source (process-get proc 'langtool-source-buffer))
|
|
(version (process-get proc 'langtool-jar-version))
|
|
(begin (process-get proc 'langtool-region-begin))
|
|
(finish (process-get proc 'langtool-region-finish)))
|
|
(when (buffer-live-p source)
|
|
(with-current-buffer source
|
|
(save-excursion
|
|
(save-restriction
|
|
(when (and begin finish)
|
|
(narrow-to-region begin finish))
|
|
(mapc
|
|
(lambda (check)
|
|
(langtool--create-overlay version check))
|
|
(nreverse checks))))))))
|
|
|
|
(defun langtool--lazy-apply-checks (proc version checks)
|
|
(let ((source (process-get proc 'langtool-source-buffer))
|
|
(begin (process-get proc 'langtool-region-begin))
|
|
(finish (process-get proc 'langtool-region-finish)))
|
|
(when (buffer-live-p source)
|
|
(with-current-buffer source
|
|
(save-excursion
|
|
(save-restriction
|
|
(when (and begin finish)
|
|
(narrow-to-region begin finish))
|
|
(cond
|
|
((consp checks)
|
|
(langtool--create-overlay version (car checks))
|
|
(run-with-idle-timer
|
|
1 nil #'langtool--lazy-apply-checks
|
|
proc version (cdr checks)))
|
|
(t
|
|
(let ((source (process-get proc 'langtool-source-buffer)))
|
|
(langtool--check-finish source nil))))))))))
|
|
|
|
(defun langtool--check-finish (source errmsg)
|
|
(let (marks face)
|
|
(when (buffer-live-p source)
|
|
(with-current-buffer source
|
|
(setq marks (langtool--overlays-region (point-min) (point-max)))
|
|
(setq face (cond
|
|
(errmsg
|
|
compilation-error-face)
|
|
(marks
|
|
compilation-warning-face)
|
|
(t
|
|
compilation-info-face)))
|
|
(setq langtool-buffer-process nil)
|
|
(setq langtool-mode-line-process
|
|
(propertize ":exit" 'face face))
|
|
(cond
|
|
(errmsg
|
|
(message "%s" errmsg))
|
|
(marks
|
|
(run-hooks 'langtool-error-exists-hook)
|
|
(message "%s"
|
|
(substitute-command-keys
|
|
"Type \\[langtool-correct-buffer] to correct buffer.")))
|
|
(t
|
|
(run-hooks 'langtool-noerror-hook)
|
|
(message "LanguageTool successfully finished with no error.")))))))
|
|
|
|
;;
|
|
;; LanguageTool Commandline
|
|
;;
|
|
|
|
(defun langtool-command--check-command ()
|
|
(cond
|
|
(langtool-bin
|
|
(unless (executable-find langtool-bin)
|
|
(error "LanguageTool command not executable")))
|
|
((or (null langtool-java-bin)
|
|
(not (executable-find langtool-java-bin)))
|
|
(error "`java` command is not found")))
|
|
(cond
|
|
(langtool-java-classpath)
|
|
(langtool-language-tool-jar
|
|
(unless (file-readable-p langtool-language-tool-jar)
|
|
(error "LanguageTool jar file is not readable"))))
|
|
(when langtool-buffer-process
|
|
(error "Another process is running")))
|
|
|
|
;; Create utf-8-unix temporary file if need. This coding-system is
|
|
;; troubleless, I think.
|
|
(defun langtool-command--maybe-create-temp-file (&optional begin finish)
|
|
(let* ((file (buffer-file-name))
|
|
(cs buffer-file-coding-system)
|
|
(cs-base (coding-system-base cs)))
|
|
(unless langtool-temp-file
|
|
(setq langtool-temp-file (langtool--make-temp-file)))
|
|
;; create temporary file to pass the text contents to LanguageTool
|
|
(when (or (null file)
|
|
(buffer-modified-p)
|
|
(and begin finish)
|
|
;; 1 is dos EOL style, this must convert to unix
|
|
;; dos (CR-LF) style EOL may destroy position of marker.
|
|
(eq (coding-system-eol-type cs) 1)
|
|
;; us-ascii is included in utf-8
|
|
(and (not (coding-system-equal cs-base 'us-ascii))
|
|
(not (coding-system-equal cs-base 'utf-8))))
|
|
(save-restriction
|
|
(widen)
|
|
(let ((coding-system-for-write 'utf-8-unix))
|
|
;; BEGIN nil means entire buffer
|
|
(write-region begin finish langtool-temp-file nil 'no-msg))
|
|
(setq file langtool-temp-file)))
|
|
file))
|
|
|
|
(defun langtool-command--invoke-process (file begin finish &optional lang)
|
|
(let ((version (langtool--jar-version)))
|
|
(cl-destructuring-bind (command args)
|
|
(langtool--basic-command&args)
|
|
;; Construct arguments pass to jar file.
|
|
;; http://wiki.languagetool.org/command-line-options
|
|
(setq args (append
|
|
args
|
|
(list
|
|
"-d" (langtool--disabled-rules))))
|
|
(cond
|
|
((stringp (or lang langtool-default-language))
|
|
(setq args (append args (list "-l" (or lang langtool-default-language)))))
|
|
(t
|
|
(setq args (append args (list "--autoDetect")))))
|
|
(when langtool-mother-tongue
|
|
(setq args (append args (list "-m" langtool-mother-tongue))))
|
|
(setq args (append args (langtool--custom-arguments 'langtool-user-arguments)))
|
|
(setq args (append args (list (langtool--process-file-name file))))
|
|
(langtool--debug "Command" "%s: %s" command args)
|
|
(let* ((buffer (langtool--process-create-client-buffer))
|
|
(proc (langtool--with-java-environ
|
|
(apply #'start-process "LanguageTool" buffer command args))))
|
|
(set-process-filter proc 'langtool-command--process-filter)
|
|
(set-process-sentinel proc 'langtool-command--process-sentinel)
|
|
(process-put proc 'langtool-source-buffer (current-buffer))
|
|
(process-put proc 'langtool-region-begin begin)
|
|
(process-put proc 'langtool-region-finish finish)
|
|
(process-put proc 'langtool-jar-version version)
|
|
proc))))
|
|
|
|
(defun langtool-command--process-filter (proc event)
|
|
(langtool--debug "Filter" "%s" event)
|
|
(with-current-buffer (process-buffer proc)
|
|
(goto-char (point-max))
|
|
(insert event)
|
|
(let ((min (or (process-get proc 'langtool-process-done)
|
|
(point-min)))
|
|
checks)
|
|
(goto-char min)
|
|
(while (re-search-forward langtool-output-regexp nil t)
|
|
(let* ((line (string-to-number (match-string 1)))
|
|
(column (1- (string-to-number (match-string 2))))
|
|
(rule-id (match-string 3))
|
|
(suggest (match-string 5))
|
|
(msg1 (match-string 4))
|
|
;; rest of line. Point the raw message.
|
|
(msg2 (match-string 6))
|
|
(message
|
|
(concat "Rule ID: " rule-id "\n"
|
|
msg1 "\n\n"
|
|
msg2))
|
|
(suggestions (and suggest (split-string suggest "; ")))
|
|
(context (langtool--pointed-context-regexp msg2))
|
|
(len (langtool--pointed-length msg2)))
|
|
(setq checks (cons
|
|
(list line column len suggestions
|
|
msg1 message rule-id context)
|
|
checks))))
|
|
(process-put proc 'langtool-process-done (point))
|
|
(langtool--apply-checks proc checks))))
|
|
|
|
(defun langtool-command--process-sentinel (proc event)
|
|
(langtool--debug "Sentinel" "event: %s" event)
|
|
(unless (process-live-p proc)
|
|
(let ((code (process-exit-status proc))
|
|
(pbuf (process-buffer proc))
|
|
(source (process-get proc 'langtool-source-buffer))
|
|
errmsg)
|
|
(cond
|
|
((buffer-live-p pbuf)
|
|
(when (/= code 0)
|
|
;; Get first line of output.
|
|
(with-current-buffer pbuf
|
|
(goto-char (point-min))
|
|
(setq errmsg
|
|
(format "LanguageTool exited abnormally with code %d (%s)"
|
|
code (buffer-substring (point) (line-end-position))))))
|
|
(kill-buffer pbuf))
|
|
(t
|
|
(setq errmsg "Buffer was dead")))
|
|
(langtool--check-finish source errmsg))))
|
|
|
|
;;;
|
|
;;; Adapter for internal/external server
|
|
;;;
|
|
|
|
(defvar langtool-adapter--plist nil)
|
|
|
|
(defun langtool-adapter-ensure-internal (process)
|
|
(setq langtool-adapter--plist
|
|
(cons 'internal
|
|
(list
|
|
'process process
|
|
'finalizer `(lambda () (langtool-server-ensure-stop ,process))
|
|
'host (process-get process 'langtool-server-host)
|
|
'port (process-get process 'langtool-server-port)))))
|
|
|
|
(defun langtool-adapter-ensure-external ()
|
|
(setq langtool-adapter--plist
|
|
(cons 'external
|
|
(list
|
|
'host langtool-http-server-host
|
|
'port langtool-http-server-port
|
|
'stream-type langtool-http-server-stream-type))))
|
|
|
|
(defun langtool-adapter-get (key)
|
|
(plist-get (cdr langtool-adapter--plist) key))
|
|
|
|
(defun langtool-adapter-ensure-terminate ()
|
|
(when langtool-adapter--plist
|
|
(let ((finalizer (langtool-adapter-get 'finalizer)))
|
|
(when finalizer
|
|
(funcall finalizer)))
|
|
(setq langtool-adapter--plist nil)))
|
|
|
|
;;
|
|
;; LanguageTool HTTP Server <-> Client
|
|
;;
|
|
|
|
(defun langtool-server--check-command ()
|
|
(cond
|
|
((or (null langtool-java-bin)
|
|
(not (executable-find langtool-java-bin)))
|
|
(error "java command is not found")))
|
|
(unless langtool-language-tool-server-jar
|
|
(error "Please set `langtool-language-tool-server-jar'"))
|
|
(unless (file-readable-p langtool-language-tool-server-jar)
|
|
(error "languagetool-server jar file is not readable")))
|
|
|
|
(defun langtool-http-client-check-command ()
|
|
;; Currently no need to check command. Just HTTP post.
|
|
)
|
|
|
|
(defun langtool-server-ensure-stop (proc)
|
|
(when (processp proc)
|
|
(let ((buffer (process-buffer proc)))
|
|
(delete-process proc)
|
|
(when (buffer-live-p buffer)
|
|
(kill-buffer buffer)))))
|
|
|
|
(defun langtool-server--parse-initial-buffer ()
|
|
(save-excursion
|
|
(goto-char (point-min))
|
|
(cond
|
|
((re-search-forward (eval-when-compile
|
|
(concat
|
|
"Starting LanguageTool "
|
|
"\\([0-9.]+\\)\\(?:-SNAPSHOT\\)? "
|
|
".+?"
|
|
"server on https?://\\([^:]+\\):\\([0-9]+\\)"
|
|
"\\.\\.\\."
|
|
"$"))
|
|
nil t))
|
|
(t
|
|
(error "Unable parse initial buffer")))
|
|
(let ((version (match-string 1))
|
|
(host (match-string 2))
|
|
(port (string-to-number (match-string 3))))
|
|
(list version host port))))
|
|
|
|
(defun langtool-server--rendezvous (proc buffer)
|
|
(message "Waiting for server")
|
|
(catch 'rendezvous
|
|
(with-current-buffer buffer
|
|
(save-excursion
|
|
(while t
|
|
(goto-char (point-min))
|
|
(when (re-search-forward "Server started" nil t)
|
|
(cl-destructuring-bind (version host port)
|
|
(langtool-server--parse-initial-buffer)
|
|
(when (version< version "4.0")
|
|
(langtool-server-ensure-stop proc)
|
|
(error "LanguageTool Server version must be than 4.0 but now %s"
|
|
version))
|
|
(process-put proc 'langtool-server-host host)
|
|
(process-put proc 'langtool-server-port port)
|
|
(message "%s done." (current-message))
|
|
(throw 'rendezvous t)))
|
|
(unless (eq (process-status proc) 'run)
|
|
(langtool-server-ensure-stop proc)
|
|
(error "Failed to start LanguageTool Server"))
|
|
(message "%s." (current-message))
|
|
(accept-process-output proc 0.1 nil t))))))
|
|
|
|
(defvar langtool-server--process-exit-hook nil)
|
|
|
|
(defun langtool-server--process-sentinel (proc event)
|
|
(langtool--debug "Sentinel" "event: %s" event)
|
|
(unless (process-live-p proc)
|
|
(run-hooks 'langtool-server--process-exit-hook)))
|
|
|
|
(defun langtool-server--ensure-running ()
|
|
(langtool-server--check-command)
|
|
(unless (let ((proc (langtool-adapter-get 'process)))
|
|
(and (processp proc)
|
|
(eq (process-status proc) 'run)))
|
|
;; Force terminate previous server process if exists.
|
|
(langtool-adapter-ensure-terminate)
|
|
(let* ((bin langtool-java-bin)
|
|
(args '()))
|
|
;; jar Default setting is "HTTPSServer" .
|
|
;; This application no need to use SSL since local app.
|
|
;; http://wiki.languagetool.org/http-server
|
|
(setq args (append args (list
|
|
"-cp" (langtool--process-file-name
|
|
langtool-language-tool-server-jar))))
|
|
(setq args (append args (list "org.languagetool.server.HTTPServer")))
|
|
(setq args (append args langtool-server-user-arguments))
|
|
(langtool--debug "HTTPServer" "%s: %s" bin args)
|
|
(let* ((buffer (get-buffer-create " *LangtoolHttpServer* "))
|
|
(proc (apply
|
|
#'start-process
|
|
"LangtoolHttpServer" buffer
|
|
bin
|
|
args)))
|
|
(langtool-server--rendezvous proc buffer)
|
|
(set-process-sentinel proc 'langtool-server--process-sentinel)
|
|
(langtool-adapter-ensure-internal proc)
|
|
proc))))
|
|
|
|
(defun langtool-client--parse-response-json ()
|
|
(let* ((json (json-read))
|
|
(matches (cdr (assq 'matches json)))
|
|
(software (cdr (assq 'software json)))
|
|
(version (cdr (assq 'version software)))
|
|
checks)
|
|
(cl-loop for match across matches
|
|
do (let* ((offset (cdr (assoc 'offset match)))
|
|
(len (cdr (assoc 'length match)))
|
|
(rule (cdr (assoc 'rule match)))
|
|
(rule-id (cdr (assoc 'id rule)))
|
|
(replacements (cdr (assoc 'replacements match)))
|
|
(suggestions (mapcar
|
|
(lambda (x) (cdr (assoc 'value x)))
|
|
replacements))
|
|
(msg1 (cdr (assoc 'message match)))
|
|
;; rest of line. Point the raw message.
|
|
(msg2 (cdr (assoc 'shortMessage match)))
|
|
(message
|
|
(concat "Rule ID: " rule-id "\n"
|
|
msg1 "\n\n"
|
|
msg2))
|
|
;; No need this value when json
|
|
(context nil)
|
|
(line nil)
|
|
(column nil))
|
|
(setq checks (cons
|
|
(list line column len suggestions
|
|
msg1 message rule-id context
|
|
offset)
|
|
checks))))
|
|
(setq checks (nreverse checks))
|
|
(list version checks)))
|
|
|
|
(defun langtool-client--parse-response-body (http-headers)
|
|
(let ((ct (cdr (assoc-string "content-type" http-headers t))))
|
|
(cond
|
|
((string= ct "application/json")
|
|
(langtool-client--parse-response-json))
|
|
(t
|
|
(error "Not a supported Content-Type %s" ct)))))
|
|
|
|
(defun langtool-client--process-sentinel (proc _event)
|
|
(unless (process-live-p proc)
|
|
(let ((pbuf (process-buffer proc))
|
|
(source (process-get proc 'langtool-source-buffer))
|
|
errmsg version checks)
|
|
(with-current-buffer pbuf
|
|
(cl-destructuring-bind (status headers body-start)
|
|
(langtool-http--parse-response-header)
|
|
(goto-char body-start)
|
|
(cond
|
|
((= status 200)
|
|
(cl-destructuring-bind (ver result)
|
|
(langtool-client--parse-response-body headers)
|
|
(setq checks result)
|
|
(setq version ver)))
|
|
(t
|
|
(setq errmsg (buffer-substring-no-properties (point) (point-max)))))
|
|
(kill-buffer pbuf)))
|
|
;; after cleanup buffer.
|
|
(cond
|
|
(errmsg
|
|
(langtool--check-finish source errmsg))
|
|
(t
|
|
(langtool--lazy-apply-checks proc version checks))))))
|
|
|
|
(defun langtool-client--process-filter (proc event)
|
|
(langtool--debug "Filter" "%s" event)
|
|
(with-current-buffer (process-buffer proc)
|
|
(goto-char (point-max))
|
|
(insert event)))
|
|
|
|
(defun langtool-client--make-post-data (&optional begin finish lang)
|
|
(let* ((text (buffer-substring-no-properties (or begin (point-min)) (or finish (point-max))))
|
|
(disabled-rules (langtool--disabled-rules))
|
|
(language (cond
|
|
((stringp (or lang langtool-default-language))
|
|
(or lang langtool-default-language))
|
|
(t
|
|
"auto")))
|
|
(query `(
|
|
("language" ,language)
|
|
("text" ,text)
|
|
,@(and langtool-mother-tongue
|
|
`(("motherTongue" ,langtool-mother-tongue)))
|
|
("disabledRules" ,disabled-rules)))
|
|
query-string)
|
|
(when (and langtool-client-filter-query-function
|
|
(functionp langtool-client-filter-query-function))
|
|
(setq query (funcall langtool-client-filter-query-function query)))
|
|
;; UTF-8 encoding if value is multibyte character
|
|
(setq query-string (url-build-query-string query))
|
|
query-string))
|
|
|
|
(defun langtool-client--http-post (data)
|
|
(let* ((host (langtool-adapter-get 'host))
|
|
(port (langtool-adapter-get 'port))
|
|
(buffer (langtool--process-create-client-buffer))
|
|
(url-path "/v2/check")
|
|
(client (let ((coding-system-for-write 'binary)
|
|
(coding-system-for-read 'utf-8-unix))
|
|
(open-network-stream
|
|
"LangtoolHttpClient" buffer host port
|
|
:type (or (langtool-adapter-get 'stream-type) 'plain)))))
|
|
(process-send-string
|
|
client
|
|
(concat
|
|
(format "POST %s HTTP/1.1\r\n" url-path)
|
|
(format "Host: %s:%d\r\n" host port)
|
|
(format "Content-length: %d\r\n" (length data))
|
|
(format "Content-Type: application/x-www-form-urlencoded\r\n")
|
|
(format "\r\n")
|
|
data))
|
|
(process-send-eof client)
|
|
client))
|
|
|
|
(defun langtool-client--invoke-process (&optional begin finish lang)
|
|
(let* ((data (langtool-client--make-post-data begin finish lang))
|
|
(proc (langtool-client--http-post data)))
|
|
(set-process-sentinel proc 'langtool-client--process-sentinel)
|
|
(set-process-filter proc 'langtool-client--process-filter)
|
|
(process-put proc 'langtool-source-buffer (current-buffer))
|
|
(process-put proc 'langtool-region-begin begin)
|
|
(process-put proc 'langtool-region-finish finish)
|
|
proc))
|
|
|
|
;;
|
|
;; HTTP or commandline interface caller
|
|
;;
|
|
|
|
(defun langtool--invoke-checker-process (&optional begin finish lang)
|
|
(when (listp mode-line-process)
|
|
(add-to-list 'mode-line-process '(t langtool-mode-line-message)))
|
|
;; clear previous check
|
|
(langtool--clear-buffer-overlays)
|
|
(let (proc)
|
|
(cl-ecase (langtool--checker-mode)
|
|
((commandline)
|
|
;; Ensure adapter is closed. That has been constructed other checker-mode.
|
|
(langtool-adapter-ensure-terminate)
|
|
(let ((file (langtool-command--maybe-create-temp-file begin finish)))
|
|
(setq proc (langtool-command--invoke-process file begin finish lang))))
|
|
((client-server)
|
|
(langtool-server--ensure-running)
|
|
(setq langtool-mode-line-server-process
|
|
(propertize ":server" 'face compilation-info-face))
|
|
(add-hook 'langtool-server--process-exit-hook
|
|
(lambda ()
|
|
(setq langtool-mode-line-server-process nil)))
|
|
(setq proc (langtool-client--invoke-process begin finish lang)))
|
|
((http-client)
|
|
(langtool-adapter-ensure-terminate)
|
|
;; Construct new adapter each check.
|
|
;; Since maybe change customize variable in a Emacs session.
|
|
(langtool-adapter-ensure-external)
|
|
(setq proc (langtool-client--invoke-process begin finish lang))))
|
|
(setq langtool-buffer-process proc)
|
|
(setq langtool-mode-line-process
|
|
(propertize ":run" 'face compilation-info-face))
|
|
(setq langtool-mode-line-message
|
|
(list " "
|
|
"LT" ; LT <= LanguageTool shorthand
|
|
'langtool-mode-line-server-process
|
|
'langtool-mode-line-process))))
|
|
|
|
(defun langtool--cleanup-process ()
|
|
;; cleanup mode-line
|
|
(let ((cell (and (listp mode-line-process) ; Check type
|
|
(rassoc '(langtool-mode-line-message) mode-line-process))))
|
|
(when cell
|
|
(setq mode-line-process (remq cell mode-line-process))))
|
|
(when (and langtool-buffer-process
|
|
(processp langtool-buffer-process))
|
|
;; TODO buffer killed, error. if process is local process (e.g. urllib)
|
|
(delete-process langtool-buffer-process))
|
|
(kill-local-variable 'langtool-buffer-process)
|
|
(kill-local-variable 'langtool-mode-line-message)
|
|
(kill-local-variable 'langtool-local-disabled-rules)
|
|
(langtool--clear-buffer-overlays)
|
|
(run-hooks 'langtool-finish-hook))
|
|
|
|
(defun langtool--check-command ()
|
|
(cl-ecase (langtool--checker-mode)
|
|
((commandline)
|
|
(langtool-command--check-command))
|
|
((client-server)
|
|
(langtool-server--check-command))
|
|
((http-client)
|
|
(langtool-http-client-check-command))))
|
|
|
|
(defun langtool--brief-execute (langtool-args parser)
|
|
(pcase (langtool--basic-command&args)
|
|
(`(,command ,args)
|
|
;; Construct arguments pass to jar file.
|
|
(setq args (append args langtool-args))
|
|
(with-temp-buffer
|
|
(when (and command args
|
|
(executable-find command)
|
|
(= (langtool--with-java-environ
|
|
(apply #'call-process command nil t nil args))
|
|
0))
|
|
(goto-char (point-min))
|
|
(funcall parser))))
|
|
(_
|
|
nil)))
|
|
|
|
(defun langtool--available-languages ()
|
|
(langtool--brief-execute
|
|
(list "--list")
|
|
(lambda ()
|
|
(let ((res '()))
|
|
(while (re-search-forward "^\\([^\s\t]+\\)" nil t)
|
|
(setq res (cons (match-string 1) res)))
|
|
(nreverse res)))))
|
|
|
|
(defun langtool--jar-version-string ()
|
|
(langtool--brief-execute
|
|
(list "--version")
|
|
(lambda ()
|
|
(langtool--chomp (buffer-string)))))
|
|
|
|
(defun langtool--jar-version ()
|
|
(let ((string (langtool--jar-version-string)))
|
|
(cond
|
|
((null string) nil)
|
|
((string-match "version \\([0-9.]+\\)" string)
|
|
(match-string 1 string))
|
|
(t
|
|
;; Unknown version, but should not raise error in this function.
|
|
"0.0"))))
|
|
|
|
;;
|
|
;; interactive correction
|
|
;;
|
|
|
|
(defun langtool--ignore-rule (rule overlays)
|
|
(cl-loop for ov in overlays
|
|
do (let ((r (overlay-get ov 'langtool-rule-id)))
|
|
(when (equal r rule)
|
|
(langtool--erase-overlay ov)))))
|
|
|
|
(defun langtool--correction (overlays)
|
|
(let ((conf (current-window-configuration)))
|
|
(unwind-protect
|
|
(let ((next (car overlays)))
|
|
(while (setq next (langtool--correction-loop next overlays))))
|
|
(langtool--expire-buffer-overlays)
|
|
(set-window-configuration conf)
|
|
(kill-buffer (langtool--correction-buffer)))))
|
|
|
|
(defun langtool--correction-loop (ov overlays)
|
|
(let* ((suggests (overlay-get ov 'langtool-suggestions))
|
|
(msg (overlay-get ov 'langtool-simple-message))
|
|
(alist (langtool--correction-popup msg suggests)))
|
|
(catch 'next
|
|
(while (progn
|
|
(goto-char (overlay-start ov))
|
|
(let (message-log-max)
|
|
(message (concat "C-h or ? for more options; "
|
|
"SPC to leave unchanged, "
|
|
"Digit to replace word")))
|
|
(let* ((echo-keystrokes) ; suppress echoing
|
|
(c (downcase (read-char)))
|
|
(pair (assq c alist)))
|
|
(cond
|
|
(pair
|
|
(let ((sug (nth 1 pair)))
|
|
;;TODO when region contains newline.
|
|
;; -> insert newline after suggestion.
|
|
(delete-region (overlay-start ov) (overlay-end ov))
|
|
(insert sug)
|
|
(langtool--erase-overlay ov))
|
|
nil)
|
|
((memq c '(?q))
|
|
(keyboard-quit))
|
|
((memq c '(?c))
|
|
(langtool--erase-overlay ov)
|
|
nil)
|
|
((memq c '(?e))
|
|
(message (substitute-command-keys
|
|
"Type \\[exit-recursive-edit] to finish the edit."))
|
|
(recursive-edit)
|
|
;; stay current cursor and wait next user command.
|
|
(throw 'next ov))
|
|
((memq c '(?i))
|
|
(let ((rule (overlay-get ov 'langtool-rule-id)))
|
|
(unless (member rule langtool-local-disabled-rules)
|
|
(setq langtool-local-disabled-rules
|
|
(cons rule langtool-local-disabled-rules)))
|
|
(langtool--ignore-rule rule overlays))
|
|
nil)
|
|
((memq c '(?\C-h ?\?))
|
|
(langtool--correction-help)
|
|
t)
|
|
((memq c '(?\d))
|
|
(throw 'next (langtool--prev-overlay ov overlays)))
|
|
((memq c '(?\s)) nil)
|
|
(t (ding) t)))))
|
|
;; next item
|
|
(langtool--next-overlay ov overlays))))
|
|
|
|
(defun langtool--correction-popup (msg suggests)
|
|
(let ((buf (langtool--correction-buffer)))
|
|
(delete-other-windows)
|
|
(let ((win (split-window)))
|
|
(set-window-buffer win buf))
|
|
(with-current-buffer buf
|
|
(let ((inhibit-read-only t))
|
|
(erase-buffer)
|
|
(insert msg "\n\n")
|
|
(cl-loop for s in suggests
|
|
for c across langtool--correction-keys
|
|
do (progn
|
|
(insert "(" c ") ")
|
|
(let ((start (point)))
|
|
(insert s)
|
|
;; colorize suggestion.
|
|
;; suggestion may contains whitespace.
|
|
(let ((ov (make-overlay start (point))))
|
|
(overlay-put ov 'face 'langtool-correction-face)))
|
|
(insert "\n"))
|
|
collect (list c s))))))
|
|
|
|
(defun langtool--correction-help ()
|
|
(let ((help-1 "[q/Q]uit correction; [c/C]lear the colorized text; ")
|
|
(help-2 "[i/I]gnore the rule over current session.")
|
|
(help-3 "[e/E]dit the buffer manually")
|
|
(help-4 "SPC skip; DEL move backward;"))
|
|
(save-window-excursion
|
|
(unwind-protect
|
|
(let ((resize-mini-windows 'grow-only))
|
|
(select-window (minibuffer-window))
|
|
(erase-buffer)
|
|
(message nil)
|
|
;;(set-minibuffer-window (selected-window))
|
|
(enlarge-window 2)
|
|
(insert (concat help-1 "\n" help-2 "\n" help-3 "\n" help-4))
|
|
(sit-for 5))
|
|
(erase-buffer)))))
|
|
|
|
(defun langtool--correction-buffer ()
|
|
(get-buffer-create "*Langtool Correction*"))
|
|
|
|
;;
|
|
;; Misc UI
|
|
;;
|
|
|
|
(defun langtool--show-message-buffer (msg)
|
|
(let ((buf (get-buffer-create langtool-error-buffer-name)))
|
|
(with-current-buffer buf
|
|
(erase-buffer)
|
|
(insert msg))
|
|
(save-window-excursion
|
|
(display-buffer buf)
|
|
(let* ((echo-keystrokes)
|
|
(event (read-event)))
|
|
(setq unread-command-events (list event))))))
|
|
|
|
;;
|
|
;; initialize
|
|
;;
|
|
|
|
(defun langtool--guess-language ()
|
|
(let ((env (or (getenv "LANG")
|
|
(getenv "LC_ALL")))
|
|
(supported-langs (langtool--available-languages))
|
|
lang country mems)
|
|
(and env
|
|
(string-match "\\`\\(..\\)_\\(..\\)?" env)
|
|
(setq lang (downcase (match-string 1 env)))
|
|
(setq country (and (match-string 2 env)
|
|
(upcase (match-string 2 env)))))
|
|
(or
|
|
(and
|
|
lang country
|
|
(setq mems (member (format "%s-%s" lang country) supported-langs))
|
|
(car mems))
|
|
(and
|
|
lang
|
|
(setq mems (cl-member-if
|
|
(lambda (x) (string-match
|
|
(concat "\\`" (regexp-quote lang)) x))
|
|
supported-langs))
|
|
(car mems)))))
|
|
|
|
;;
|
|
;; autoshow message
|
|
;;
|
|
|
|
(defcustom langtool-autoshow-message-function
|
|
#'langtool-autoshow-default-message
|
|
"Function with one argument which displaying error overlays reported
|
|
by LanguageTool. These overlays hold some useful properties:
|
|
`langtool-simple-message', `langtool-rule-id', `langtool-suggestions' .
|
|
`langtool-autoshow-default-message' is a default/sample implementations.
|
|
See the Commentary section for `popup' implementation."
|
|
:group 'langtool
|
|
:type '(choice
|
|
(const nil)
|
|
function))
|
|
|
|
(defcustom langtool-autoshow-idle-delay 0.5
|
|
"Number of seconds while idle time to wait before showing error message."
|
|
:group 'langtool
|
|
:type 'number)
|
|
|
|
(defvar langtool-autoshow--current-idle-delay nil)
|
|
|
|
(defvar langtool-autoshow--timer nil
|
|
"Hold idle timer watch every LanguageTool processed buffer.")
|
|
|
|
(defun langtool-autoshow-default-message (overlays)
|
|
;; Do not interrupt current message
|
|
(unless (current-message)
|
|
(let ((msg (langtool-simple-error-message overlays)))
|
|
(message "%s" msg))))
|
|
|
|
(defun langtool-autoshow--maybe ()
|
|
(when langtool-autoshow-message-function
|
|
(let ((delay (langtool-autoshow--idle-delay)))
|
|
(cond
|
|
((equal langtool-autoshow--current-idle-delay delay))
|
|
(t
|
|
(setq langtool-autoshow--current-idle-delay delay)
|
|
(timer-set-idle-time langtool-autoshow--timer
|
|
langtool-autoshow--current-idle-delay t))))
|
|
(condition-case err
|
|
(let ((error-overlays (langtool--current-error-overlays)))
|
|
(when error-overlays
|
|
(funcall langtool-autoshow-message-function error-overlays)))
|
|
(error
|
|
(message "langtool: %s" err)))))
|
|
|
|
(defun langtool-autoshow--idle-delay ()
|
|
(if (numberp langtool-autoshow-idle-delay)
|
|
langtool-autoshow-idle-delay
|
|
(default-value 'langtool-autoshow-idle-delay)))
|
|
|
|
(defun langtool-autoshow-ensure-timer ()
|
|
(unless (and (timerp langtool-autoshow--timer)
|
|
(memq langtool-autoshow--timer timer-idle-list))
|
|
(setq langtool-autoshow--timer
|
|
(run-with-idle-timer
|
|
(langtool-autoshow--idle-delay) t 'langtool-autoshow--maybe)))
|
|
(add-hook 'kill-buffer-hook #'langtool-autoshow-cleanup-timer-maybe nil t))
|
|
|
|
(defun langtool-autoshow-cleanup-timer-maybe ()
|
|
(unless (langtool-working-p)
|
|
(when (timerp langtool-autoshow--timer)
|
|
(cancel-timer langtool-autoshow--timer)
|
|
(setq langtool-autoshow--timer nil))))
|
|
|
|
;;;
|
|
;;; interactive commands
|
|
;;;
|
|
|
|
(defun langtool-read-lang-name ()
|
|
(let ((completion-ignore-case t)
|
|
(set
|
|
(append
|
|
'(("auto" . auto))
|
|
(or (mapcar #'list (langtool--available-languages))
|
|
(mapcar (lambda (x) (list (car x))) locale-language-names)))))
|
|
(let ((key (completing-read "Lang: " set)))
|
|
(or (cdr (assoc key set)) key))))
|
|
|
|
(defun langtool-goto-next-error ()
|
|
"Obsoleted function. Should use `langtool-correct-buffer'.
|
|
Go to next error."
|
|
(interactive)
|
|
(let ((overlays (langtool--overlays-region (point) (point-max))))
|
|
(langtool--goto-error
|
|
overlays
|
|
(lambda (ov) (< (point) (overlay-start ov))))))
|
|
|
|
(defun langtool-goto-previous-error ()
|
|
"Obsoleted function. Should use `langtool-correct-buffer'.
|
|
Goto previous error."
|
|
(interactive)
|
|
(let ((overlays (langtool--overlays-region (point-min) (point))))
|
|
(langtool--goto-error
|
|
(reverse overlays)
|
|
(lambda (ov) (< (overlay-end ov) (point))))))
|
|
|
|
(defun langtool-show-message-at-point ()
|
|
"Show error details at point."
|
|
(interactive)
|
|
(let ((ovs (langtool--current-error-overlays)))
|
|
(if (null ovs)
|
|
(message "No errors")
|
|
(let ((msg (langtool-details-error-message ovs)))
|
|
(langtool--show-message-buffer msg)))))
|
|
|
|
(defun langtool-show-brief-message-at-point ()
|
|
"Show error brief message at point."
|
|
(interactive)
|
|
(let ((msgs (langtool--current-error-messages)))
|
|
(if (null msgs)
|
|
(message "No errors")
|
|
(langtool--show-message-buffer
|
|
(mapconcat #'identity msgs "\n")))))
|
|
|
|
(defun langtool-check-done ()
|
|
"Finish LanguageTool process and cleanup existing colorized texts."
|
|
(interactive)
|
|
(langtool--cleanup-process)
|
|
(force-mode-line-update)
|
|
(message "Cleaned up LanguageTool."))
|
|
|
|
;;;###autoload
|
|
(defalias 'langtool-check #'langtool-check-buffer)
|
|
|
|
;;;###autoload
|
|
(defun langtool-check-buffer (&optional lang)
|
|
"Check context current buffer and light up errors.
|
|
Optional \\[universal-argument] read LANG name.
|
|
|
|
You can change the `langtool-default-language' to apply all session.
|
|
Restrict to selection when region is activated."
|
|
(interactive
|
|
(when current-prefix-arg
|
|
(list (langtool-read-lang-name))))
|
|
(langtool--check-command)
|
|
;; probablly ok...
|
|
(let* ((region-p (langtool-region-active-p))
|
|
(begin (and region-p (region-beginning)))
|
|
(finish (and region-p (region-end))))
|
|
(when region-p
|
|
(deactivate-mark))
|
|
(langtool--invoke-checker-process begin finish lang)
|
|
(force-mode-line-update)))
|
|
|
|
;;;###autoload
|
|
(defun langtool-switch-default-language (lang)
|
|
"Switch `langtool-default-language' to LANG."
|
|
(interactive (list (langtool-read-lang-name)))
|
|
(setq langtool-default-language lang)
|
|
(message "Now default language is `%s'" lang))
|
|
|
|
(defun langtool-correct-region (start end)
|
|
"Execute interactive correction after `langtool-check' on the region."
|
|
(let ((ovs (langtool--overlays-region start end)))
|
|
(if (null ovs)
|
|
(message "No error found. %s"
|
|
(substitute-command-keys
|
|
(concat
|
|
"Type \\[langtool-check-done] to finish checking "
|
|
"or type \\[langtool-check] to re-check buffer")))
|
|
(barf-if-buffer-read-only)
|
|
(langtool--correction ovs))))
|
|
|
|
;; Remaining backward compat. Should use `langtool-interactive-correction'
|
|
(defun langtool-correct-buffer ()
|
|
"Execute interactive correction after `langtool-check'."
|
|
(interactive)
|
|
(langtool-correct-region (point-min) (point-max)))
|
|
|
|
(defun langtool-correct-at-point ()
|
|
"Execute interactive correction at the point."
|
|
(interactive)
|
|
(langtool-correct-region (point) (point)))
|
|
|
|
(defun langtool-interactive-correction ()
|
|
"Execute interactive correction for the current editor context.
|
|
If region active, just correct that range."
|
|
(interactive)
|
|
(cond
|
|
((langtool-region-active-p)
|
|
(let ((start (region-beginning))
|
|
(end (region-end)))
|
|
(deactivate-mark)
|
|
(langtool-correct-region start end)))
|
|
(t
|
|
(langtool-correct-region (point-min) (point-max)))))
|
|
|
|
(defun langtool-server-stop ()
|
|
"Terminate LanguageTool HTTP server."
|
|
(interactive)
|
|
(langtool-adapter-ensure-terminate)
|
|
(message "Server is terminated."))
|
|
|
|
(defun langtool-toggle-debug ()
|
|
"Toggle LanguageTool debugging."
|
|
(interactive)
|
|
(setq langtool--debug (not langtool--debug))
|
|
(if langtool--debug
|
|
(message "Langtool debug ON.")
|
|
(message "Langtool debug off.")))
|
|
|
|
;;;
|
|
;;; initialize
|
|
;;;
|
|
|
|
;; initialize custom variables guessed from environment.
|
|
(let ((mt (langtool--guess-language)))
|
|
(unless langtool-mother-tongue
|
|
(setq langtool-mother-tongue mt)))
|
|
|
|
(provide 'langtool)
|
|
|
|
;;; langtool.el ends here
|