#+begin_src emacs-lisp
(require 'go-translate)
- (setq gts-translate-list '(("en" "de")))
+ (setq gt-translate-list '(("en" "de")))
- ;; (setq gts-default-translator (gts-translator :engines (gts-bing-engine)))
-
- (setq gts-default-translator
- (gts-translator
- :picker (gts-prompt-picker)
- :engines (list (gts-bing-engine) (gts-google-engine))
- :render (gts-buffer-render)))
+ (setq gt-default-translator
+ (gt-translator
+ :engines (list (gt-bing-engine) (gt-google-engine))
+ :render (gt-buffer-render)))
#+end_src
* [[http://www.mew.org][mew]] email
+++ /dev/null
-;;; go-translate-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
-;;
-;;; Code:
-
-(add-to-list 'load-path (directory-file-name
- (or (file-name-directory #$) (car load-path))))
-
-\f
-;;;### (autoloads nil "go-translate" "go-translate.el" (0 0 0 0))
-;;; Generated autoloads from go-translate.el
-
-(autoload 'gts-do-translate "go-translate" "\
-Do the translate" t nil)
-
-(register-definition-prefixes "go-translate" '("gts-default-translator"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-core" "gts-core.el" (0 0 0 0))
-;;; Generated autoloads from gts-core.el
-
-(register-definition-prefixes "gts-core" '("gts-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-bing" "gts-engine-bing.el" (0 0
-;;;;;; 0 0))
-;;; Generated autoloads from gts-engine-bing.el
-
-(register-definition-prefixes "gts-engine-bing" '("gts-bing-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-deepl" "gts-engine-deepl.el" (0
-;;;;;; 0 0 0))
-;;; Generated autoloads from gts-engine-deepl.el
-
-(register-definition-prefixes "gts-engine-deepl" '("gts-deepl-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-google" "gts-engine-google.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from gts-engine-google.el
-
-(register-definition-prefixes "gts-engine-google" '("gts-google-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-google-rpc" "gts-engine-google-rpc.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from gts-engine-google-rpc.el
-
-(register-definition-prefixes "gts-engine-google-rpc" '("gts-google-rpc-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-stardict" "gts-engine-stardict.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from gts-engine-stardict.el
-
-(register-definition-prefixes "gts-engine-stardict" '("gts-stardict-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-youdao" "gts-engine-youdao.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from gts-engine-youdao.el
-
-(register-definition-prefixes "gts-engine-youdao" '("gts-youdao-dict-e"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-faces" "gts-faces.el" (0 0 0 0))
-;;; Generated autoloads from gts-faces.el
-
-(register-definition-prefixes "gts-faces" '("gts-p"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-implements" "gts-implements.el" (0 0 0
-;;;;;; 0))
-;;; Generated autoloads from gts-implements.el
-
-(register-definition-prefixes "gts-implements" '("gts-"))
-
-;;;***
-\f
-;;;### (autoloads nil nil ("go-translate-pkg.el") (0 0 0 0))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; coding: utf-8
-;; End:
-;;; go-translate-autoloads.el ends here
+++ /dev/null
-(define-package "go-translate" "20221211.1327" "Translation framework supports multiple engines such as Google/Bing/DeepL"
- '((emacs "27.1"))
- :commit "65d5139f202320b71e6b8b03d752d02b7c0b8c6f" :authors
- '(("lorniu" . "lorniuNOSPAMgmail.com"))
- :maintainer
- '("lorniu" . "lorniuNOSPAMgmail.com")
- :keywords
- '("convenience")
- :url "https://github.com/lorniu/go-translate")
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+++ /dev/null
-;;; go-translate.el --- Translation framework supports multiple engines such as Google/Bing/DeepL -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-
-;; Author: lorniu <lorniuNOSPAMgmail.com>
-;; URL: https://github.com/lorniu/go-translate
-;; Package-Requires: ((emacs "27.1"))
-;; Keywords: convenience
-;; SPDX-License-Identifier: MIT
-;; Version: 2.0
-
-;;; Commentary:
-
-;; To be the most powerful translator on Emacs. Supports multiple translation engines such as Google, Bing, deepL.
-
-;; First, Install it via MELPA or download from github. Make sure this is on your `load-path'.
-
-;; Then, add following lines to your `.emacs':
-
-;; (require 'go-translate)
-;; (setq gts-translate-list '(("en" "zh")))
-;; (setq gts-default-translator
-;; (gts-translator
-;; :picker (gts-prompt-picker)
-;; :engines (list (gts-google-engine) (gts-google-rpc-engine))
-;; :render (gts-buffer-render)))
-
-;; And start your translate with command `gts-do-translate'.
-
-;;; Code:
-
-(require 'gts-core)
-(require 'gts-implements)
-(require 'gts-engine-bing)
-(require 'gts-engine-google)
-(require 'gts-engine-google-rpc)
-(require 'gts-engine-deepl)
-(require 'gts-engine-stardict)
-(require 'gts-engine-youdao)
-
-\f
-;;; Commands
-
-(defvar gts-default-translator
- (gts-translator :picker
- (gts-prompt-picker)
- ;;(gts-noprompt-picker)
- ;;(gts-noprompt-picker :texter (gts-whole-buffer-texter))
-
- :engines
- (list
- (gts-bing-engine)
- (gts-google-engine :parser (gts-google-summary-parser))
- (gts-google-rpc-engine)
-
- ;;(gts-google-engine)
- ;;(gts-google-rpc-engine)
- ;;(gts-deepl-engine :auth-key "2e20bade-88e9-02f3-169f-ab3c445d7984:fx" :pro nil)
-
- ;;(gts-google-engine :parser (gts-google-summary-parser))
- ;;(gts-google-engine :parser (gts-google-parser))
- ;;(gts-google-rpc-engine :parser (gts-google-rpc-summary-parser))
- )
-
- :render
- (gts-buffer-render)
-
- ;;(gts-posframe-pop-render)
- ;;(gts-posframe-pop-render :backcolor "#333333" :forecolor "#ffffff")
-
- ;;(gts-posframe-pin-render)
- ;;(gts-posframe-pin-render :position (cons 1200 20))
- ;;(gts-posframe-pin-render :width 80 :height 25 :position (cons 1000 20) :forecolor "#ffffff" :backcolor "#111111")
-
- ;;(gts-kill-ring-render)
-
- :splitter nil
- ;; (gts-paragraph-splitter)
- ))
-
-;;;###autoload
-(defun gts-do-translate ()
- "Do the translate"
- (interactive)
- (gts-translate gts-default-translator))
-
-
-(provide 'go-translate)
-
-;;; go-translate.el ends here
+++ /dev/null
-;;; gts-core.el --- Translate engines and utils -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; The core components and utils of the translator
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'subr-x)
-(require 'eieio)
-
-(defgroup go-translate nil
- "Translate Framework for Emacs, asynchronous and flexible."
- :group 'external
- :prefix 'gts-)
-
-(defvar gts-debug-p nil)
-
-\f
-;;; Utils
-
-(defun gts-aref-for (vector &rest ns)
- "Recursively find the element in VECTOR. NS is indexes, as the path."
- (while ns
- (setq vector (aref vector (pop ns))))
- vector)
-
-(defun gts-format-params (data)
- "Format alist DATA to k=v style string."
- (cond ((null data) nil)
- ((stringp data) data)
- (t (mapconcat (lambda (arg)
- (format "%s=%s"
- (url-hexify-string (format "%s" (car arg)))
- (url-hexify-string (format "%s" (cdr arg)))))
- data "&"))))
-
-(defun gts-ensure-list (object)
- "Return OBJECT as a list."
- (if (listp object) object (list object)))
-
-(defun gts-ensure-plain (o)
- "Return O or the result of its execution."
- (if (functionp o) (funcall o) o))
-
-\f
-;;; Components
-
-;; logger/http-client/cacher
-
-(defclass gts-logger () ()
- "Used to log the messages."
- :abstract t)
-
-(defclass gts-http-client () ()
- "Used to send a request."
- :abstract t)
-
-(defclass gts-cacher ()
- ((caches :initform nil)) ; (key . (str . timestamp))
- "Used to cache the translate results."
- :abstract t)
-
-;; translator/task
-
-(defclass gts-translator ()
- ((picker :initarg :picker :documentation "`gts-picker' object or a function return it" :initform nil)
- (engines :initarg :engines :documentation "a list of `gts-engine' objects or a function return them" :initform nil)
- (render :initarg :render :documentation "`gts-render' object or a function return it" :initform nil)
- (splitter :initarg :splitter :documentation "`gts-splitter' object or a function return it" :initform nil)
-
- (text :initarg :text :documentation "Text to be translated")
- (sptext :initarg :sptext :documentation "List of strings splitted according `gts-splitter'")
- (path :initarg :path :documentation "From/To language cons")
-
- (plan-cnt :initform 0 :documentation "count of tasks in a translation")
- (task-queue :initform nil :documentation "translation tasks.")
- (state :initform 0 :documentation "Inner state of the translator:
-0: new translator without any tasks,
-1: tasks add finished, but not running,
-2: prepare render finished, and begin to running,
-3: all tasks running finished,
-4: rendered done, all over.")
- (version :initform nil :documentation "Used to distinguish between different translations")))
-
-(defclass gts-task ()
- ((id :initform (gensym))
-
- (text :initarg :text :documentation "Text that sent to engines. It maybe contains delimiters")
- (from :initarg :from)
- (to :initarg :to)
-
- (raw :initform nil :documentation "raw result responsed by the http-client")
- (parsed :initform nil :initarg :parsed :documentation "result parsed by parser, string or list")
- (err :initform nil :initarg :err :documentation "error info")
- (meta :initform nil :initarg :meta :documentation "extra info passed from parser to render. tbeg/tend")
-
- (engine :initarg :engine :initform nil)
- (render :initarg :render :initform nil)
- (translator :initarg :translator :initform nil)))
-
-;; picker/texter
-
-(defclass gts-picker ()
- ((single :initarg :single :initform nil)
- (texter :initarg :texter))
- "Used to pick the translation source text and from/to lang."
- :abstract t)
-
-(defclass gts-texter () ()
- "Used to get the initial translation text.
-Current word under cursor? Selection region? Whole line? Whole buffer? Others?
-You can implements your rules.")
-
-;; splitter
-
-(defclass gts-splitter () ()
- "Used to split the translation text by pragraph or other rules."
- :abstract t)
-
-;; engine/parser
-
-(defclass gts-engine ()
- ((tag :initarg :tag :documentation "Used to display as name")
- (parser :initarg :parser :documentation "Used to parse the response result"))
- :abstract t)
-
-(defclass gts-parser ()
- ((tag :initarg :tag :initform nil)))
-
-;; render
-
-(defclass gts-render () ())
-
-;; generic methods
-
-(cl-defgeneric gts-translate (translator-or-engine &rest args)
- "Start a translation for TRANSLATOR-OR-ENGINE.
-ARGS should be text/path or task/callback.")
-
-;; silence byte-compiler
-(eieio-declare-slots task-queue text from to)
-
-\f
-;;; Logger
-
-(cl-defgeneric gts-log (logger tag message)
- "Used to record the messages.")
-
-(defvar gts-default-logger nil "The default logger.")
-
-(defmacro gts-do-log (tag &rest messages)
- (declare (indent 1))
- `(when gts-debug-p
- (if gts-default-logger
- (cl-loop with ms = nil
- for message in (list ,@messages)
- if message do (cl-loop for m in (split-string message "\n") do (push m ms))
- finally (cl-loop
- for m in (nreverse ms)
- do (gts-log gts-default-logger (format "%s" ,tag) m)))
- (error "Make sure `gts-default-logger' is available. eg:\n
- (setq gts-default-logger (gts-buffer-logger))\n\n\n"))))
-
-\f
-;;; Cacher
-
-(defcustom gts-cache-enable t
- "Enable the cacher if this is t."
- :type 'boolean
- :group 'go-translate)
-
-(defcustom gts-cache-expired-factor (* 30 60)
- "Cache alive time based on this.
-Make word live longer time than sentence."
- :type 'integer
- :group 'go-translate)
-
-(defvar gts-default-cacher nil "The default cacher.")
-
-(cl-defgeneric gts-cache-get (cacher task)
- "Get item for TASK from CACHER.")
-
-(cl-defgeneric gts-cache-set (cacher task result)
- "Add RESULT fro TASK to CACHER.")
-
-(cl-defmethod gts-cache-key ((_ gts-cacher) task)
- (with-slots (text from to engine) task
- (sha1 (format "%s-%s-%s-%s"
- text from to
- (eieio-object-class-name engine)))))
-
-(cl-defmethod gts-clear-expired ((cacher gts-cacher))
- (with-slots (caches expired) cacher
- (cl-delete-if (lambda (c) (> (time-to-seconds) (cddr c))) caches)))
-
-(cl-defmethod gts-clear-all ((cacher gts-cacher))
- (oset cacher caches nil))
-
-\f
-;;; Http Client
-
-(cl-defgeneric gts-request (http-client url &key done fail data headers)
- "Use HTTP-CLIENT to request a URL with DATA.
-When success execute CALLBACK, or execute ERRORBACK."
- (:method (&rest _) (user-error "Method `gts-request' is not implement")))
-
-(defvar gts-default-http-client nil
- "The default http client used to send a request.")
-
-(cl-defun gts-do-request (url &key done fail data headers)
- "Helper for `gts-request'.
-DONE is a callback based on the responsed result buffer.
-FAIL is the callback for any error occured in request or parse."
- (if (and gts-default-http-client
- (eieio-object-p gts-default-http-client)
- (object-of-class-p gts-default-http-client 'gts-http-client))
- (let ((tag (format "%s" (eieio-object-class-name gts-default-http-client)))
- (data (gts-format-params data)))
- (gts-do-log tag
- (format "Start! (%s)" url)
- (if headers (format " HEADER: %s" headers))
- (if data (format " DATA: %s" data)))
- (gts-request gts-default-http-client url
- :headers headers
- :data data
- :done (lambda ()
- (gts-do-log tag (format "DONE! (%s)" url))
- (condition-case err
- (funcall done)
- (error
- (gts-do-log tag (format "FAIL in callback! (%s) %s" url err))
- (funcall fail err))))
- :fail (lambda (status)
- (gts-do-log tag (format "FAIL! (%s) %s" url status))
- (funcall fail status))))
- (funcall fail "Make sure `gts-default-http-client' is available. eg:\n
- (setq gts-default-http-client (gts-url-http-client))\n\n\n")))
-
-\f
-;;; Picker/Texter
-
-(cl-defgeneric gts-pick (picker)
- "Get the source text and translate from/to path from PICKER.")
-
-(cl-defgeneric gts-path (picker text)
- "Use to get the translation path for TEXT from PICKER.")
-
-(cl-defgeneric gts-next-path (picker text path &optional backwardp)
- "Get the next available path.")
-
-(cl-defgeneric gts-text (texter)
- "Get the init translation source text via TEXTER.")
-
-(defcustom gts-translate-list nil
- "Setup your translate languages. Just like:
-
-Single:
-
- (setq gts-translate-list \\='((\"en\" \"zh\")))
-
-Or multiple:
-
- (setq gts-translate-list \\='((\"en\" \"zh\") (\"en\" \"fr\")))
-
-The picker will give the translate from/to pair according this."
- :type 'alist
- :group 'go-translate)
-
-(defcustom gts-picker-lang-match-alist
- (list
- (cons "en" "^[-a-zA-Z0-9,.;_ ]+$")
- (cons "zh" "\\cc")
- (cons "ja" (lambda (text) (string-match-p "\\cj" text)))
- (cons "ru" "\\cy"))
- "Setup language match rules.
-
-Used to pick the right language for current translate text.
-
-Key should be the language, value should be a regexp string or function."
- :type 'alist
- :group 'go-translate)
-
-(defvar gts-picker-last-path nil)
-
-(defun gts-picker-lang-matcher (lang)
- "Judge source, sure case, yes:no:unknown.
-choose path, from main, then extra path match."
- (let ((p (cdr (cl-find-if
- (lambda (item) (string-match-p (format "^%s$" (car item)) lang))
- gts-picker-lang-match-alist))))
- (if (stringp p) (lambda (text) (string-match-p p text)) p)))
-
-(cl-defmethod gts-all-paths ((picker gts-picker))
- (when (or (null gts-translate-list) (not (consp (car gts-translate-list))))
- (user-error "Please make sure you set the avaiable `gts-translate-list'. eg:\n
- (setq gts-translate-list '((\"en\" \"zh\") (\"en\" \"ja\"))\n\n"))
- (let (paths)
- (when gts-picker-last-path
- (cl-pushnew gts-picker-last-path paths))
- (cl-loop with candidates = (if (oref picker single)
- (list (car gts-translate-list))
- gts-translate-list)
- for (lang1 . lang2) in candidates
- for lang2 = (if (consp lang2) (car lang2) lang2)
- do (progn
- (cl-pushnew (cons lang1 lang2) paths :test 'equal)
- (cl-pushnew (cons lang2 lang1) paths :test 'equal)))
- (reverse paths)))
-
-(cl-defmethod gts-matched-paths ((picker gts-picker) text)
- (when text
- (let ((paths (gts-all-paths picker))
- (text (with-temp-buffer ; clear punctuations
- (insert text)
- (goto-char (point-min))
- (while (re-search-forward "\\s.\\|\n" nil t) (replace-match ""))
- (buffer-string))))
- (cl-loop for path in paths
- for matcher = (gts-picker-lang-matcher (car path))
- when (and matcher (funcall matcher text))
- collect path))))
-
-(cl-defmethod gts-path ((picker gts-picker) text)
- "Get translate path according TEXT using PICKER."
- (let ((paths (gts-matched-paths picker text)))
- (if paths (car paths)
- (or gts-picker-last-path
- (car (gts-all-paths picker))))))
-
-(cl-defmethod gts-next-path ((picker gts-picker) text path &optional backwardp)
- (let (candidates idx)
- (cl-loop for path in (append (gts-matched-paths picker text) (gts-all-paths picker))
- do (cl-pushnew path candidates :test 'equal))
- (setq candidates (reverse candidates))
- (setq idx (cl-position path candidates :test 'equal))
- (if backwardp
- (elt candidates (if (= 0 idx) (- (length candidates) 1) (- idx 1)))
- (elt candidates (if (= (+ 1 idx) (length candidates)) 0 (+ 1 idx))))))
-
-\f
-;;; Splitter
-
-(cl-defgeneric gts-split (gts-splitter text)
- "Split TEXT to several parts.
-Return list of string, or nil if split failed.")
-
-\f
-;;; Engine/Parser
-
-(cl-defmethod gts-translate ((engine gts-engine) _task _callback)
- "Translate and update TASK with parsed result using ENGINE.
-The CALLBACK should contain the render logic."
- (user-error "Method `gts-translate' of %s is not implement" (eieio-object-class-name engine)))
-
-(cl-defmethod gts-translate :around ((engine gts-engine) task callback)
- "Add cache and log support."
- (with-slots (id render translator) task
- (if-let ((render-name (eieio-object-class-name render))
- (engine-name (eieio-object-class-name engine))
- (cache (gts-cache-get gts-default-cacher task)))
- ;; try cache
- (let ((engines (gts-get translator 'engines)))
- (gts-update-raw task cache)
- (gts-parse (oref engine parser) task)
- (if (cdr engines) (gts-me-out render task)
- (gts-out render task))
- (gts-do-log 'render (format "%s: done with cache!" id)))
- ;; request from engine
- (gts-do-log 'engine (format "%s: starting %s..." id engine-name))
- (cl-call-next-method engine task
- (lambda ()
- (gts-do-log 'engine (format "%s: %s done!" id engine-name))
- (funcall callback)
- ;; refresh cache
- (with-slots (err raw parsed) task
- (unless err
- (gts-cache-set gts-default-cacher task raw))))))))
-
-(cl-defgeneric gts-with-token (engine done fail)
- (:documentation "Get token for ENGINE, if success then DONE is called.")
- (declare (indent 1)))
-
-(cl-defgeneric gts-tts (engine text lang)
- "TTS, speak TEXT with LANG."
- (:method ((e gts-engine) &rest _)
- (user-error "No TTS service found on engine `%s'" (oref e tag))))
-
-(cl-defgeneric gts-parse (parser task)
- (:documentation "Parse the raw result and update the parsed result into TASK.")
- (:method ((_o gts-parser) task)
- ;; do nothing
- (gts-update-parsed task (oref task raw))))
-
-\f
-;;; Render
-
-(cl-defgeneric gts-pre (render translator)
- (:documentation "Pre-render before request success.
-Do some preparation for the gts-out.")
- (:method :after ((render gts-render) _)
- (gts-do-log 'render (format "prepare render with %s finished" (eieio-object-class-name render))))
- (:method ((_o gts-render) (_t gts-translator)) ()))
-
-(cl-defgeneric gts-out (render task)
- (:documentation "Render the TASK, default output to *Messages*.")
- (:method :after ((render gts-render) task)
- (gts-do-log 'render (format "%s: %s finished" (oref task id) (eieio-object-class-name render))))
- (:method ((_ gts-render) task)
- (with-slots (err parsed) task
- (when (and (not err) (listp parsed))
- (setq parsed (string-join parsed "\n\f\n")))
- (setq parsed (string-trim (format "%s" (or err parsed))))
- (setq parsed (propertize parsed 'face 'font-lock-keyword-face))
- (message "-+-G-+-T-+-S-+-")
- (message parsed ))))
-
-(cl-defgeneric gts-me-pre (render translator)
- (:documentation "Pre-render for TRANSLATOR.
-It used only when multiple engines exists.
-Default dispatch to gts-pre when first pre-render.")
- (:method :after ((render gts-render) _)
- (gts-do-log 'render (format "me prepare render with %s finished" (eieio-object-class-name render))))
- (:method ((render gts-render) translator)
- (with-slots (task-queue state) translator
- (when (= state 1)
- (gts-pre render translator)
- (setf state 2)))))
-
-(cl-defgeneric gts-me-out (render task)
- (:documentation "Render TASK with RENDER.
-It used only when multiple engines exists.
-Default dispatch to gts-out with all results concated.")
- (:method :after ((render gts-render) task)
- (gts-do-log 'render (format "%s: %s finished" (oref task id) (eieio-object-class-name render))))
- (:method ((render gts-render) task)
- (let ((translator (oref task translator)) results)
- ;; show only when all tasks finished.
- (when (= (oref translator state) 3)
- (dolist (task (oref translator task-queue))
- (with-slots (err parsed engine) task
- (when (and (not err) (listp parsed))
- (setq parsed (string-join parsed "\f")))
- (push (cons (format "[%s]" (oref engine tag)) (or err parsed)) results)))
- (setq results (nreverse results))
- (let* ((newlinep (cl-find-if (lambda (r) (string-match-p "\n" (cdr r))) results))
- (concated (mapconcat (lambda (r)
- (if newlinep
- (concat (propertize (concat (car r) "\n") 'face 'gts-pop-posframe-me-header-2-face)
- (format "\n%s" (cdr r)))
- (concat (propertize (format "%-7s" (car r)) 'face 'gts-pop-posframe-me-header-face)
- (format " %s" (cdr r)))))
- results
- (if newlinep "\n\n" "\n"))))
- (oset translator state 4)
- (gts-out render (gts-task :parsed concated :translator translator)))))))
-
-\f
-;;; TTS
-
-(defcustom gts-tts-speaker (or (executable-find "mpv")
- (executable-find "mplayer"))
- "The program to use to speak the translation.
-
-On Windows, if it is not found, will fallback to use `powershell`
-to do the job. Although it is not perfect, it seems to work."
- :type 'string
- :group 'go-translate)
-
-(defcustom gts-tts-try-speak-locally t
- "If t then will fallback to locally TTS service when engine's TTS failed.
-For example, it will use powershell on Windows to speak the word
-when this is set to t."
- :type 'boolean
- :group 'go-translate)
-
-(defvar gts-tts-playing-process nil)
-
-(defun gts-tts-speak-buffer-data ()
- "Speak the current buffer's data."
- (gts-tts-try-interrupt-playing-process)
- (let ((proc (make-process :name (format "gts-tts-process-%s" (+ 1000 (random 1000)))
- :command (append (split-string gts-tts-speaker) (list "-"))
- :buffer nil
- :noquery t
- :connection-type 'pipe)))
- (setq gts-tts-playing-process proc)
- (process-send-region proc (point-min) (point-max))
- (if (process-live-p proc) (process-send-eof proc))))
-
-(defun gts-tts-try-interrupt-playing-process ()
- (when (and gts-tts-playing-process (process-live-p gts-tts-playing-process))
- (ignore-errors (kill-process gts-tts-playing-process))
- (setq gts-tts-playing-process nil)))
-
-(defun gts-do-tts (text lang &optional engine)
- "Speak TEXT in LANG with possible tts service by ENGINE.
-If engine failed, then try locally TTS if `gts-tts-try-speak-locally' is set."
- (condition-case err
- (if engine
- (if gts-tts-speaker
- (gts-tts engine text lang)
- (user-error "No mpv/mplayer found"))
- (user-error "No engine TTS service provided"))
- (error (if gts-tts-try-speak-locally
- (cond ((executable-find "powershell")
- (let ((cmd (format "$w = New-Object -ComObject SAPI.SpVoice; $w.speak(\\\"%s\\\")" text)))
- (shell-command (format "powershell -Command \"& {%s}\""
- (encode-coding-string
- (replace-regexp-in-string "\n" " " cmd)
- (keyboard-coding-system))))))
- (t (message "[TTS] %s" (cadr err))))))))
-
-\f
-;;; Translator
-
-(defvar gts-text-delimiter "34587612321123")
-
-(defvar gts-current-command nil "The command invoked by `gts-translate'.")
-
-(cl-defmethod initialize-instance :after ((this gts-translator) &rest _)
- (unless (gts-ensure-plain (oref this render))
- (oset this render (gts-render)))
- (unless (gts-ensure-plain (oref this picker))
- (oset this picker (gts-noprompt-picker))))
-
-(cl-defmethod gts-get ((this gts-translator) &rest slots)
- "Return the normalized value of SLOTS in THIS translator."
- (cl-loop for slot in slots
- for value =
- (cl-flet ((ensure (v) (or v (user-error "No %s found in current translator" slot))))
- (pcase slot
- ((or 'picker 'render) (ensure (gts-ensure-plain (slot-value this slot))))
- ('splitter (gts-ensure-plain (slot-value this slot)))
- ('engines (ensure (gts-ensure-list (gts-ensure-plain (slot-value this slot)))))
- (_ (slot-value this slot))))
- collect value into values
- finally (return (if (cadr slots) (apply #'cl-values values) (car values)))))
-
-(cl-defmethod gts-init ((this gts-translator) text path)
- "Init all status and tasks in THIS translator."
- ;; input
- (unless (and text path)
- (let ((input (gts-pick (gts-get this 'picker))))
- (setq text (cl-nth-value 0 input))
- (setq path (cl-nth-value 1 input))))
- (oset this text text)
- (oset this path path)
- (setq gts-picker-last-path path)
- (gts-do-log 'translator (format "\nBegin to translate %s" path))
- (gts-do-log 'text text)
- (cl-multiple-value-bind (splitter engines render) (gts-get this 'splitter 'engines 'render 'version)
- ;; reset
- (oset this state 0)
- (oset this task-queue nil)
- (oset this plan-cnt (length engines))
- (oset this version (time-to-seconds))
- ;; tasks
- (let ((splitted (if splitter (gts-split splitter text))))
- (oset this sptext splitted)
- (cl-loop for engine in engines
- for task = (gts-task :translator this
- :engine engine
- :render render
- :from (car path) :to (cdr path)
- :text (if splitted (string-join splitted (concat "\n" gts-text-delimiter "\n")) text))
- do (gts-add-task this task))
- (gts-do-log 'text (format "splitted? %s!" (if splitted "Yes" "No"))))))
-
-(cl-defmethod gts-add-task ((this gts-translator) task)
- "Add a new TASK to THIS translator."
- (with-slots (id engine render) task
- (with-slots (text path plan-cnt task-queue state) this
- (when (= state 0)
- (setf task-queue (append task-queue (list task)))
- (gts-do-log 'translator
- (format "- add task %s: (%s/%s)" id
- (eieio-object-class-name engine) (eieio-object-class-name render))))
- (when (and (= state 0) (= (length task-queue) plan-cnt))
- (setf state 1)))))
-
-(cl-defmethod gts-done-tasks ((this gts-translator))
- "Return the finished tasks in THIS translator."
- (with-slots (task-queue) this
- (cl-remove-if-not
- (lambda (task) (or (oref task err) (oref task raw))) task-queue)))
-
-(defun gts-update-raw (task resp &optional error)
- "Update non-parsed RESP result to TASK.
-If ERROR is not nil, then update task with failure."
- (declare (indent 1))
- (with-slots (id raw err translator) task
- (with-slots (task-queue plan-cnt state) translator
- (setf raw resp)
- (setf err error)
- (when (and (= state 2) (= plan-cnt (length (gts-done-tasks translator))))
- (setf state 3))
- (gts-do-log 'translator (format "%s: **responsed** %s" id (or error "success!"))))))
-
-(defun gts-update-parsed (task result &optional metadata filter)
- "Update TASK with parsed RESULT, update METADATA if exists.
-FILTER the parsed result if necessary, it's a function take parsed result as argument."
- (declare (indent 1))
- (with-slots (id raw parsed err meta translator) task
- (if raw
- (condition-case er
- (let ((r (if (or (listp result) (not (gts-get translator 'sptext)))
- result
- (gts-do-log 'translator
- (format "%s: result contains delimiter, so split to list" id))
- (split-string result gts-text-delimiter nil "[ \t\n\r]+"))))
- (setf parsed (if filter (funcall filter r) r))
- (if metadata (setf meta metadata)))
- (error (setf err er)))
- (gts-update-raw task t "Mybe Null Response"))))
-
-(defun gts-render-fail (task error)
- "Directly render the ERROR message and finish the TASK."
- (declare (indent 1))
- (gts-do-log 'translator (format "error? %s" error))
- (if task
- (with-slots (translator render) task
- (let ((engines (gts-get translator 'engines)))
- (gts-update-raw task nil error)
- (if (cdr engines)
- (gts-me-out render task)
- (gts-out render task))))
- (signal 'error error)))
-
-(cl-defmethod gts-translate ((this gts-translator) &optional text path)
- "Fire a translation for THIS translator instance.
-When TEXT and PATH is nil then pick them via `gts-pick'."
- ;; record this, so can fixup issue in posframe-pop etc. Weird?
- (setq gts-current-command this-command)
- ;; initialize
- (gts-init this text path)
- (cl-multiple-value-bind (engines render tasks text path)
- (gts-get this 'engines 'render 'task-queue 'text 'path)
- (let ((buf (current-buffer)))
- ;; single engine
- (if (not (cdr engines))
- (let ((task (car tasks)))
- (gts-pre render this)
- (gts-translate (car engines) task
- (lambda ()
- (with-current-buffer buf
- (gts-out render task)))))
- ;; multiple engines
- (gts-me-pre render this)
- (dolist (task tasks)
- (condition-case er
- (gts-translate (oref task engine) task
- (lambda ()
- (with-current-buffer buf
- (gts-me-out render task))))
- (error
- (gts-render-fail task er))))
- (gts-me-out render (gts-task :text text :from (car path) :to (cdr path) :translator this))))))
-
-
-(provide 'gts-core)
-
-;;; gts-core.el ends here
+++ /dev/null
-;;; gts-engine-bing.el --- Microsoft Translate -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; https://bing.com/translator
-
-;;; Code:
-
-(require 'gts-implements)
-
-(defclass gts-bing-parser (gts-parser) ())
-
-(defclass gts-bing-engine (gts-engine)
- ((tag :initform "Bing")
- (base-url :initform "https://www.bing.com")
- (sub-url :initform "/ttranslatev3")
-
- (tld-url :initform nil)
- (ig :initform nil)
- (key :initform nil)
- (token :initform nil)
- (last-time :initform nil)
- (expired-time :initform (* 30 60))
-
- (ttsk-url :initform "/tfetspktok")
- (tts-url :initform "https://%s.tts.speech.microsoft.com/cognitiveservices/v1")
- (tts-tpl :initform "<speak version='1.0' xml:lang='%s'><voice xml:lang='%s' xml:gender='Female' name='%s'><prosody rate='-20.00%%'>%s</prosody></voice></speak>")
-
- (parser :initform (gts-bing-parser))))
-
-\f
-;;; Engine
-
-(defvar gts-bing-extra-langs-mapping '(("zh" . "zh-Hans")))
-
-(defvar gts-bing-token-maybe-invalid nil)
-
-(cl-defmethod gts-get-lang ((_ gts-bing-engine) lang)
- (or (cdr-safe (assoc lang gts-bing-extra-langs-mapping)) lang))
-
-(cl-defmethod gts-token-available-p ((engine gts-bing-engine))
- (with-slots (token key ig last-time expired-time) engine
- (and token key ig last-time
- (not gts-bing-token-maybe-invalid)
- (< (- (time-to-seconds) last-time) expired-time))))
-
-(cl-defmethod gts-with-token ((engine gts-bing-engine) done fail)
- (with-slots (token key ig base-url) engine
- (if (gts-token-available-p engine)
- (funcall done)
- (gts-do-request (concat base-url "/translator")
- :done
- (lambda ()
- (let (key token ig tld)
- (re-search-forward "curUrl=.*/\\([a-z]+\\.bing.com\\)")
- (setq tld (match-string 1))
- (re-search-forward "\"ig\":\"\\([^\"]+\\).*params_RichTranslateHelper = \\[\\([0-9]+\\),\"\\([^\"]+\\)")
- (setq ig (match-string 1) key (match-string 2) token (match-string 3))
- (oset engine ig ig)
- (oset engine key key)
- (oset engine token token)
- (oset engine last-time (time-to-seconds))
- (oset engine tld-url (concat "https://" tld))
- (setq gts-bing-token-maybe-invalid nil)
- (gts-do-log 'bing (format "url: %s\nkey: %s\ntoken: %s\nig: %s" tld key token ig))
- (funcall done)))
- :fail fail))))
-
-(cl-defmethod gts-translate ((engine gts-bing-engine) task rendercb)
- (gts-with-token engine
- (lambda ()
- (with-slots (text from to raw) task
- (with-slots (tld-url sub-url token key ig parser) engine
- (gts-do-request (format "%s%s?isVertical=1&IG=%s&IID=translator.5022.1" tld-url sub-url ig)
- :headers `(("Content-Type" . "application/x-www-form-urlencoded;charset=UTF-8"))
- :data `(("fromLang" . ,(gts-get-lang engine from))
- ("to" . ,(gts-get-lang engine to))
- ("text" . ,text)
- ("key" . ,key)
- ("token" . ,token))
- :done (lambda ()
- (gts-update-raw task (buffer-string))
- (gts-parse parser task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task
- (cond ((ignore-errors (= (caddar err) 429))
- "[429] Too many requests! Please retry later")
- (t err))))))))
- (lambda (err)
- (gts-render-fail task
- (format "Error occurred when request for token.\n\n%s" err)))))
-
-\f
-;;; TTS
-
-(defvar gts-bing-tts-langs-mapping '(("zh" . ("zh-CN" . "zh-CN-XiaoxiaoNeural"))
- ("en" . ("en-US" . "en-US-AriaNeural"))
- ("fr" . ("fr-CA" . "fr-CA-SylvieNeural"))
- ("de" . ("de-DE" . "de-DE-KatjaNeural"))))
-
-(cl-defmethod gts-tts-payload ((engine gts-bing-engine) lang text)
- (with-slots (tts-tpl) engine
- (let (l n (mt (assoc lang gts-bing-tts-langs-mapping)))
- (if mt (setq l (cadr mt) n (cddr mt))
- (user-error "Add the mapping of your language into `gts-bing-tts-langs-mapping' :)"))
- (format tts-tpl l l n (encode-coding-string text 'utf-8)))))
-
-(cl-defmethod gts-tts ((engine gts-bing-engine) text lang)
- (gts-with-token engine
- (lambda ()
- (with-slots (tld-url sub-url token key ig parser ttsk-url tts-url tts-tpl) engine
- (gts-do-request (format "%s%s?isVertical=1&IG=%s&IID=translator.5022.2" tld-url ttsk-url ig)
- :headers '(("content-type" . "application/x-www-form-urlencoded"))
- :data `(("token" . ,token) ("key" . ,key))
- :done (lambda ()
- (let* ((json (json-read))
- (token (cdr (assoc 'token json)))
- (region (cdr (assoc 'region json))))
- (gts-do-log 'bing-tts (format "token: %s\nregion: %s" token region))
- (gts-do-request (format tts-url region)
- :data (gts-tts-payload engine lang text)
- :headers `(("content-type" . "application/ssml+xml")
- ("authorization" . ,(format "Bearer %s" token))
- ("x-microsoft-outputformat" . "audio-16khz-32kbitrate-mono-mp3"))
- :done (lambda ()
- (gts-tts-speak-buffer-data))
- :fail (lambda (_)
- (user-error "[BING-TTS] error when play sound")))))
- :fail (lambda (err) (user-error "%s" err)))))
- (lambda (_) (user-error "Failed to get token"))))
-
-\f
-;;; Parser
-
-(cl-defmethod gts-parse ((_ gts-bing-parser) task)
- (with-temp-buffer
- (set-buffer-multibyte t)
- (insert (oref task raw))
- (decode-coding-region (point-min) (point-max) 'utf-8)
- (gts-do-log 'bing (string-trim (buffer-string)))
- (goto-char (point-min))
- (if-let* ((json (json-read))
- (result (ignore-errors (cdr (assoc 'text (aref (cdr (assoc 'translations (aref json 0))) 0))))))
- (gts-update-parsed task result)
- (setq gts-bing-token-maybe-invalid t) ; refresh token when error occurred
- (gts-update-raw task nil (buffer-string)))))
-
-
-(provide 'gts-engine-bing)
-
-;;; gts-engine-bing.el ends here
+++ /dev/null
-;;; gts-engine-deepl.el --- Translate Engine for DeepL -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; https://www.deepl.com
-
-;;; Code:
-
-(require 'gts-implements)
-
-\f
-;;; Components
-
-(defclass gts-deepl-parser (gts-parser) ())
-
-(defclass gts-deepl-engine (gts-engine)
- ((tag :initform "DeepL")
- (pro :initform nil :initarg :pro :documentation "If your key is PRO version")
- (free-url :initform "https://api-free.deepl.com")
- (pro-url :initform "https://api.deepl.com")
- (sub-url :initform "/v2/translate")
- (auth-key :initform nil :initarg :auth-key)
- (parser :initform (gts-deepl-parser))))
-
-(cl-defmethod initialize-instance :after ((engine gts-deepl-engine) &rest _)
- (unless (oref engine auth-key)
- (user-error "You should provide a auth-key when instance gts-deepl-engine")))
-
-\f
-;;; Utils
-
-(defcustom gts-deepl-fill-enable t
- "Controller wheather try to improve the input and output.
-Default behavior is removing excess linebreaks in input for better
-translation effect, and filling the output for better reading experience.
-You can override the behaviors by :around the method `gts-deepl-fill-input'
-or `gts-deepl-fill-output'."
- :type 'boolean
- :group 'go-translate)
-
-(cl-defmethod gts-deepl-fill-input (text)
- "Improve the input TEXT for better translation effect.
-Mainly remove excess linebreaks. I want to skip unfill on comments and codes,
-but don't know how to implement easily. To make it better later, maybe."
- (if gts-deepl-fill-enable
- (with-temp-buffer
- (insert text)
- (let ((fill-column (point-max)))
- (fill-region (point-min) (point-max)))
- (buffer-string))
- text))
-
-(cl-defmethod gts-deepl-fill-output (text)
- "Improve the output TEXT for better reading experience.
-Mainly fill the text to suitable length."
- (if gts-deepl-fill-enable
- (with-temp-buffer
- (insert text)
- (fill-region (point-min) (point-max))
- (buffer-string))
- text))
-
-\f
-;;; Engine
-
-(defvar gts-deepl-langs-mapping '(("en" . "EN")
- ("zh" . "ZH")
- ("de" . "DE") ; German
- ("fr" . "FR") ; French
- ("it" . "IT") ; Italian
- ("ja" . "JA") ; Japanese
- ("es" . "ES") ; Spanish
- ("nl" . "NL") ; Dutch
- ("pl" . "PL") ; Polish
- ("pt" . "PT") ; Portuguese (all Portuguese varieties mixed)
- ("ru" . "RU") ; Russian
- ))
-
-(cl-defmethod gts-get-lang ((_ gts-deepl-engine) lang)
- (let ((mapping (assoc lang gts-deepl-langs-mapping)))
- (if mapping (cdr mapping)
- (user-error
- "Language %s is not supported by DeepL.\nSupported list: %s"
- lang (mapconcat #'car gts-deepl-langs-mapping ", ")))))
-
-(cl-defmethod gts-gen-url ((engine gts-deepl-engine))
- (with-slots (free-url pro-url sub-url pro) engine
- (format "%s%s" (if pro pro-url free-url) sub-url)))
-
-(cl-defmethod gts-translate ((engine gts-deepl-engine) task rendercb)
- (with-slots (text from to) task
- (with-slots (auth-key parser) engine
- (gts-do-request (gts-gen-url engine)
- :headers `(("Content-Type" . "application/x-www-form-urlencoded;charset=UTF-8")
- ("Authorization" . ,(concat "DeepL-Auth-Key " auth-key)))
- :data `(("text" . ,(gts-deepl-fill-input text))
- ("source_lang" . ,(gts-get-lang engine from))
- ("target_lang" . ,(gts-get-lang engine to)))
- :done (lambda ()
- (gts-update-raw task (buffer-string))
- (gts-parse parser task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task
- (if (ignore-errors (= (caddar err) 403))
- "[403] http error, make sure your auth_key is correct"
- err)))))))
-
-\f
-;;; Parser
-
-(cl-defmethod gts-parse ((_ gts-deepl-parser) task)
- (let* ((json (json-read-from-string (oref task raw)))
- (str (mapconcat (lambda (r) (cdr (cadr r))) (cdar json) "\n"))
- (filter (lambda (parsed)
- (cl-loop for p in (gts-ensure-list parsed)
- collect (gts-deepl-fill-output p) into ps
- finally (return (if (cdr ps) ps (car ps)))))))
- (gts-update-parsed task (decode-coding-string str 'utf-8) nil filter)))
-
-
-(provide 'gts-engine-deepl)
-
-;;; gts-engine-deepl.el ends here
+++ /dev/null
-;;; gts-engine-google-rpc.el --- Google translation with rpc api -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; http://translate.google.com, new RPC API
-
-;;; Code:
-
-(require 'gts-engine-google)
-
-(defcustom gts-google-rpc-base-url "https://translate.google.com"
- "The base url of Google translate used by google-rpc engine.
-you can customize it according to your country region."
- :type 'string
- :group 'go-translate)
-
-\f
-;;; Components
-
-(defclass gts-google-rpc-parser (gts-google-parser)
- ((tag :initform "Detail")))
-
-(defclass gts-google-rpc-summary-parser (gts-google-summary-parser gts-google-rpc-parser)
- ((tag :initform "Summary")))
-
-(defclass gts-google-rpc-engine (gts-engine)
- ((tag :initform "Google/RPC")
- (sub-url :initform "/_/TranslateWebserverUi/data/batchexecute")
- (parser :initform (gts-google-rpc-parser))
-
- (rpc-translate :initform "MkEWBc")
- (rpc-tts :initform "jQ1olc")
- (rpc-sid :initform "FdrFJe")
- (rpc-bl :initform "cfb2h")))
-
-\f
-;;; Engine
-
-(defvar gts-google-rpc-request-headers '(("Content-Type" . "application/x-www-form-urlencoded;charset=UTF-8")))
-
-(cl-defmethod gts-with-token ((engine gts-google-rpc-engine) done fail)
- (with-slots (sub-url rpc-sid rpc-bl) engine
- (gts-do-request gts-google-rpc-base-url
- :done
- (lambda ()
- (let* ((f-sid (progn
- (re-search-forward (format "\"%s\":\"\\([^\"]*\\)\"" rpc-sid))
- (match-string 1)))
- (bl (progn (re-search-forward (format "\"%s\":\"\\([^\"]*\\)\"" rpc-bl))
- (match-string 1)))
- (url-tpl (lambda (rpcid lang)
- (format "%s%s?%s" gts-google-rpc-base-url sub-url
- (gts-format-params
- `(("rpcids" . ,rpcid)
- ("f.sid" . ,f-sid)
- ("bl" . ,bl)
- ("hl" . ,lang)
- ("soc-app" . 1)
- ("soc-platform" . 1)
- ("soc-device" . 1)
- ("_reqid" . ,(+ 1000 (random 9000)))
- ("rt" . "c")))))))
- (funcall done url-tpl)))
- :fail fail)))
-
-(cl-defmethod gts-translate ((engine gts-google-rpc-engine) task rendercb)
- (gts-with-token engine
- (lambda (url-tpl)
- (with-slots (text from to) task
- (with-slots (rpc-translate parser) engine
- (gts-do-request (funcall url-tpl rpc-translate to)
- :headers gts-google-rpc-request-headers
- :data (format
- "f.req=%s&"
- (url-hexify-string
- (let ((outer [[[rpcid inner nil "generic"]]])
- (inner [[text from to t][nil]]))
- (setf (aref (aref inner 0) 0) text)
- (setf (aref (aref inner 0) 1) from)
- (setf (aref (aref inner 0) 2) to)
- (setf (aref (aref (aref outer 0) 0) 0) rpc-translate)
- (setf (aref (aref (aref outer 0) 0) 1) (json-encode inner))
- (json-encode outer))))
- :done (lambda ()
- (gts-update-raw task (buffer-string))
- (gts-parse parser task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task err))))))
- (lambda (err)
- (gts-render-fail task
- (format "Error occurred when request for token.\n\n%s" err)))))
-
-(cl-defmethod gts-tts ((engine gts-google-rpc-engine) text lang)
- (gts-with-token engine
- (lambda (url-tpl)
- (with-slots (rpc-tts) engine
- (gts-do-request (funcall url-tpl rpc-tts "en-US")
- :headers gts-google-rpc-request-headers
- :data (format
- "f.req=%s&"
- (url-hexify-string
- (let ((outer [[[rpcid inner nil "generic"]]])
- (inner [text lang nil nil]))
- (setf (aref inner 0) text)
- (setf (aref inner 1) lang)
- (setf (aref (aref (aref outer 0) 0) 0) rpc-tts)
- (setf (aref (aref (aref outer 0) 0) 1) (json-encode inner))
- (json-encode outer))))
- :done (lambda ()
- (let (beg end json code)
- (re-search-forward "^[0-9]+$")
- (setq beg (point))
- (re-search-forward "^\\([0-9]+\\)$")
- (setq end (- (point) (length (match-string 1))))
- (setq json (json-read-from-string (string-trim (buffer-substring-no-properties beg end))))
- (when (string= (gts-aref-for json 0 0) "wrb.fr")
- (setq code (aref (json-read-from-string (gts-aref-for json 0 2)) 0))
- (erase-buffer)
- (insert code)
- (base64-decode-region (point-min) (point-max))
- (gts-tts-speak-buffer-data))))
- :fail (lambda (err) (user-error "Error when TTS. %s" err)))))
- (lambda (_) (user-error "Error occurred when request for token"))))
-
-\f
-;;; Parser
-
-(cl-defmethod gts-resp-to-json ((_ gts-google-rpc-parser) resp)
- "Convert the buffer RESP into JSON format."
- (condition-case err
- (with-temp-buffer
- (let (beg end str json)
- (insert resp)
- (goto-char (point-min))
- (re-search-forward "^[0-9]+$")
- (setq beg (point))
- (re-search-forward "^\\([0-9]+\\)$")
- (setq end (- (point) (length (match-string 1))))
- (setq str
- (decode-coding-string
- (string-trim (buffer-substring-no-properties beg end))
- 'utf-8))
- (setq json (json-read-from-string str))
- (if (string= (aref (aref json 0) 0) "wrb.fr")
- (let ((json-str (aref (aref json 0) 2)))
- (json-read-from-string json-str))
- (error "No results found"))))
- (error (user-error "Result conversion error (%s)" err))))
-
-(cl-defmethod gts-result--brief ((_ gts-google-rpc-parser) json)
- "Get the translation text from JSON."
- (mapconcat
- (lambda (item)
- (if (ignore-errors (aref item 2))
- (format " %s" (aref item 0))
- (aref item 0)))
- (gts-aref-for json 1 0 0 5)
- ""))
-
-(cl-defmethod gts-result--sphonetic ((_ gts-google-rpc-parser) json)
- "Get the text phonetic from JSON."
- (gts-aref-for json 0 0))
-
-(cl-defmethod gts-result--tphonetic ((_ gts-google-rpc-parser) json)
- "Get the translation phonetic from JSON."
- (gts-aref-for json 1 0 0 1))
-
-(cl-defmethod gts-result--details ((_ gts-google-rpc-parser) json)
- "Get the details from JSON.
-Result style: ((noun (a (x y z))) (verb (b (m n o))))."
- (cl-loop with dts = (ignore-errors (gts-aref-for json 3 5 0))
- for i across dts
- collect
- (cons
- (aref i 0)
- (cl-loop for j across (aref i 1)
- collect
- (cons
- (aref j 0)
- (cl-loop for k across (aref j 2) collect k))))))
-
-(cl-defmethod gts-result--definitions ((_ gts-google-rpc-parser) json)
- "Get the definitions from JSON.
-Result style: ((noun (a b)) (verb (c d)))."
- (cl-loop with defs = (ignore-errors (gts-aref-for json 3 1 0))
- for i across defs
- collect
- (cons
- (aref i 0)
- (cl-loop for j across (aref i 1)
- collect
- (cons (aref j 0)
- (ignore-errors (aref j 1)))))))
-
-(cl-defmethod gts-result--suggestion ((_ gts-google-rpc-parser) json)
- "Get the suggestion from JSON."
- (ignore-errors
- (replace-regexp-in-string "<b>\\|</b>\\|<i>\\|</i>" "" (gts-aref-for json 0 1 0 0 1))))
-
-
-(provide 'gts-engine-google-rpc)
-
-;;; gts-engine-google-rpc.el ends here
+++ /dev/null
-;;; gts-engine-google.el --- Google translate module -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; http://translate.google.com
-
-;;; Code:
-
-(require 'gts-implements)
-
-\f
-;;; Components
-
-(defclass gts-google-parser (gts-parser)
- ((tag :initform "Detail")))
-
-(defclass gts-google-summary-parser (gts-google-parser)
- ((tag :initform "Summary")))
-
-(defclass gts-google-engine (gts-engine)
- ((tag :initform "Google")
- (base-url :initform "http://translate.googleapis.com")
- (sub-url :initform "/translate_a/single")
- (token :initform (cons 430675 2721866130) :initarg token) ; hard code
- (token-time :initform t)
- (token-expired-time :initform (* 30 60))
- (parser :initform (gts-google-parser))))
-
-\f
-;;; Engine
-
-(defvar gts-google-request-headers '(("Connection" . "Keep-Alive")))
-
-(cl-defmethod gts-gen-url ((engine gts-google-engine) text from to)
- "Generate the url with TEXT, FROM and TO. Return a (url text from to) list."
- (format "%s%s?%s"
- (oref engine base-url)
- (oref engine sub-url)
- (mapconcat (lambda (p)
- (format "%s=%s" (url-hexify-string (car p)) (url-hexify-string (cdr p))))
- `(("client" . "gtx")
- ("ie" . "UTF-8")
- ("oe" . "UTF-8")
- ("dt" . "bd")
- ("dt" . "ex")
- ("dt" . "ld")
- ("dt" . "md")
- ("dt" . "qc")
- ("dt" . "rw")
- ("dt" . "rm")
- ("dt" . "ss")
- ("dt" . "t")
- ("dt" . "at")
- ("pc" . "1")
- ("otf" . "1")
- ("srcrom" . "1")
- ("ssel" . "0")
- ("tsel" . "0")
- ("hl" . ,to)
- ("sl" . ,from)
- ("tl" . ,to)
- ("q" . ,text)
- ("tk" . ,(gts-google-tkk (oref engine token) text)))
- "&")))
-
-(cl-defmethod gts-token-available-p ((engine gts-google-engine))
- (with-slots (token token-time token-expired-time) engine
- (and token
- (or (eq token-time t)
- (and token-time
- (<= (float-time (time-subtract (current-time) token-time))
- token-expired-time))))))
-
-(cl-defmethod gts-with-token ((engine gts-google-engine) done fail)
- (with-slots (token token-time base-url) engine
- (if (gts-token-available-p engine)
- (funcall done)
- (gts-do-request base-url
- :headers gts-google-request-headers
- :done (lambda ()
- (let ((tk (progn
- (re-search-forward ",tkk:'\\([0-9]+\\)\\.\\([0-9]+\\)")
- (cons (string-to-number (match-string 1))
- (string-to-number (match-string 2))))))
- (setf token tk)
- (setf token-time (current-time))
- (funcall done)))
- :fail fail))))
-
-(cl-defmethod gts-translate ((engine gts-google-engine) task rendercb)
- (gts-with-token engine
- (lambda ()
- (with-slots (text from to) task
- (gts-do-request (gts-gen-url engine text from to)
- :headers gts-google-request-headers
- :done (lambda ()
- (gts-update-raw task (buffer-string))
- (gts-parse (oref engine parser) task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task err)))))
- (lambda (err)
- (gts-render-fail task
- (format "Error when fetching Token-Key, check your network and proxy, or retry later\n\n%s" err)))))
-
-;; tts
-
-(cl-defmethod gts-tts-gen-urls ((engine gts-google-engine) text lang)
- "Generate the tts urls for TEXT to LANGUAGE."
- (cl-loop with texts = (gts-tts-text-splitter engine text)
- for total = (length texts)
- for index from 0
- for piece in texts
- collect
- (let ((params `(("ie" . "UTF-8")
- ("client" . "gtx")
- ("prev" . "input")
- ("q" . ,text)
- ("tl" . ,lang)
- ("total" . ,(number-to-string total))
- ("idx" . ,(number-to-string index))
- ("textlen" . ,(number-to-string (length piece)))
- ("tk" . ,(gts-google-tkk (oref engine token) piece)))))
- (format "%s/translate_tts?%s"
- (oref engine base-url)
- (mapconcat (lambda (p)
- (format "%s=%s"
- (url-hexify-string (car p))
- (url-hexify-string (cdr p))))
- params "&")))))
-
-(cl-defmethod gts-tts-text-splitter ((_ gts-google-engine) text)
- "Split TEXT by maxlen at applicable point for translating.
-Code from `google-translate', maybe improve it someday."
- (let (result (maxlen 200))
- (if (or (null maxlen) (<= maxlen 0))
- (push text result)
- ;; split long text?
- (with-temp-buffer
- (save-excursion (insert text))
- ;; strategy to split at applicable point
- ;; 1) fill-region remaining text by maxlen
- ;; 2) find end of sentence, end of punctuation, word boundary
- ;; 3) consume from remaining text between start and (2)
- ;; 4) repeat
- (let ((fill-column (* maxlen 3))
- (sentence-end-double-space nil)
- (pos (point-min)))
- (while (< pos (point-max))
- (save-restriction
- (narrow-to-region pos (point-max))
- (fill-region pos (point-max))
- (let ((limit (+ pos maxlen)))
- (if (>= limit (point-max))
- (setq limit (point-max))
- (goto-char limit)
- ;; try to split at end of sentence
- (if (> (backward-sentence) pos)
- (setq limit (point))
- ;; try to split at end of punctuation
- (goto-char limit)
- (if (re-search-backward "[,、]" pos t)
- (setq limit (1+ (point))) ; include punctuation
- (goto-char limit)
- ;; try to split at word boundary
- (forward-word-strictly -1)
- (when (> (point) pos)
- (setq limit (point))))))
- (push (buffer-substring-no-properties pos limit) result)
- (goto-char limit)
- (setq pos limit)))))))
- (reverse result)))
-
-(cl-defmethod gts-tts ((engine gts-google-engine) text lang)
- (let ((urls (gts-tts-gen-urls engine text lang))
- (speaker (split-string gts-tts-speaker)))
- (with-temp-message "Speaking..."
- (gts-tts-try-interrupt-playing-process)
- (apply #'call-process (car speaker) nil nil nil (append (cdr speaker) urls)))))
-
-\f
-;;; Parser
-
-;; detail-mode, use as default
-
-(cl-defmethod gts-parse ((parser gts-google-parser) task)
- (let* ((json (gts-resp-to-json parser (oref task raw)))
- (brief (gts-result--brief parser json))
- (sphonetic (gts-result--sphonetic parser json))
- (tphonetic (gts-result--tphonetic parser json))
- (details (gts-result--details parser json))
- (definitions (gts-result--definitions parser json))
- (suggestion (gts-result--suggestion parser json))
- (suggestionp (> (length suggestion) 0)) tbeg tend)
- (cl-flet ((phonetic (ph)
- (if (and (or definitions definitions) (> (length ph) 0))
- (propertize (format " [%s]" ph) 'face 'gts-google-buffer-phonetic-face)
- ""))
- (headline (line)
- (propertize (format "[%s]\n" line) 'face 'gts-google-buffer-headline-face)))
- (with-temp-buffer
- ;; suggestion
- (when suggestionp
- (insert (propertize "Do you mean:" 'face 'gts-google-buffer-suggestion-desc-face) " "
- (propertize suggestion 'face 'gts-google-buffer-suggestion-text-face) "?\n\n"))
- ;; phonetic & translate
- (if (or details definitions)
- (progn
- (insert (if suggestionp suggestion (oref (oref task translator) text)))
- (insert (phonetic sphonetic) " ")
- (setq tbeg (point))
- (insert (propertize brief 'face 'gts-google-buffer-brief-result-face))
- (setq tend (point))
- (insert (phonetic tphonetic) "\n\n"))
- (insert brief))
- ;; details
- (when details
- (insert (headline "Details"))
- (cl-loop for (label . items) in details
- unless (= 0 (length label))
- do (insert (format "\n%s:\n" label))
- do (cl-loop with index = 0
- for trans in items
- do (insert
- (format "%2d. " (cl-incf index))
- (car trans)
- " (" (mapconcat #'identity (cdr trans) ", ") ")"
- "\n")))
- (insert "\n"))
- ;; definitions
- (when definitions
- (insert (headline "Definitions"))
- (cl-loop for (label . items) in definitions
- unless (= 0 (length label))
- do (insert (format "\n%s:\n" label))
- do (cl-loop with index = 0
- for (exp . eg) in items
- do (insert (format "%2d. " (cl-incf index)) exp)
- when (> (length eg) 0)
- do (insert
- "\n > "
- (propertize (or eg "") 'face 'gts-google-buffer-detail-demo-face))
- do (insert "\n"))))
- ;; at last, fill and return
- (gts-update-parsed task (buffer-string) (list :tbeg tbeg :tend tend))))))
-
-;; summary-mode
-
-(cl-defmethod gts-parse ((parser gts-google-summary-parser) task)
- (let* ((json (gts-resp-to-json parser (oref task raw)))
- (result (string-trim (gts-result--brief parser json))))
- (gts-update-parsed task result (list :tbeg 1 :tend (+ 1 (length result))))))
-
-;; Extract results from response
-
-(cl-defmethod gts-resp-to-json ((_ gts-google-parser) resp)
- "Convert the buffer RESP into JSON."
- (condition-case err
- (json-read-from-string (decode-coding-string resp 'utf-8))
- (error (user-error "Result conversion error: %s" err))))
-
-(cl-defmethod gts-result--brief ((_ gts-google-parser) json)
- "Get the translation text from JSON."
- (mapconcat (lambda (item) (aref item 0)) (aref json 0) ""))
-
-(cl-defmethod gts-result--sphonetic ((_ gts-google-parser) json)
- "Get the text phonetic from JSON."
- (mapconcat (lambda (item) (if (> (length item) 3) (aref item 3) "")) (aref json 0) ""))
-
-(cl-defmethod gts-result--tphonetic ((_ gts-google-parser) json)
- "Get the translation phonetic from JSON."
- (mapconcat (lambda (item) (if (> (length item) 2) (aref item 2) "")) (aref json 0) ""))
-
-(cl-defmethod gts-result--details ((_ gts-google-parser) json)
- "Get the details from JSON.
-Result style: ((noun (a (x y z))) (verb (b (m n o))))."
- (cl-loop for i across (aref json 1)
- collect
- (cons
- (aref i 0)
- (cl-loop for j across (aref i 2)
- collect
- (cons
- (aref j 0)
- (cl-loop for k across (aref j 1) collect k))))))
-
-(cl-defmethod gts-result--definitions ((_ gts-google-parser) json)
- "Get the definitions from JSON.
-Result style: ((noun (a b)) (verb (c d)))."
- (cl-loop with defs = (ignore-errors (aref json 12))
- for i across defs
- collect
- (cons
- (aref i 0)
- (cl-loop for j across (aref i 1)
- collect
- (cons
- (aref j 0)
- (ignore-errors (aref j 2)))))))
-
-(cl-defmethod gts-result--suggestion ((_ gts-google-parser) json)
- "Get the suggestion from JSON."
- (let ((info (aref json 7))) (unless (seq-empty-p info) (aref info 1))))
-
-\f
-;;; Token Key algorithm (deprecated)
-
-;; This algorithm is from `google-translate' project.
-;; https://github.com/atykhonov/google-translate/blob/master/google-translate-tk.el
-
-(defvar gts-google-token--bit-v-len 32)
-
-(defun gts-google-token--bit-v-2comp (v)
- "Return the two's complement of V."
- (let* ((vc (vconcat v))
- (len (length vc)))
- ;; Complement of v
- (cl-loop for i from 0 below len do
- (aset vc i (logxor (aref vc i) 1)))
- ;; vc = complement of v + 1
- (cl-loop for i downfrom (1- len) to 0
- do (aset vc i (logxor (aref vc i) 1))
- when (> (aref vc i) 0) return nil)
- vc))
-
-(defun gts-google-token--number-to-bit-v (n)
- "Return a bit vector from N."
- (if (< n 0) (gts-google-token--bit-v-2comp
- (gts-google-token--number-to-bit-v (abs n)))
- (let ((v (make-vector gts-google-token--bit-v-len 0)))
- (cl-loop for i downfrom (1- gts-google-token--bit-v-len) to 0
- with q
- when (< n 1) return nil do
- (setq q (ffloor (* n 0.5)))
- (aset v i (floor (- n (* 2.0 q))))
- (setq n q))
- v)))
-
-(defun gts-google-token--bit-v-to-number (v)
- "Return a floating-point number from V."
- (if (and (> (aref v 0) 0)
- ;; Exclude [1 0 ... 0]
- (cl-loop for i from 1 below gts-google-token--bit-v-len
- thereis (> (aref v i) 0)))
- (- (gts-google-token--bit-v-to-number (gts-google-token--bit-v-2comp v)))
- (funcall (if (> (aref v 0) 0) #'- #'+)
- (cl-reduce (lambda (acc e) (+ (* acc 2.0) e))
- v :initial-value 0.0))))
-
-(defun gts-google-token--logfn (fn n1 n2)
- "Helper function for logical FN with N1 and N2."
- (let ((v1 (gts-google-token--number-to-bit-v n1))
- (v2 (gts-google-token--number-to-bit-v n2))
- (v (make-vector gts-google-token--bit-v-len 0)))
- (cl-loop for i from 0 below gts-google-token--bit-v-len do
- (aset v i (funcall fn (aref v1 i) (aref v2 i))))
- (gts-google-token--bit-v-to-number v)))
-
-(defun gts-google-token--logand (n1 n2)
- "Return a floating-point number from N1 and N2."
- (gts-google-token--logfn #'logand n1 n2))
-
-(defun gts-google-token--logxor (n1 n2)
- "Return a floating-point number from N1 and N2."
- (gts-google-token--logfn #'logxor n1 n2))
-
-(defun gts-google-token--lsh (n d)
- "Return a floating-point number.
-Shift the bits in N to the left or rihgt D places.
-D is an integer."
- (let ((v (gts-google-token--number-to-bit-v n))
- (v-result (make-vector gts-google-token--bit-v-len 0)))
- (if (< d 0)
- ;; Shift Right Logical
- (cl-loop for i from (abs d) below gts-google-token--bit-v-len
- for j from 0 do
- (aset v-result i (aref v j)))
- ;; Shift Left Logical
- (cl-loop for i from d below gts-google-token--bit-v-len
- for j from 0 do
- (aset v-result j (aref v i))))
- (gts-google-token--bit-v-to-number v-result)))
-
-(defun gts-google-token--gen-rl (a b)
- "Gen rl from A and B."
- (cl-loop for c from 0 below (- (length b) 2) by 3
- for d = (aref b (+ c 2)) do
- (setq d (if (>= d ?a) (- d 87) (- d ?0)))
- (setq d (if (= (aref b (1+ c)) ?+)
- (gts-google-token--lsh a (- d))
- (gts-google-token--lsh a d)))
- (setq a (if (= (aref b c) ?+)
- (gts-google-token--logand (+ a d) 4294967295.0)
- (gts-google-token--logxor a d))))
- a)
-
-(defun gts-google-tkk (token text)
- "Calculate the Token for search TEXT.
-
-It will use the tkk from Google translate page."
- (let* ((b (car token))
- (d1 (cdr token))
- (ub "+-3^+b+-f")
- (vb "+-a^+6")
- (a (cl-loop for c across (encode-coding-string text 'utf-8)
- for rr = (gts-google-token--gen-rl (+ (or rr b) c) vb)
- finally (return rr))))
- (setq a (gts-google-token--gen-rl a ub))
- (setq a (gts-google-token--logxor a d1))
- (if (< a 0) (setq a (+ (gts-google-token--logand a 2147483647.0) 2147483648.0)))
- (setq a (ffloor (mod a 1e6)))
- (format "%s.%s"
- (car (split-string (number-to-string a) "\\."))
- (car (split-string (number-to-string
- (gts-google-token--logxor a b))
- "\\.")))))
-
-
-(provide 'gts-engine-google)
-
-;;; gts-engine-google.el ends here
+++ /dev/null
-;;; gts-engine-stardict.el --- StarDict -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; Engine for sdcv (StarDict Console Version).
-;;
-;; sdcv is an offline translate software. It can be used when no network.
-;;
-;; Make sure sdcv is installed on your system:
-;;
-;; sudo pacman -S sdcv
-;;
-;; Then download dictionary data to ~/.stardict/dic or /usr/share/stardict/dic:
-;;
-;; # For example from http://download.huzheng.org:
-;;
-;; mkdir -p ~/.stardict/dic
-;; cd ~/.stardict/dic
-;; wget http://download.huzheng.org/zh_CN/stardict-langdao-ce-gb-2.4.2.tar.bz2
-;; wget http://download.huzheng.org/zh_CN/stardict-langdao-ce-gb-2.4.2.tar.bz2
-;; tar xvf stardict-langdao-ec-gb-2.4.2.tar.bz2
-;; tar xvf stardict-langdao-ce-gb-2.4.2.tar.bz2
-;; sdcv -l
-;;
-;; TODO: Provide more options and a better parser.
-
-;;; Code:
-
-(require 'gts-implements)
-
-(defclass gts-stardict-engine (gts-engine)
- ((tag :initform "StarDict")
- (parser :initform (gts-parser))))
-
-(defcustom gts-stardict-program "sdcv"
- "Executable command of sdcv (StarDict Console Version)."
- :type 'string
- :group 'go-translate)
-
-(cl-defmethod gts-translate ((engine gts-stardict-engine) task rendercb)
- (let* ((text (oref task text))
- (parser (oref engine parser))
- (result (with-temp-buffer
- (require 'ansi-color)
- (apply #'call-process gts-stardict-program nil t nil
- (list "--non-interactive" "--color" text)) ;--json-output
- (if (string-equal (buffer-substring 1 16) "Nothing similar")
- "No translation result found, sorry :("
- (ansi-color-apply (buffer-string))))))
- (gts-update-raw task result)
- (gts-parse parser task)
- (funcall rendercb)))
-
-
-(provide 'gts-engine-stardict)
-
-;;; gts-engine-stardict.el ends here
+++ /dev/null
-;;; gts-engine-youdao.el --- YouDao Dict -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; 有道词典 (dict.youdao.com), A chinese translation website.
-;;
-;; This engine is only for chinese user.
-;; > 此引擎仅供中文翻译使用
-;;
-;; Simply implement using EWW to do the parsing job for now. I am too lazy to parse and extract the html results.
-;; > 懒得去解析、组装 html，所以暂时直接借用 eww 的解析结果
-;; > 权作应急使用，*也许* 以后会增加更完善的 parser 方案
-
-;;; Code:
-
-(require 'gts-implements)
-
-(defclass gts-youdao-dict-eww-parser (gts-parser)
- ((tag :initform "EWW")))
-
-(defclass gts-youdao-dict-engine (gts-engine)
- ((tag :initform "有道词典")
- (url :initform "https://dict.youdao.com/result?word=%s&lang=%s")
- (parser :initform (gts-youdao-dict-eww-parser))))
-
-(cl-defmethod gts-translate ((engine gts-youdao-dict-engine) task rendercb)
- (with-slots (text from to meta) task
- (with-slots (url parser) engine
- (let* ((lang (cond ((string-equal from "zh") to)
- ((string-equal to "zh") from)
- (t (user-error "只支持中文跟其他语言之间的翻译"))))
- (url (format url (url-hexify-string text) (url-hexify-string lang))))
- (setf meta (list :url url))
- (gts-do-request url
- :done (lambda ()
- (gts-update-raw task (buffer-string)) ; html format response
- (gts-parse parser task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task err)))))))
-
-(cl-defmethod gts-parse ((_ gts-youdao-dict-eww-parser) task)
- (with-slots (raw meta) task
- (with-temp-buffer
- (let ((buf (current-buffer)))
- (with-temp-buffer
- (require 'eww)
- (insert "Content-type: text/html; charset=utf-8\n\n" raw)
- (eww-render nil (plist-get meta :url) nil buf))
- (gts-update-parsed task (buffer-string) meta)))))
-
-
-(provide 'gts-engine-youdao)
-
-;;; gts-engine-youdao.el ends here
+++ /dev/null
-;;; gts-faces.el --- Face definitions -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; The faces and colors.
-
-;;; Code:
-
-(require 'gts-core)
-
-(defgroup go-translate-faces nil
- "The faces for this framework."
- :group 'go-translate)
-
-\f
-;;; Common
-
-(defface gts-logger-buffer-tag-face '((t :inherit font-lock-comment-face))
- "Used in the logger buffer tag keyword."
- :group 'go-translate-faces)
-
-(defface gts-logger-buffer-timestamp-face '((t :foreground "grey"))
- "Used in the logger buffer timestamp keyword."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-header-line-lang-face '((t :inherit font-lock-keyword-face))
- "Used in the buffer's header-line-format, from/to."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-header-line-desc-face '((t :inherit font-lock-variable-name-face))
- "Used in the buffer's header-line-format, description."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-error-face '((t :inherit font-lock-warning-face))
- "Used in the buffer's error text."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-source-face '((t :inherit font-lock-string-face))
- "Used in the buffer's source."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-me-header-backgroud-face '((t :background "slategray" :foreground "white" :extend t))
- "Used in the buffer's multiple engine separator."
- :group 'go-translate-faces)
-
-\f
-;;; Google Buffer Render
-
-(defface gts-google-buffer-headline-face '((t :inherit font-lock-function-name-face :weight bold))
- "Propertize the headline in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-phonetic-face '((t :inherit font-lock-string-face :slant normal))
- "Propertize the phonetic in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-suggestion-desc-face '((t :inherit font-lock-warning-face))
- "Propertize the suggestion description in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-suggestion-text-face '((t :slant italic :underline t))
- "Propertize the phonetic text in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-brief-result-face '((t :weight bold))
- "Propertize the brief result in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-source-face '((t :inherit font-lock-string-face))
- "Propertize the source in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-detail-demo-face '((t :inherit font-lock-doc-face))
- "Propertize the detail demo in buffer rendering."
- :group 'go-translate-faces)
-
-\f
-;;; Posframe Render
-
-(defcustom gts-pop-posframe-forecolor "white"
- "Default foreground color of pop posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pop-posframe-backcolor "black"
- "Default background color of pop posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pin-posframe-forecolor nil
- "Default foreground color of pin posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pin-posframe-backcolor nil
- "Default background color of pin posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pin-posframe-bdcolor "#000000"
- "Default border color of pin posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pin-posframe-fringe-color nil
- "Used in the posframe pip buffer fringe color."
- :type 'string
- :group 'go-translate-faces)
-
-(defface gts-pop-posframe-me-header-face '((t :foreground "grey"))
- "Used in the posframe pop buffer engine header."
- :group 'go-translate-faces)
-
-(defface gts-pop-posframe-me-header-2-face '((t (:foreground "#666666" :underline t :extend t)))
- "Used in the posframe pop buffer engine header."
- :group 'go-translate-faces)
-
-
-(provide 'gts-faces)
-
-;;; gts-faces.el ends here
+++ /dev/null
-;;; gts-implements.el --- Component implements -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; Builtin implements of basic components
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'url)
-(require 'json)
-(require 'gts-core)
-(require 'gts-faces)
-
-\f
-;;; [Logger] Log all to a standalone buffer
-
-(defclass gts-buffer-logger (gts-logger)
- ((buffer :initarg buf :initform nil))) ; dont set :initarg to buffer, it will make an error on emacsv27.
-
-(defvar gts-logger-buffer-name " *gts-logger*")
-
-(cl-defmethod gts-log ((logger gts-buffer-logger) tag msg)
- (with-current-buffer (get-buffer-create (or (oref logger buffer) gts-logger-buffer-name))
- (goto-char (point-max))
- (if (or (= (length msg) 0) (string= msg "\n"))
- (insert "")
- (insert
- (propertize (cl-subseq (format "%-.1f" (time-to-seconds)) 6) 'face 'gts-logger-buffer-timestamp-face)
- " "
- (propertize (concat "[" tag "] ") 'face 'gts-logger-buffer-tag-face))
- (insert msg))
- (insert "\n")))
-
-(setq gts-default-logger (gts-buffer-logger))
-
-\f
-;;; [Cacher] Cache in the memory
-
-(defclass gts-memory-cacher (gts-cacher) ()
- "Cache in the memory.")
-
-(cl-defmethod gts-cache-get ((cacher gts-memory-cacher) task)
- (when gts-cache-enable
- (with-slots (caches expired) cacher
- (let ((key (gts-cache-key cacher task)))
- (when-let ((cache (assoc key caches)))
- (when (> (cddr cache) (time-to-seconds))
- (gts-do-log 'memory-cacher (format "%s: get from cache %s (%s)" (oref task id) key (length caches)))
- (cadr cache)))))))
-
-(cl-defmethod gts-cache-set ((cacher gts-memory-cacher) task result)
- (when gts-cache-enable
- (with-slots (caches expired) cacher
- (let* ((key (gts-cache-key cacher task))
- (cache (assoc key caches))
- (text (oref task text))
- (etime
- ;; sentence with shorter expired time, but word with longer.
- (if (string-match-p "[[:space:]\n]" text)
- (+ (time-to-seconds) gts-cache-expired-factor)
- (+ (time-to-seconds) (* 100 gts-cache-expired-factor)))))
- (if cache
- (progn
- (setf (cadr cache) result)
- (setf (cddr cache) etime)
- (gts-do-log 'memory-cacher (format "%s: update cache %s (%s)" (oref task id) key (length caches))))
- (oset cacher caches (cons (cons key (cons result etime)) caches))
- (gts-do-log 'memory-cacher (format "%s: add to cache %s (%s)" (oref task id) key (length caches))))
- (gts-clear-expired cacher)))))
-
-(setq gts-default-cacher (gts-memory-cacher))
-
-\f
-;;; [Http Client] implement with builtin `url.el'.
-;; This will be used as the default http client.
-
-(defclass gts-url-http-client (gts-http-client) ())
-
-(defcustom gts-user-agent "Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.75 Safari/537.36"
- "The user agent used when send a request."
- :type 'string
- :group 'go-translate)
-
-(defvar url-http-end-of-headers)
-
-(cl-defmethod gts-request ((_ gts-url-http-client) url &key done fail data headers)
- "Request URL with DATA and HEADERS asynchronous.
-Execute DONE when success, or FAIL when failed."
- (cl-assert (and url done fail))
- (let ((url-debug gts-debug-p)
- (url-user-agent gts-user-agent)
- (url-request-extra-headers headers)
- (url-request-method (if data "POST" "GET"))
- (url-request-data data))
- (url-retrieve url (lambda (status)
- (unwind-protect
- (if-let ((err (cond
- ((eq (car status) :error) (cadr status))
- ((null url-http-end-of-headers) "Nothing responsed from server"))))
- (funcall fail err)
- (when done
- (delete-region (point-min) url-http-end-of-headers)
- (funcall done)))
- (kill-buffer)))
- nil t)))
-
-(setq gts-default-http-client (gts-url-http-client)) ; use this as default
-
-\f
-;;; [Render] buffer render
-
-(defclass gts-buffer-render (gts-render) ())
-
-(defcustom gts-split-width-threshold 80
- "Threshold width for window horizontal split."
- :group 'go-translate
- :type '(choice
- (const :tag "Disable" nil)
- (integer :tag "Threshold")))
-
-(defcustom gts-buffer-follow-p nil
- "If t then pop to the result window after translation."
- :type 'boolean
- :group 'go-translate)
-
-(defcustom gts-buffer-name "*Go-Translate*"
- "The name of translation result buffer."
- :type 'string
- :group 'go-translate)
-
-(defcustom gts-buffer-window-config nil
- "Window configuration used by the result buffer window.
-
-For example, set to:
-
- \\='((display-buffer-reuse-window display-buffer-in-side-window)
- (side . right))
-
-will force opening in right side window."
- :type 'list
- :group 'go-translate)
-
-(defcustom gts-buffer-render-task-header-function #'gts-buffer-render-task-header
- "Function used to render the task header when in multiple engines's query."
- :type 'function
- :group 'go-translate)
-
-(defvar-local gts-buffer-translator nil)
-(defvar-local gts-buffer-keybinding-messages nil)
-(defvar-local gts-buffer-local-map nil)
-
-(cl-defmacro gts-buffer-set-key ((key &optional desc) form)
- "Helper for define KEY in buffer."
- (declare (indent 1))
- `(progn (define-key gts-buffer-local-map
- (kbd ,key)
- ,(if (equal 'function (car form)) `,form `(lambda () (interactive) ,form)))
- (when ,desc
- (cl-delete ,key gts-buffer-keybinding-messages :key #'car :test #'string=)
- (push (cons ,key ,desc) gts-buffer-keybinding-messages))))
-
-(defun gts-buffer-init-header-line (path &optional desc)
- "Setup header line format.
-It will show the basic information of the translation,
-including PATH and other DESC."
- (setq header-line-format
- (list
- " "
- "[" (propertize (car path) 'face 'gts-render-buffer-header-line-lang-face) "]"
- (if desc (concat " ― " (propertize desc 'face 'gts-render-buffer-header-line-desc-face)) "")
- " → "
- "[" (propertize (cdr path) 'face 'gts-render-buffer-header-line-lang-face) "]"
- " (" (propertize "h" 'face 'font-lock-type-face) " for help)"
- " "
- "Loading...")))
-
-(defun gts-buffer-change-header-line-state (type)
- "Update header line according TYPE."
- (cl-case type
- (done
- (when (string-equal (car (last header-line-format)) "Loading...")
- (setq header-line-format (butlast header-line-format))))))
-
-(defun gts-buffer-display-or-focus-buffer (buffer)
- "Only display the BUFFER, or display and focus."
- (with-current-buffer buffer
- (if gts-buffer-follow-p (pop-to-buffer buffer)
- (display-buffer buffer))))
-
-(defun gts-buffer-ensure-a-blank-line-at-beginning (buffer)
- "Ensure a blank line at beginning of BUFFER."
- (with-current-buffer buffer
- (let ((inhibit-read-only t))
- (save-excursion
- (let ((m (mark-marker)))
- (goto-char (point-min))
- (unless (equal (char-after) ?\n)
- (insert "\n"))
- (when (ignore-errors (= (marker-position m) 1))
- (set-marker m (point))))
- (set-buffer-modified-p nil)))))
-
-(defun gts-childframe-of-buffer (&optional buffer)
- "Get the childframe of BUFFER if it exists, or return nil."
- (let ((cf (window-frame (get-buffer-window buffer t))))
- (when (frame-parameter cf 'parent-frame) cf)))
-
-(defun gts-buffer-render-task-header (engine-tag parser-tag)
- (concat (propertize
- (format "%s %s\n" engine-tag (if parser-tag (format "(%s) " parser-tag) ""))
- 'face 'gts-render-buffer-me-header-backgroud-face)))
-
-(defun gts-render-buffer-prepare (buffer translator)
- (with-current-buffer (get-buffer-create buffer)
- (let ((inhibit-read-only t)
- (engines (gts-get translator 'engines)))
- (with-slots (text path) translator
- ;; setup
- (deactivate-mark)
- (visual-line-mode -1)
- (font-lock-mode 1)
- (setq-local cursor-type 'hbar)
- (setq-local cursor-in-non-selected-windows nil)
- (setq-local gts-buffer-translator translator)
- ;; headline
- (gts-buffer-init-header-line path (unless (cdr engines) (oref (car engines) tag)))
- ;; source text
- (erase-buffer)
- (unless (gts-childframe-of-buffer (current-buffer)) (insert "\n")) ; except childframe
- (insert text)
- ;; keybinds
- (setq gts-buffer-local-map (make-sparse-keymap))
- (gts-buffer-set-key ("x" "Reverse Path")
- (gts-translate translator text (cons (cdr path) (car path))))
- (gts-buffer-set-key ("M-p" "Prev Path")
- (gts-translate translator text (gts-next-path (gts-get translator 'picker) text path t)))
- (gts-buffer-set-key ("M-n" "Next Path")
- (gts-translate translator text (gts-next-path (gts-get translator 'picker) text path)))
- (gts-buffer-set-key ("g" "Refresh")
- (gts-translate translator text path))
- (gts-buffer-set-key ("y" "TTS")
- (if-let ((task (get-text-property (point) 'task)))
- (gts-do-tts text (car path) (oref task engine))
- (message "[TTS] No engine found at point")))
- (gts-buffer-set-key ("O" "Open Externally")
- (when-let ((task (get-text-property (point) 'task)))
- (let* ((meta (oref task meta)) (url (plist-get meta :url)))
- (cond (url (browse-url url) (message "Opening %s... Done!" url))
- (t (message "Don't know how to open externally for this."))))))
- (gts-buffer-set-key ("C" "Clean Cache")
- (gts-clear-all gts-default-cacher))
- (gts-buffer-set-key ("t" "Toggle-Follow")
- (let ((state (if (setq gts-buffer-follow-p (not gts-buffer-follow-p)) "allowed" "disabled")))
- (message "Now, buffer following %s." state)))
- (gts-buffer-set-key ("q" "Quit") #'kill-buffer-and-window)
- (gts-buffer-set-key ("p") #'previous-line)
- (gts-buffer-set-key ("n") #'next-line)
- (gts-buffer-set-key ("C-g")
- (unwind-protect (gts-tts-try-interrupt-playing-process)
- (keyboard-quit)))
- (gts-buffer-set-key ("h")
- (message (mapconcat
- (lambda (kd) (concat (propertize (car kd) 'face 'font-lock-keyword-face) ": " (cdr kd)))
- (reverse gts-buffer-keybinding-messages) " ")))
- (gts-buffer-set-key ("C-x C-q")
- (progn (read-only-mode -1)
- (use-local-map nil)
- (local-set-key (kbd "C-x C-q")
- (lambda ()
- (interactive)
- (read-only-mode 1)
- (use-local-map gts-buffer-local-map)))))
- (read-only-mode 1)
- (use-local-map gts-buffer-local-map)
- ;; execute the hook if exists
- (run-hooks 'gts-after-buffer-prepared-hook)))))
-
-(defun gts-render-buffer (buffer task)
- "For single engine translation."
- (when-let ((inhibit-read-only t)
- (buf (get-buffer buffer)))
- (with-current-buffer buf
- (with-slots (err parsed meta engine translator) task
- ;; error
- (if err
- (progn
- (goto-char (point-max))
- (insert (propertize (format "\n\n%s" err) 'face 'gts-render-buffer-error-face)))
- (erase-buffer)
- (cond
- ;; content (non-split)
- ((stringp parsed)
- (let ((tbeg (plist-get meta :tbeg))
- (tend (plist-get meta :tend)))
- (unless tbeg
- (insert (propertize (oref translator text) 'face 'gts-render-buffer-source-face) "\n\n"))
- (unless tbeg (setq tbeg (point)))
- (insert parsed)
- (unless tend (setq tend (point)))
- ;; try set mark in beginning of the translate result,
- ;; and set currsor position in end of the translate result,
- ;; so you can quick select the translate result with C-x C-x.
- (when (not (gts-childframe-of-buffer buf)) ; when not childframe
- (push-mark tend 'nomsg)
- (goto-char tbeg)
- (set-window-point (get-buffer-window buf t) tbeg))))
- ;; content (split)
- (t (cl-loop for idx from 0
- for src in (gts-get translator 'sptext)
- for tar in parsed
- concat (concat (propertize src 'face 'gts-render-buffer-source-face) "\n\n" tar "\n\n") into res
- finally (insert res)))))
- ;; update states
- (set-buffer-modified-p nil)
- (gts-buffer-change-header-line-state 'done)
- (put-text-property (point-min) (point-max) 'task task)
- ;; execute the hook if exists
- (run-hooks 'gts-after-buffer-render-hook))
- buf)))
-
-(defun gts-render-buffer-multi-engines (buffer task)
- "For multiple engines translation."
- (when-let ((inhibit-read-only t)
- (buf (get-buffer buffer)))
- (with-slots (from to translator) task
- (with-slots (text task-queue version) translator
- (with-current-buffer buf
- (when (equal (oref gts-buffer-translator version) version)
- (erase-buffer)
- (insert (propertize (format "\n%s\n\n" text) 'face 'gts-render-buffer-source-face))
- ;; content
- (save-excursion
- (dolist (task task-queue)
- (with-slots (err parsed meta engine) task
- (let* ((result (if (or err (stringp parsed)) parsed
- (string-join parsed "\n\n")))
- (header (funcall gts-buffer-render-task-header-function
- (oref engine tag)
- (oref (oref engine parser) tag)))
- (content (cond
- (err
- (concat header (propertize (format "\n%s\n\n" err) 'face 'gts-render-buffer-error-face)))
- ((string-empty-p result)
- (concat header "\nLoading...\n\n"))
- (t (concat header "\n" (string-trim result) "\n\n")))))
- (put-text-property 0 (length content) 'task task content)
- (insert content)))))
- ;; states
- (set-buffer-modified-p nil)
- ;; all tasks finished
- (when (= (oref translator state) 3)
- ;; cursor
- (unless (gts-childframe-of-buffer buf)
- (set-window-point (get-buffer-window buf t) (save-excursion (forward-line 2) (point))))
- ;; state
- (gts-buffer-change-header-line-state 'done))
- ;; execute the hook if exists
- (run-hooks 'gts-after-buffer-multiple-render-hook)))
- buf))))
-
-(cl-defmethod gts-pre ((_ gts-buffer-render) translator)
- ;; init and setup
- (gts-render-buffer-prepare gts-buffer-name translator)
- ;; display
- (let ((split-width-threshold (or gts-split-width-threshold split-width-threshold)))
- (display-buffer gts-buffer-name gts-buffer-window-config)))
-
-(cl-defmethod gts-out ((_ gts-buffer-render) task)
- ;; render & display
- (when-let ((buf (gts-render-buffer gts-buffer-name task)))
- (gts-buffer-ensure-a-blank-line-at-beginning buf)
- (gts-buffer-display-or-focus-buffer buf)))
-
-(cl-defmethod gts-me-out ((_ gts-buffer-render) task)
- ;; render & display
- (when-let ((buf (gts-render-buffer-multi-engines gts-buffer-name task)))
- (when (= (oref (oref task translator) state) 3)
- (gts-buffer-display-or-focus-buffer buf))))
-
-\f
-;;; [Render] Child-Frame Render (Popup Mode)
-;; implements via package Posframe, you should install it before use this
-
-(defclass gts-posframe-pop-render (gts-render)
- ((width :initarg :width :initform 100)
- (height :initarg :height :initform 15)
- (forecolor :initarg :forecolor :initform nil)
- (backcolor :initarg :backcolor :initform nil)
- (padding :initarg :padding :initform 12))
- "Pop up a childframe to show the result.
-The frame will disappear when do do anything but focus in it.
-Manually close the frame with `q'.")
-
-(require 'posframe nil t)
-(declare-function posframe-show "ext:posframe.el" t t)
-(declare-function posframe-delete "ext:posframe.el" t t)
-(declare-function posframe-hide "ext:posframe.el" t t)
-(declare-function posframe-refresh "ext:posframe.el" t t)
-(declare-function posframe-poshandler-frame-top-right-corner "ext:posframe.el" t t)
-
-(defcustom gts-posframe-pop-render-buffer " *GTS-Pop-Posframe*"
- "Buffer name of Pop Posframe."
- :type 'string
- :group 'go-translate)
-
-(defvar gts-posframe-pop-render-timeout 30)
-(defvar gts-posframe-pop-render-poshandler nil)
-
-(defun gts-posframe-init-header-line (from to)
- (setq header-line-format
- (list "[" (propertize from 'face 'gts-render-buffer-header-line-lang-face) "]"
- " → "
- "[" (propertize to 'face 'gts-render-buffer-header-line-lang-face) "]")))
-
-(defun gts-posframe-render-auto-close-handler ()
- "Close the pop-up posframe window."
- (interactive)
- (unless (or (and gts-current-command
- (member this-command (list gts-current-command #'exit-minibuffer)))
- (and gts-posframe-pop-render-buffer
- (string= (buffer-name) gts-posframe-pop-render-buffer)))
- (ignore-errors (posframe-delete gts-posframe-pop-render-buffer))
- (remove-hook 'post-command-hook #'gts-posframe-render-auto-close-handler)))
-
-(cl-defmethod gts-pre ((render gts-posframe-pop-render) translator)
- (with-slots (width height forecolor backcolor padding) render
- (let ((inhibit-read-only t)
- (buf gts-posframe-pop-render-buffer))
- (posframe-show buf
- :string "Loading..."
- :timeout gts-posframe-pop-render-timeout
- :max-width width
- :max-height height
- :foreground-color (or forecolor gts-pop-posframe-forecolor)
- :background-color (or backcolor gts-pop-posframe-backcolor)
- :internal-border-width padding
- :internal-border-color (or backcolor gts-pop-posframe-backcolor)
- :accept-focus t
- :position (point)
- :poshandler gts-posframe-pop-render-poshandler)
- ;; render
- (gts-render-buffer-prepare buf translator)
- (posframe-refresh buf)
- ;; setup
- (with-current-buffer buf
- (gts-buffer-set-key ("q" "Close") (posframe-delete buf))))))
-
-(cl-defmethod gts-out ((_ gts-posframe-pop-render) task)
- ;; render & refresh
- (when-let ((buf (gts-render-buffer gts-posframe-pop-render-buffer task)))
- (posframe-refresh buf)
- (add-hook 'post-command-hook #'gts-posframe-render-auto-close-handler)))
-
-(cl-defmethod initialize-instance :after ((_ gts-posframe-pop-render) &rest _)
- (unless (featurep 'posframe)
- (user-error "To use `gts-posframe-render', you should install and load package `posframe' first")))
-
-\f
-;;; [Render] Child-Frame Render (Pin Mode)
-
-(defclass gts-posframe-pin-render (gts-posframe-pop-render)
- ((width :initarg :width :initform 60)
- (height :initarg :height :initform 20)
- (padding :initarg :padding :initform 8)
- (bd-width :initarg :bd-width :initform 1)
- (bd-color :initarg :bd-color :initform nil)
- (backcolor :initarg :backcolor :initform nil)
- (fri-color :initarg :fringe-color :initform nil)
- (position :initarg :position :initform nil))
- "Pin the childframe in a fixed position to display the translate result.
-The childframe will not close, until you kill it with `q'.
-Other operations in the childframe buffer, just like in 'gts-buffer-render'.")
-
-(defcustom gts-posframe-pin-render-buffer " *GTS-Pin-Posframe*"
- "Buffer name of Pin Posframe."
- :type 'string
- :group 'go-translate)
-
-(defvar gts-posframe-pin-render-frame nil)
-(defvar gts-posframe-pin-render-poshandler #'posframe-poshandler-frame-top-right-corner)
-
-(cl-defmethod gts-pre ((render gts-posframe-pin-render) translator)
- ;; create/show frame
- (if (and (get-buffer gts-posframe-pin-render-buffer) gts-posframe-pin-render-frame)
- (make-frame-visible gts-posframe-pin-render-frame)
- (with-slots (width height min-width min-height bd-width forecolor backcolor bd-color padding position) render
- (setq gts-posframe-pin-render-frame
- (let ((inhibit-read-only t))
- (posframe-show gts-posframe-pin-render-buffer
- :string "\nLoading..."
- :width width
- :height height
- :min-width width
- :min-height height
- :foreground-color (or forecolor gts-pin-posframe-forecolor)
- :background-color (or backcolor gts-pin-posframe-backcolor)
- :internal-border-width bd-width
- :border-color (or bd-color gts-pin-posframe-bdcolor)
- :left-fringe padding
- :right-fringe padding
- :refresh nil
- :accept-focus t
- :respect-header-line t
- :position position
- :poshandler (unless position gts-posframe-pin-render-poshandler)))))
- (set-frame-parameter gts-posframe-pin-render-frame 'drag-internal-border t)
- (set-frame-parameter gts-posframe-pin-render-frame 'drag-with-header-line t)
- (when-let ((color (or (oref render fri-color) gts-pin-posframe-fringe-color)))
- (set-face-background 'fringe color gts-posframe-pin-render-frame)))
- ;; render
- (gts-render-buffer-prepare gts-posframe-pin-render-buffer translator)
- (gts-buffer-ensure-a-blank-line-at-beginning gts-posframe-pin-render-buffer)
- ;; setup
- (with-current-buffer gts-posframe-pin-render-buffer
- (gts-buffer-set-key ("q" "Hide") (posframe-hide gts-posframe-pin-render-buffer))
- (gts-buffer-set-key ("Q" "Close") (posframe-delete gts-posframe-pin-render-buffer))))
-
-(cl-defmethod gts-out ((_ gts-posframe-pin-render) task)
- ;; render & refresh
- (when-let ((buf (gts-render-buffer gts-posframe-pin-render-buffer task)))
- (gts-buffer-ensure-a-blank-line-at-beginning buf)))
-
-(cl-defmethod gts-me-out ((_ gts-posframe-pin-render) task)
- ;; render & refresh
- (gts-render-buffer-multi-engines gts-posframe-pin-render-buffer task))
-
-\f
-;;; [Render] kill-ring render
-
-(defclass gts-kill-ring-render (gts-render) ())
-
-(cl-defmethod gts-out ((_ gts-kill-ring-render) task)
- (deactivate-mark)
- (with-slots (err parsed) task
- (if err
- (user-error "%s" err)
- (kill-new (if (listp parsed) (string-join parsed "\n\n") parsed))
- (message "Translate result already in the kill ring."))))
-
-\f
-;;; [Texter] take current-at-point-or-selection as source text
-
-(defclass gts-current-or-selection-texter (gts-texter) ())
-
-(cl-defmethod gts-text ((_ gts-current-or-selection-texter))
- (cond ((eq major-mode 'pdf-view-mode)
- (if (pdf-view-active-region-p)
- (car (pdf-view-active-region-text))))
- ((use-region-p)
- (string-trim (buffer-substring-no-properties (region-beginning) (region-end))))
- (t (current-word t t))))
-
-;; silence!
-(declare-function pdf-view-active-region-p "ext:pdf-view.el" t t)
-(declare-function pdf-view-active-region-text "ext:pdf-view.el" t t)
-
-\f
-;;; [Texter] take whole-buffer for as source text
-
-(defclass gts-whole-buffer-texter (gts-texter) ())
-
-(cl-defmethod gts-text ((_ gts-whole-buffer-texter))
- (buffer-substring-no-properties (point-min) (point-max)))
-
-\f
-;;; [Picker] noprompt picker
-
-(defclass gts-noprompt-picker (gts-picker)
- ((texter :initarg :texter :initform (gts-current-or-selection-texter))))
-
-(defvar gts-picker-current-picker nil)
-(defvar gts-picker-current-text nil)
-(defvar gts-picker-current-path nil)
-
-(cl-defmethod gts-pick ((picker gts-noprompt-picker))
- (let ((text (gts-text (oref picker texter))))
- (when (= 0 (length (if text (string-trim text) "")))
- (user-error "Make sure there is any word at point, or selection exists"))
- (let ((path (gts-path picker text)))
- (setq gts-picker-current-path path)
- (cl-values text path))))
-
-\f
-;;; [Picker] prompt, and flexible
-
-(defclass gts-prompt-picker (gts-picker)
- ((texter :initarg :texter :initform (gts-current-or-selection-texter))))
-
-(defvar gts-prompt-for-translate-keymap
- (let ((map (make-sparse-keymap)))
- (set-keymap-parent map minibuffer-local-map)
- (define-key map "\C-g" #'top-level)
- (define-key map "\C-n" #'gts-prompt-picker-next-path)
- (define-key map "\C-p" (lambda () (interactive) (gts-prompt-picker-next-path t)))
- (define-key map "\C-l" #'delete-minibuffer-contents)
- (define-key map [C-return] (lambda () (interactive) (exit-minibuffer)))
- map)
- "Minibuffer keymap used when prompt user input.")
-
-(defun gts-prompt-picker-next-path (&optional backwardp)
- "Pick next available translate path.
-If BACKWARDP is t, then pick the previous one."
- (interactive "P")
- (let ((p (gts-next-path gts-picker-current-picker
- gts-picker-current-text
- gts-picker-current-path
- backwardp)))
- (setq gts-picker-current-path p)
- (gts-picker-prompt-pick (minibuffer-contents) p)
- (exit-minibuffer)))
-
-(defun gts-picker-prompt-pick (&optional text path)
- (setq gts-picker-current-path path)
- (let* ((enable-recursive-minibuffers t)
- (minibuffer-allow-text-properties t)
- (prompt (concat (concat "[" (car path) " > " (cdr path) "] ") "Text: "))
- (text (read-from-minibuffer prompt text gts-prompt-for-translate-keymap)))
- (setq gts-picker-current-text text)
- (when (zerop (length (string-trim text)))
- (user-error "Text should not be null"))
- (with-minibuffer-selected-window
- (exit-minibuffer))))
-
-(cl-defmethod gts-pick ((picker gts-prompt-picker))
- (setq gts-picker-current-picker picker)
- (let* ((text (gts-text (oref picker texter)))
- (path (gts-path picker text)))
- (gts-picker-prompt-pick text path)
- (cl-values gts-picker-current-text gts-picker-current-path)))
-
-\f
-;;; [Splitter] split text by paragraph
-
-(defclass gts-paragraph-splitter (gts-splitter) ())
-
-(cl-defmethod gts-split ((_ gts-paragraph-splitter) text)
- (setq text (split-string text "\n\n" t))
- (if (and (listp text) (cadr text)) text))
-
-
-(provide 'gts-implements)
-
-;;; gts-implements.el ends here
+++ /dev/null
-;;; go-translate-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
-;;
-;;; Code:
-
-(add-to-list 'load-path (directory-file-name
- (or (file-name-directory #$) (car load-path))))
-
-\f
-;;;### (autoloads nil "go-translate" "go-translate.el" (0 0 0 0))
-;;; Generated autoloads from go-translate.el
-
-(autoload 'gts-do-translate "go-translate" "\
-Do the translate" t nil)
-
-(register-definition-prefixes "go-translate" '("gts-default-translator"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-core" "gts-core.el" (0 0 0 0))
-;;; Generated autoloads from gts-core.el
-
-(register-definition-prefixes "gts-core" '("gts-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-bing" "gts-engine-bing.el" (0 0
-;;;;;; 0 0))
-;;; Generated autoloads from gts-engine-bing.el
-
-(register-definition-prefixes "gts-engine-bing" '("gts-bing-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-deepl" "gts-engine-deepl.el" (0
-;;;;;; 0 0 0))
-;;; Generated autoloads from gts-engine-deepl.el
-
-(register-definition-prefixes "gts-engine-deepl" '("gts-deepl-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-google" "gts-engine-google.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from gts-engine-google.el
-
-(register-definition-prefixes "gts-engine-google" '("gts-google-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-google-rpc" "gts-engine-google-rpc.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from gts-engine-google-rpc.el
-
-(register-definition-prefixes "gts-engine-google-rpc" '("gts-google-rpc-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-stardict" "gts-engine-stardict.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from gts-engine-stardict.el
-
-(register-definition-prefixes "gts-engine-stardict" '("gts-stardict-"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-engine-youdao" "gts-engine-youdao.el"
-;;;;;; (0 0 0 0))
-;;; Generated autoloads from gts-engine-youdao.el
-
-(register-definition-prefixes "gts-engine-youdao" '("gts-youdao-dict-e"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-faces" "gts-faces.el" (0 0 0 0))
-;;; Generated autoloads from gts-faces.el
-
-(register-definition-prefixes "gts-faces" '("gts-p"))
-
-;;;***
-\f
-;;;### (autoloads nil "gts-implements" "gts-implements.el" (0 0 0
-;;;;;; 0))
-;;; Generated autoloads from gts-implements.el
-
-(register-definition-prefixes "gts-implements" '("gts-"))
-
-;;;***
-\f
-;;;### (autoloads nil nil ("go-translate-pkg.el") (0 0 0 0))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; coding: utf-8
-;; End:
-;;; go-translate-autoloads.el ends here
+++ /dev/null
-(define-package "go-translate" "20230503.303" "Translation framework supports multiple engines such as Google/Bing/DeepL"
- '((emacs "27.1"))
- :commit "59506f69503cca65291fa5ccd0a326e716338c23" :authors
- '(("lorniu" . "lorniuNOSPAMgmail.com"))
- :maintainers
- '(("lorniu" . "lorniuNOSPAMgmail.com"))
- :maintainer
- '("lorniu" . "lorniuNOSPAMgmail.com")
- :keywords
- '("convenience")
- :url "https://github.com/lorniu/go-translate")
-;; Local Variables:
-;; no-byte-compile: t
-;; End:
+++ /dev/null
-;;; go-translate.el --- Translation framework supports multiple engines such as Google/Bing/DeepL -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-
-;; Author: lorniu <lorniuNOSPAMgmail.com>
-;; URL: https://github.com/lorniu/go-translate
-;; Package-Requires: ((emacs "27.1"))
-;; Keywords: convenience
-;; SPDX-License-Identifier: MIT
-;; Version: 2.0
-
-;;; Commentary:
-
-;; To be the most powerful translator on Emacs. Supports multiple translation engines such as Google, Bing, deepL.
-
-;; First, Install it via MELPA or download from github. Make sure this is on your `load-path'.
-
-;; Then, add following lines to your `.emacs':
-
-;; (require 'go-translate)
-;; (setq gts-translate-list '(("en" "zh")))
-;; (setq gts-default-translator
-;; (gts-translator
-;; :picker (gts-prompt-picker)
-;; :engines (list (gts-google-engine) (gts-google-rpc-engine))
-;; :render (gts-buffer-render)))
-
-;; And start your translate with command `gts-do-translate'.
-
-;;; Code:
-
-(require 'gts-core)
-(require 'gts-implements)
-(require 'gts-engine-bing)
-(require 'gts-engine-google)
-(require 'gts-engine-google-rpc)
-(require 'gts-engine-deepl)
-(require 'gts-engine-stardict)
-(require 'gts-engine-youdao)
-
-\f
-;;; Commands
-
-(defvar gts-default-translator
- (gts-translator :picker
- (gts-prompt-picker)
- ;;(gts-noprompt-picker)
- ;;(gts-noprompt-picker :texter (gts-whole-buffer-texter))
-
- :engines
- (list
- (gts-bing-engine)
- (gts-google-engine :parser (gts-google-summary-parser))
- (gts-google-rpc-engine)
-
- ;;(gts-google-engine)
- ;;(gts-google-rpc-engine)
- ;;(gts-deepl-engine :auth-key "2e20bade-88e9-02f3-169f-ab3c445d7984:fx" :pro nil)
-
- ;;(gts-google-engine :parser (gts-google-summary-parser))
- ;;(gts-google-engine :parser (gts-google-parser))
- ;;(gts-google-rpc-engine :parser (gts-google-rpc-summary-parser))
- )
-
- :render
- (gts-buffer-render)
-
- ;;(gts-posframe-pop-render)
- ;;(gts-posframe-pop-render :backcolor "#333333" :forecolor "#ffffff")
-
- ;;(gts-posframe-pin-render)
- ;;(gts-posframe-pin-render :position (cons 1200 20))
- ;;(gts-posframe-pin-render :width 80 :height 25 :position (cons 1000 20) :forecolor "#ffffff" :backcolor "#111111")
-
- ;;(gts-kill-ring-render)
-
- :splitter nil
- ;; (gts-paragraph-splitter)
- ))
-
-;;;###autoload
-(defun gts-do-translate ()
- "Do the translate"
- (interactive)
- (gts-translate gts-default-translator))
-
-
-(provide 'go-translate)
-
-;;; go-translate.el ends here
+++ /dev/null
-;;; gts-core.el --- Translate engines and utils -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; The core components and utils of the translator
-
-;;; Code:
-
-(require 'cl-lib)
-(require 'subr-x)
-(require 'eieio)
-
-(defgroup go-translate nil
- "Translate Framework for Emacs, asynchronous and flexible."
- :group 'external
- :prefix 'gts-)
-
-(defvar gts-debug-p nil)
-
-\f
-;;; Utils
-
-(defun gts-aref-for (vector &rest ns)
- "Recursively find the element in VECTOR. NS is indexes, as the path."
- (while ns
- (setq vector (aref vector (pop ns))))
- vector)
-
-(defun gts-format-params (data)
- "Format alist DATA to k=v style string."
- (cond ((null data) nil)
- ((stringp data) data)
- (t (mapconcat (lambda (arg)
- (format "%s=%s"
- (url-hexify-string (format "%s" (car arg)))
- (url-hexify-string (format "%s" (cdr arg)))))
- data "&"))))
-
-(defun gts-ensure-list (object)
- "Return OBJECT as a list."
- (if (listp object) object (list object)))
-
-(defun gts-ensure-plain (o)
- "Return O or the result of its execution."
- (if (functionp o) (funcall o) o))
-
-\f
-;;; Components
-
-;; logger/http-client/cacher
-
-(defclass gts-logger () ()
- "Used to log the messages."
- :abstract t)
-
-(defclass gts-http-client () ()
- "Used to send a request."
- :abstract t)
-
-(defclass gts-cacher ()
- ((caches :initform nil)) ; (key . (str . timestamp))
- "Used to cache the translate results."
- :abstract t)
-
-;; translator/task
-
-(defclass gts-translator ()
- ((picker :initarg :picker :documentation "`gts-picker' object or a function return it" :initform nil)
- (engines :initarg :engines :documentation "a list of `gts-engine' objects or a function return them" :initform nil)
- (render :initarg :render :documentation "`gts-render' object or a function return it" :initform nil)
- (splitter :initarg :splitter :documentation "`gts-splitter' object or a function return it" :initform nil)
-
- (text :initarg :text :documentation "Text to be translated")
- (sptext :initarg :sptext :documentation "List of strings splitted according `gts-splitter'")
- (path :initarg :path :documentation "From/To language cons")
-
- (plan-cnt :initform 0 :documentation "count of tasks in a translation")
- (task-queue :initform nil :documentation "translation tasks.")
- (state :initform 0 :documentation "Inner state of the translator:
-0: new translator without any tasks,
-1: tasks add finished, but not running,
-2: prepare render finished, and begin to running,
-3: all tasks running finished,
-4: rendered done, all over.")
- (version :initform nil :documentation "Used to distinguish between different translations")))
-
-(defclass gts-task ()
- ((id :initform (gensym))
-
- (text :initarg :text :documentation "Text that sent to engines. It maybe contains delimiters")
- (from :initarg :from)
- (to :initarg :to)
-
- (raw :initform nil :documentation "raw result responsed by the http-client")
- (parsed :initform nil :initarg :parsed :documentation "result parsed by parser, string or list")
- (err :initform nil :initarg :err :documentation "error info")
- (meta :initform nil :initarg :meta :documentation "extra info passed from parser to render. tbeg/tend")
-
- (engine :initarg :engine :initform nil)
- (render :initarg :render :initform nil)
- (translator :initarg :translator :initform nil)))
-
-;; picker/texter
-
-(defclass gts-picker ()
- ((single :initarg :single :initform nil)
- (texter :initarg :texter))
- "Used to pick the translation source text and from/to lang."
- :abstract t)
-
-(defclass gts-texter () ()
- "Used to get the initial translation text.
-Current word under cursor? Selection region? Whole line? Whole buffer? Others?
-You can implements your rules.")
-
-;; splitter
-
-(defclass gts-splitter () ()
- "Used to split the translation text by pragraph or other rules."
- :abstract t)
-
-;; engine/parser
-
-(defclass gts-engine ()
- ((tag :initarg :tag :documentation "Used to display as name")
- (parser :initarg :parser :documentation "Used to parse the response result"))
- :abstract t)
-
-(defclass gts-parser ()
- ((tag :initarg :tag :initform nil)))
-
-;; render
-
-(defclass gts-render () ())
-
-;; generic methods
-
-(cl-defgeneric gts-translate (translator-or-engine &rest args)
- "Start a translation for TRANSLATOR-OR-ENGINE.
-ARGS should be text/path or task/callback.")
-
-;; silence byte-compiler
-(eieio-declare-slots task-queue text from to)
-
-\f
-;;; Logger
-
-(cl-defgeneric gts-log (logger tag message)
- "Used to record the messages.")
-
-(defvar gts-default-logger nil "The default logger.")
-
-(defmacro gts-do-log (tag &rest messages)
- (declare (indent 1))
- `(when gts-debug-p
- (if gts-default-logger
- (cl-loop with ms = nil
- for message in (list ,@messages)
- if message do (cl-loop for m in (split-string message "\n") do (push m ms))
- finally (cl-loop
- for m in (nreverse ms)
- do (gts-log gts-default-logger (format "%s" ,tag) m)))
- (error "Make sure `gts-default-logger' is available. eg:\n
- (setq gts-default-logger (gts-buffer-logger))\n\n\n"))))
-
-\f
-;;; Cacher
-
-(defcustom gts-cache-enable t
- "Enable the cacher if this is t."
- :type 'boolean
- :group 'go-translate)
-
-(defcustom gts-cache-expired-factor (* 30 60)
- "Cache alive time based on this.
-Make word live longer time than sentence."
- :type 'integer
- :group 'go-translate)
-
-(defvar gts-default-cacher nil "The default cacher.")
-
-(cl-defgeneric gts-cache-get (cacher task)
- "Get item for TASK from CACHER.")
-
-(cl-defgeneric gts-cache-set (cacher task result)
- "Add RESULT fro TASK to CACHER.")
-
-(cl-defmethod gts-cache-key ((_ gts-cacher) task)
- (with-slots (text from to engine) task
- (sha1 (format "%s-%s-%s-%s"
- text from to
- (eieio-object-class-name engine)))))
-
-(cl-defmethod gts-clear-expired ((cacher gts-cacher))
- (with-slots (caches expired) cacher
- (cl-delete-if (lambda (c) (> (time-to-seconds) (cddr c))) caches)))
-
-(cl-defmethod gts-clear-all ((cacher gts-cacher))
- (oset cacher caches nil))
-
-\f
-;;; Http Client
-
-(cl-defgeneric gts-request (http-client url &key done fail data headers)
- "Use HTTP-CLIENT to request a URL with DATA.
-When success execute CALLBACK, or execute ERRORBACK."
- (:method (&rest _) (user-error "Method `gts-request' is not implement")))
-
-(defvar gts-default-http-client nil
- "The default http client used to send a request.")
-
-(cl-defun gts-do-request (url &key done fail data headers)
- "Helper for `gts-request'.
-DONE is a callback based on the responsed result buffer.
-FAIL is the callback for any error occured in request or parse."
- (if (and gts-default-http-client
- (eieio-object-p gts-default-http-client)
- (object-of-class-p gts-default-http-client 'gts-http-client))
- (let ((tag (format "%s" (eieio-object-class-name gts-default-http-client)))
- (data (gts-format-params data)))
- (gts-do-log tag
- (format "Start! (%s)" url)
- (if headers (format " HEADER: %s" headers))
- (if data (format " DATA: %s" data)))
- (gts-request gts-default-http-client url
- :headers headers
- :data data
- :done (lambda ()
- (gts-do-log tag (format "DONE! (%s)" url))
- (condition-case err
- (funcall done)
- (error
- (gts-do-log tag (format "FAIL in callback! (%s) %s" url err))
- (funcall fail err))))
- :fail (lambda (status)
- (gts-do-log tag (format "FAIL! (%s) %s" url status))
- (funcall fail status))))
- (funcall fail "Make sure `gts-default-http-client' is available. eg:\n
- (setq gts-default-http-client (gts-url-http-client))\n\n\n")))
-
-\f
-;;; Picker/Texter
-
-(cl-defgeneric gts-pick (picker)
- "Get the source text and translate from/to path from PICKER.")
-
-(cl-defgeneric gts-path (picker text)
- "Use to get the translation path for TEXT from PICKER.")
-
-(cl-defgeneric gts-next-path (picker text path &optional backwardp)
- "Get the next available path.")
-
-(cl-defgeneric gts-text (texter)
- "Get the init translation source text via TEXTER.")
-
-(defvar gts-picker-last-path nil)
-
-(defcustom gts-translate-list nil
- "Setup your translate languages. Just like:
-
-Single:
-
- (setq gts-translate-list \\='((\"en\" \"zh\")))
-
-Or multiple:
-
- (setq gts-translate-list \\='((\"en\" \"zh\") (\"en\" \"fr\")))
-
-The picker will give the translate from/to pair according this."
- :type 'alist
- :group 'go-translate)
-
-(defcustom gts-picker-lang-match-alist
- (list
- (cons "zh" "\\cc")
- (cons "ja" (lambda (text) (string-match-p "\\cj" text)))
- (cons "ru" "\\cy"))
- "Setup language match rules.
-Used to pick the right language for current translate text.
-Key should be the language, value should be a regexp string or function.
-Picker choose path according this first. If non-match, choose other paths."
- :type 'alist
- :group 'go-translate)
-
-(defun gts-picker-filter-paths (paths text)
- "Filter PATHS according TEXT.
-The rules are provided by `gts-picker-lang-match-alist'."
- (when text
- (cl-loop with text = (with-temp-buffer ; clear punctuations
- (insert text)
- (goto-char (point-min))
- (while (re-search-forward "\\s.\\|\n" nil t) (replace-match ""))
- (buffer-string))
- for path in paths
- for matcher = (let ((p (cdr (cl-find-if ; get match rule
- (lambda (item) (string-match-p (format "^%s$" (car item)) (car path)))
- gts-picker-lang-match-alist))))
- (if (stringp p) (lambda (text) (string-match-p p text)) p))
- when (and matcher (funcall matcher text))
- collect path)))
-
-(cl-defmethod gts-paths ((picker gts-picker) &optional keep-order)
- "All paths can be picked by PICKER.
-When KEEP-ORDER is not nil then do not try to push last path to the first place."
- (when (or (null gts-translate-list) (not (consp (car gts-translate-list))))
- (user-error "Please make sure you set the avaiable `gts-translate-list'. eg:\n
- (setq gts-translate-list '((\"en\" \"zh\") (\"en\" \"ja\"))\n\n"))
- (let (paths)
- (cl-loop for (lang1 . lang2) in gts-translate-list
- do (let ((lang2 (if (consp lang2) (car lang2) lang2)))
- (cl-pushnew (cons lang1 lang2) paths :test #'equal)
- (unless (oref picker single) (cl-pushnew (cons lang2 lang1) paths :test #'equal))))
- (setq paths (nreverse paths))
- (if (and (not keep-order)
- gts-picker-last-path (member gts-picker-last-path paths))
- (cons gts-picker-last-path (remove gts-picker-last-path paths))
- paths)))
-
-(cl-defmethod gts-path ((picker gts-picker) text)
- "Default path for TEXT used by PICKER.
-Return the first path matching TEXT. If no path matches, return the non-nil
-`gts-picker-last-path', then the first available path."
- (if-let* ((paths (gts-paths picker))
- (matched (gts-picker-filter-paths paths text)))
- (car matched)
- (or (let ((langs (mapcar #'car gts-picker-lang-match-alist)))
- (cl-find-if (lambda (p) (not (member (car p) langs))) paths))
- (car paths))))
-
-(cl-defmethod gts-next-path ((picker gts-picker) text path &optional backwardp)
- (let (candidates idx (paths (gts-paths picker 'keep-order)))
- (cl-loop for path in (append (gts-picker-filter-paths paths text) paths)
- do (cl-pushnew path candidates :test 'equal))
- (setq candidates (reverse candidates))
- (setq idx (cl-position path candidates :test 'equal))
- (if backwardp
- (elt candidates (if (= 0 idx) (- (length candidates) 1) (- idx 1)))
- (elt candidates (if (= (+ 1 idx) (length candidates)) 0 (+ 1 idx))))))
-
-\f
-;;; Splitter
-
-(cl-defgeneric gts-split (gts-splitter text)
- "Split TEXT to several parts.
-Return list of string, or nil if split failed.")
-
-\f
-;;; Engine/Parser
-
-(cl-defmethod gts-translate ((engine gts-engine) _task _callback)
- "Translate and update TASK with parsed result using ENGINE.
-The CALLBACK should contain the render logic."
- (user-error "Method `gts-translate' of %s is not implement" (eieio-object-class-name engine)))
-
-(cl-defmethod gts-translate :around ((engine gts-engine) task callback)
- "Add cache and log support."
- (with-slots (id render translator) task
- (if-let ((render-name (eieio-object-class-name render))
- (engine-name (eieio-object-class-name engine))
- (cache (gts-cache-get gts-default-cacher task)))
- ;; try cache
- (let ((engines (gts-get translator 'engines)))
- (gts-update-raw task cache)
- (gts-parse (oref engine parser) task)
- (if (cdr engines) (gts-me-out render task)
- (gts-out render task))
- (gts-do-log 'render (format "%s: done with cache!" id)))
- ;; request from engine
- (gts-do-log 'engine (format "%s: starting %s..." id engine-name))
- (cl-call-next-method engine task
- (lambda ()
- (gts-do-log 'engine (format "%s: %s done!" id engine-name))
- (funcall callback)
- ;; refresh cache
- (with-slots (err raw parsed) task
- (unless err
- (gts-cache-set gts-default-cacher task raw))))))))
-
-(cl-defgeneric gts-with-token (engine done fail)
- (:documentation "Get token for ENGINE, if success then DONE is called.")
- (declare (indent 1)))
-
-(cl-defgeneric gts-tts (engine text lang)
- "TTS, speak TEXT with LANG."
- (:method ((e gts-engine) &rest _)
- (user-error "No TTS service found on engine `%s'" (oref e tag))))
-
-(cl-defgeneric gts-parse (parser task)
- (:documentation "Parse the raw result and update the parsed result into TASK.")
- (:method ((_o gts-parser) task)
- ;; do nothing
- (gts-update-parsed task (oref task raw))))
-
-\f
-;;; Render
-
-(cl-defgeneric gts-pre (render translator)
- (:documentation "Pre-render before request success.
-Do some preparation for the gts-out.")
- (:method :after ((render gts-render) _)
- (gts-do-log 'render (format "prepare render with %s finished" (eieio-object-class-name render))))
- (:method ((_o gts-render) (_t gts-translator)) ()))
-
-(cl-defgeneric gts-out (render task)
- (:documentation "Render the TASK, default output to *Messages*.")
- (:method :after ((render gts-render) task)
- (gts-do-log 'render (format "%s: %s finished" (oref task id) (eieio-object-class-name render))))
- (:method ((_ gts-render) task)
- (with-slots (err parsed) task
- (when (and (not err) (listp parsed))
- (setq parsed (string-join parsed "\n\f\n")))
- (setq parsed (string-trim (format "%s" (or err parsed))))
- (setq parsed (propertize parsed 'face 'font-lock-keyword-face))
- (message "-+-G-+-T-+-S-+-")
- (message parsed ))))
-
-(cl-defgeneric gts-me-pre (render translator)
- (:documentation "Pre-render for TRANSLATOR.
-It used only when multiple engines exists.
-Default dispatch to gts-pre when first pre-render.")
- (:method :after ((render gts-render) _)
- (gts-do-log 'render (format "me prepare render with %s finished" (eieio-object-class-name render))))
- (:method ((render gts-render) translator)
- (with-slots (task-queue state) translator
- (when (= state 1)
- (gts-pre render translator)
- (setf state 2)))))
-
-(cl-defgeneric gts-me-out (render task)
- (:documentation "Render TASK with RENDER.
-It used only when multiple engines exists.
-Default dispatch to gts-out with all results concated.")
- (:method :after ((render gts-render) task)
- (gts-do-log 'render (format "%s: %s finished" (oref task id) (eieio-object-class-name render))))
- (:method ((render gts-render) task)
- (let ((translator (oref task translator)) results)
- ;; show only when all tasks finished.
- (when (= (oref translator state) 3)
- (dolist (task (oref translator task-queue))
- (with-slots (err parsed engine) task
- (when (and (not err) (listp parsed))
- (setq parsed (string-join parsed "\f")))
- (push (cons (format "[%s]" (oref engine tag)) (or err parsed)) results)))
- (setq results (nreverse results))
- (let* ((newlinep (cl-find-if (lambda (r) (string-match-p "\n" (cdr r))) results))
- (concated (mapconcat (lambda (r)
- (if newlinep
- (concat (propertize (concat (car r) "\n") 'face 'gts-pop-posframe-me-header-2-face)
- (format "\n%s" (cdr r)))
- (concat (propertize (format "%-7s" (car r)) 'face 'gts-pop-posframe-me-header-face)
- (format " %s" (cdr r)))))
- results
- (if newlinep "\n\n" "\n"))))
- (oset translator state 4)
- (gts-out render (gts-task :parsed concated :translator translator)))))))
-
-\f
-;;; TTS
-
-(defcustom gts-tts-speaker (or (executable-find "mpv")
- (executable-find "mplayer"))
- "The program to use to speak the translation.
-
-On Windows, if it is not found, will fallback to use `powershell`
-to do the job. Although it is not perfect, it seems to work."
- :type 'string
- :group 'go-translate)
-
-(defcustom gts-tts-try-speak-locally t
- "If t then will fallback to locally TTS service when engine's TTS failed.
-For example, it will use powershell on Windows to speak the word
-when this is set to t."
- :type 'boolean
- :group 'go-translate)
-
-(defvar gts-tts-playing-process nil)
-
-(defun gts-tts-speak-buffer-data ()
- "Speak the current buffer's data."
- (gts-tts-try-interrupt-playing-process)
- (let ((proc (make-process :name (format "gts-tts-process-%s" (+ 1000 (random 1000)))
- :command (append (split-string gts-tts-speaker) (list "-"))
- :buffer nil
- :noquery t
- :connection-type 'pipe)))
- (setq gts-tts-playing-process proc)
- (process-send-region proc (point-min) (point-max))
- (if (process-live-p proc) (process-send-eof proc))))
-
-(defun gts-tts-try-interrupt-playing-process ()
- (when (and gts-tts-playing-process (process-live-p gts-tts-playing-process))
- (ignore-errors (kill-process gts-tts-playing-process))
- (setq gts-tts-playing-process nil)))
-
-(defun gts-do-tts (text lang &optional engine)
- "Speak TEXT in LANG with possible tts service by ENGINE.
-If engine failed, then try locally TTS if `gts-tts-try-speak-locally' is set."
- (condition-case err
- (if engine
- (if gts-tts-speaker
- (gts-tts engine text lang)
- (user-error "No mpv/mplayer found"))
- (user-error "No engine TTS service provided"))
- (error (if gts-tts-try-speak-locally
- (cond ((executable-find "powershell")
- (let ((cmd (format "$w = New-Object -ComObject SAPI.SpVoice; $w.speak(\\\"%s\\\")" text)))
- (shell-command (format "powershell -Command \"& {%s}\""
- (encode-coding-string
- (replace-regexp-in-string "\n" " " cmd)
- (keyboard-coding-system))))))
- (t (message "[TTS] %s" (cadr err))))))))
-
-\f
-;;; Translator
-
-(defvar gts-text-delimiter "34587612321123")
-
-(defvar gts-current-command nil "The command invoked by `gts-translate'.")
-(defvar gts-current-picker nil "Picker used in current translate.")
-(defvar gts-current-engines nil "Engines used in current translate.")
-(defvar gts-current-render nil "Render used in current translate.")
-
-(cl-defmethod initialize-instance :after ((this gts-translator) &rest _)
- (unless (gts-ensure-plain (oref this render))
- (oset this render (gts-render)))
- (unless (gts-ensure-plain (oref this picker))
- (oset this picker (gts-noprompt-picker))))
-
-(cl-defmethod gts-get ((this gts-translator) &rest slots)
- "Return the normalized value of SLOTS in THIS translator."
- (cl-loop for slot in slots
- for value =
- (cl-flet ((ensure (v) (or v (user-error "No %s found in current translator" slot))))
- (pcase slot
- ('splitter (gts-ensure-plain (slot-value this slot)))
- ('picker (ensure (gts-ensure-plain (or gts-current-picker (slot-value this slot)))))
- ('engines (ensure (gts-ensure-list (gts-ensure-plain (or gts-current-engines (slot-value this slot))))))
- ('render (ensure (gts-ensure-plain (or gts-current-render (slot-value this slot)))))
- (_ (slot-value this slot))))
- collect value into values
- finally (return (if (cadr slots) (apply #'cl-values values) (car values)))))
-
-(cl-defmethod gts-init ((this gts-translator) text path)
- "Init all status and tasks in THIS translator."
- ;; input
- (unless (and text path)
- (let ((input (gts-pick (gts-get this 'picker))))
- (setq text (cl-nth-value 0 input))
- (setq path (cl-nth-value 1 input))))
- (oset this text text)
- (oset this path path)
- (setq gts-picker-last-path path)
- (gts-do-log 'translator (format "\nBegin to translate %s" path))
- (gts-do-log 'text text)
- (cl-multiple-value-bind (splitter engines render) (gts-get this 'splitter 'engines 'render 'version)
- ;; reset
- (oset this state 0)
- (oset this task-queue nil)
- (oset this plan-cnt (length engines))
- (oset this version (time-to-seconds))
- ;; tasks
- (let ((splitted (if splitter (gts-split splitter text))))
- (oset this sptext splitted)
- (cl-loop for engine in engines
- for task = (gts-task :translator this
- :engine engine
- :render render
- :from (car path) :to (cdr path)
- :text (if splitted (string-join splitted (concat "\n" gts-text-delimiter "\n")) text))
- do (gts-add-task this task))
- (gts-do-log 'text (format "splitted? %s!" (if splitted "Yes" "No"))))))
-
-(cl-defmethod gts-add-task ((this gts-translator) task)
- "Add a new TASK to THIS translator."
- (with-slots (id engine render) task
- (with-slots (text path plan-cnt task-queue state) this
- (when (= state 0)
- (setf task-queue (append task-queue (list task)))
- (gts-do-log 'translator
- (format "- add task %s: (%s/%s)" id
- (eieio-object-class-name engine) (eieio-object-class-name render))))
- (when (and (= state 0) (= (length task-queue) plan-cnt))
- (setf state 1)))))
-
-(cl-defmethod gts-done-tasks ((this gts-translator))
- "Return the finished tasks in THIS translator."
- (with-slots (task-queue) this
- (cl-remove-if-not
- (lambda (task) (or (oref task err) (oref task raw))) task-queue)))
-
-(defun gts-update-raw (task resp &optional error)
- "Update non-parsed RESP result to TASK.
-If ERROR is not nil, then update task with failure."
- (declare (indent 1))
- (with-slots (id raw err translator) task
- (with-slots (task-queue plan-cnt state) translator
- (setf raw resp)
- (setf err error)
- (when (and (= state 2) (= plan-cnt (length (gts-done-tasks translator))))
- (setf state 3))
- (gts-do-log 'translator (format "%s: **responsed** %s" id (or error "success!"))))))
-
-(defun gts-update-parsed (task result &optional metadata filter)
- "Update TASK with parsed RESULT, update METADATA if exists.
-FILTER the parsed result if necessary, it's a function take parsed result
-as argument."
- (declare (indent 1))
- (with-slots (id raw parsed err meta translator) task
- (if raw
- (condition-case er
- (let ((r (if (or (listp result) (not (gts-get translator 'sptext)))
- result
- (gts-do-log 'translator
- (format "%s: result contains delimiter, so split to list" id))
- (split-string result gts-text-delimiter nil "[ \t\n\r]+"))))
- (setf parsed (if filter (funcall filter r) r))
- (if metadata (setf meta metadata)))
- (error (setf err er)))
- (gts-update-raw task t "Mybe Null Response"))))
-
-(defun gts-render-fail (task error)
- "Directly render the ERROR message and finish the TASK."
- (declare (indent 1))
- (gts-do-log 'translator (format "error? %s" error))
- (if task
- (with-slots (translator render) task
- (let ((engines (gts-get translator 'engines)))
- (gts-update-raw task nil error)
- (if (cdr engines)
- (gts-me-out render task)
- (gts-out render task))))
- (signal 'error error)))
-
-(cl-defmethod gts-translate ((this gts-translator) &optional text path)
- "Fire a translation for THIS translator instance.
-When TEXT and PATH is nil then pick them via `gts-pick'."
- ;; dynamic
- (setq gts-current-command this-command)
- (setq gts-current-picker (oref this picker))
- (setq gts-current-engines (oref this engines))
- (setq gts-current-render (oref this render))
- ;; initialize
- (gts-init this text path)
- (cl-multiple-value-bind (engines render tasks text path)
- (gts-get this 'engines 'render 'task-queue 'text 'path)
- (let ((buf (current-buffer)))
- ;; single engine
- (if (not (cdr engines))
- (let ((task (car tasks)))
- (gts-pre render this)
- (gts-translate (car engines) task
- (lambda ()
- (with-current-buffer buf
- (gts-out render task)))))
- ;; multiple engines
- (gts-me-pre render this)
- (dolist (task tasks)
- (condition-case er
- (gts-translate (oref task engine) task
- (lambda ()
- (with-current-buffer buf
- (gts-me-out render task))))
- (error
- (gts-render-fail task er))))
- (gts-me-out render (gts-task :text text :from (car path) :to (cdr path) :translator this))))))
-
-
-(provide 'gts-core)
-
-;;; gts-core.el ends here
+++ /dev/null
-;;; gts-engine-bing.el --- Microsoft Translate -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; https://bing.com/translator
-
-;;; Code:
-
-(require 'gts-implements)
-
-(defclass gts-bing-parser (gts-parser) ())
-
-(defclass gts-bing-engine (gts-engine)
- ((tag :initform "Bing")
- (base-url :initform "https://www.bing.com")
- (sub-url :initform "/ttranslatev3")
-
- (tld-url :initform nil)
- (ig :initform nil)
- (key :initform nil)
- (token :initform nil)
- (last-time :initform nil)
- (expired-time :initform (* 30 60))
-
- (ttsk-url :initform "/tfetspktok")
- (tts-url :initform "https://%s.tts.speech.microsoft.com/cognitiveservices/v1")
- (tts-tpl :initform "<speak version='1.0' xml:lang='%s'><voice xml:lang='%s' xml:gender='Female' name='%s'><prosody rate='-20.00%%'>%s</prosody></voice></speak>")
-
- (parser :initform (gts-bing-parser))))
-
-\f
-;;; Engine
-
-(defvar gts-bing-extra-langs-mapping '(("zh" . "zh-Hans")))
-
-(defvar gts-bing-token-maybe-invalid nil)
-
-(cl-defmethod gts-get-lang ((_ gts-bing-engine) lang)
- (or (cdr-safe (assoc lang gts-bing-extra-langs-mapping)) lang))
-
-(cl-defmethod gts-token-available-p ((engine gts-bing-engine))
- (with-slots (token key ig last-time expired-time) engine
- (and token key ig last-time
- (not gts-bing-token-maybe-invalid)
- (< (- (time-to-seconds) last-time) expired-time))))
-
-(cl-defmethod gts-with-token ((engine gts-bing-engine) done fail)
- (with-slots (token key ig base-url) engine
- (if (gts-token-available-p engine)
- (funcall done)
- (gts-do-request (concat base-url "/translator")
- :done
- (lambda ()
- (let (key token ig tld)
- (re-search-forward "curUrl=.*/\\([a-z]+\\.bing.com\\)")
- (setq tld (match-string 1))
- (re-search-forward "\"ig\":\"\\([^\"]+\\).*params_AbusePreventionHelper = \\[\\([0-9]+\\),\"\\([^\"]+\\)")
- (setq ig (match-string 1) key (match-string 2) token (match-string 3))
- (oset engine ig ig)
- (oset engine key key)
- (oset engine token token)
- (oset engine last-time (time-to-seconds))
- (oset engine tld-url (concat "https://" tld))
- (setq gts-bing-token-maybe-invalid nil)
- (gts-do-log 'bing (format "url: %s\nkey: %s\ntoken: %s\nig: %s" tld key token ig))
- (funcall done)))
- :fail fail))))
-
-(cl-defmethod gts-translate ((engine gts-bing-engine) task rendercb)
- (gts-with-token engine
- (lambda ()
- (with-slots (text from to raw) task
- (with-slots (tld-url sub-url token key ig parser) engine
- (gts-do-request (format "%s%s?isVertical=1&IG=%s&IID=translator.5022.1" tld-url sub-url ig)
- :headers `(("Content-Type" . "application/x-www-form-urlencoded;charset=UTF-8"))
- :data `(("fromLang" . ,(gts-get-lang engine from))
- ("to" . ,(gts-get-lang engine to))
- ("text" . ,text)
- ("key" . ,key)
- ("token" . ,token))
- :done (lambda ()
- (gts-update-raw task (buffer-string))
- (gts-parse parser task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task
- (cond ((ignore-errors (= (caddar err) 429))
- "[429] Too many requests! Please retry later")
- (t err))))))))
- (lambda (err)
- (gts-render-fail task
- (format "Error occurred when request for token.\n\n%s" err)))))
-
-\f
-;;; TTS
-
-(defvar gts-bing-tts-langs-mapping '(("zh" . ("zh-CN" . "zh-CN-XiaoxiaoNeural"))
- ("en" . ("en-US" . "en-US-AriaNeural"))
- ("fr" . ("fr-CA" . "fr-CA-SylvieNeural"))
- ("de" . ("de-DE" . "de-DE-KatjaNeural"))))
-
-(cl-defmethod gts-tts-payload ((engine gts-bing-engine) lang text)
- (with-slots (tts-tpl) engine
- (let (l n (mt (assoc lang gts-bing-tts-langs-mapping)))
- (if mt (setq l (cadr mt) n (cddr mt))
- (user-error "Add the mapping of your language into `gts-bing-tts-langs-mapping' :)"))
- (format tts-tpl l l n (encode-coding-string text 'utf-8)))))
-
-(cl-defmethod gts-tts ((engine gts-bing-engine) text lang)
- (gts-with-token engine
- (lambda ()
- (with-slots (tld-url sub-url token key ig parser ttsk-url tts-url tts-tpl) engine
- (gts-do-request (format "%s%s?isVertical=1&IG=%s&IID=translator.5022.2" tld-url ttsk-url ig)
- :headers '(("content-type" . "application/x-www-form-urlencoded"))
- :data `(("token" . ,token) ("key" . ,key))
- :done (lambda ()
- (let* ((json (json-read))
- (token (cdr (assoc 'token json)))
- (region (cdr (assoc 'region json))))
- (gts-do-log 'bing-tts (format "token: %s\nregion: %s" token region))
- (gts-do-request (format tts-url region)
- :data (gts-tts-payload engine lang text)
- :headers `(("content-type" . "application/ssml+xml")
- ("authorization" . ,(format "Bearer %s" token))
- ("x-microsoft-outputformat" . "audio-16khz-32kbitrate-mono-mp3"))
- :done (lambda ()
- (gts-tts-speak-buffer-data))
- :fail (lambda (_)
- (user-error "[BING-TTS] error when play sound")))))
- :fail (lambda (err) (user-error "%s" err)))))
- (lambda (_) (user-error "Failed to get token"))))
-
-\f
-;;; Parser
-
-(cl-defmethod gts-parse ((_ gts-bing-parser) task)
- (with-temp-buffer
- (set-buffer-multibyte t)
- (insert (oref task raw))
- (decode-coding-region (point-min) (point-max) 'utf-8)
- (gts-do-log 'bing (string-trim (buffer-string)))
- (goto-char (point-min))
- (if-let* ((json (json-read))
- (result (ignore-errors (cdr (assoc 'text (aref (cdr (assoc 'translations (aref json 0))) 0))))))
- (gts-update-parsed task result)
- (setq gts-bing-token-maybe-invalid t) ; refresh token when error occurred
- (gts-update-raw task nil (buffer-string)))))
-
-
-(provide 'gts-engine-bing)
-
-;;; gts-engine-bing.el ends here
+++ /dev/null
-;;; gts-engine-deepl.el --- Translate Engine for DeepL -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; https://www.deepl.com
-
-;;; Code:
-
-(require 'gts-implements)
-
-\f
-;;; Components
-
-(defclass gts-deepl-parser (gts-parser) ())
-
-(defclass gts-deepl-engine (gts-engine)
- ((tag :initform "DeepL")
- (pro :initform nil :initarg :pro :documentation "If your key is PRO version")
- (free-url :initform "https://api-free.deepl.com")
- (pro-url :initform "https://api.deepl.com")
- (sub-url :initform "/v2/translate")
- (auth-key :initform nil :initarg :auth-key)
- (parser :initform (gts-deepl-parser))))
-
-(cl-defmethod initialize-instance :after ((engine gts-deepl-engine) &rest _)
- (unless (oref engine auth-key)
- (user-error "You should provide a auth-key when instance gts-deepl-engine")))
-
-\f
-;;; Utils
-
-(defcustom gts-deepl-fill-enable t
- "Controller wheather try to improve the input and output.
-Default behavior is removing excess linebreaks in input for better
-translation effect, and filling the output for better reading experience.
-You can override the behaviors by :around the method `gts-deepl-fill-input'
-or `gts-deepl-fill-output'."
- :type 'boolean
- :group 'go-translate)
-
-(cl-defmethod gts-deepl-fill-input (text)
- "Improve the input TEXT for better translation effect.
-Mainly remove excess linebreaks. I want to skip unfill on comments and codes,
-but don't know how to implement easily. To make it better later, maybe."
- (if gts-deepl-fill-enable
- (with-temp-buffer
- (insert text)
- (let ((fill-column (* 2 (point-max))))
- (fill-region (point-min) (point-max)))
- (buffer-string))
- text))
-
-(cl-defmethod gts-deepl-fill-output (text)
- "Improve the output TEXT for better reading experience.
-Mainly fill the text to suitable length."
- (if gts-deepl-fill-enable
- (with-temp-buffer
- (insert text)
- (fill-region (point-min) (point-max))
- (buffer-string))
- text))
-
-\f
-;;; Engine
-
-(defvar gts-deepl-langs-mapping '(("en" . "EN")
- ("zh" . "ZH")
- ("de" . "DE") ; German
- ("fr" . "FR") ; French
- ("it" . "IT") ; Italian
- ("ja" . "JA") ; Japanese
- ("es" . "ES") ; Spanish
- ("nl" . "NL") ; Dutch
- ("pl" . "PL") ; Polish
- ("pt" . "PT") ; Portuguese (all Portuguese varieties mixed)
- ("ru" . "RU") ; Russian
- ))
-
-(cl-defmethod gts-get-lang ((_ gts-deepl-engine) lang)
- (let ((mapping (assoc lang gts-deepl-langs-mapping)))
- (if mapping (cdr mapping)
- (user-error
- "Language %s is not supported by DeepL.\nSupported list: %s"
- lang (mapconcat #'car gts-deepl-langs-mapping ", ")))))
-
-(cl-defmethod gts-gen-url ((engine gts-deepl-engine))
- (with-slots (free-url pro-url sub-url pro) engine
- (format "%s%s" (if pro pro-url free-url) sub-url)))
-
-(cl-defmethod gts-translate ((engine gts-deepl-engine) task rendercb)
- (with-slots (text from to) task
- (with-slots (auth-key parser) engine
- (gts-do-request (gts-gen-url engine)
- :headers `(("Content-Type" . "application/x-www-form-urlencoded;charset=UTF-8")
- ("Authorization" . ,(concat "DeepL-Auth-Key " auth-key)))
- :data `(("text" . ,(gts-deepl-fill-input text))
- ("source_lang" . ,(gts-get-lang engine from))
- ("target_lang" . ,(gts-get-lang engine to)))
- :done (lambda ()
- (gts-update-raw task (buffer-string))
- (gts-parse parser task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task
- (if (ignore-errors (= (caddar err) 403))
- "[403] http error, make sure your auth_key is correct"
- err)))))))
-
-\f
-;;; Parser
-
-(cl-defmethod gts-parse ((_ gts-deepl-parser) task)
- (let* ((json (json-read-from-string (oref task raw)))
- (str (mapconcat (lambda (r) (cdr (cadr r))) (cdar json) "\n"))
- (filter (lambda (parsed)
- (cl-loop for p in (gts-ensure-list parsed)
- collect (gts-deepl-fill-output p) into ps
- finally (return (if (cdr ps) ps (car ps)))))))
- (gts-update-parsed task (decode-coding-string str 'utf-8) nil filter)))
-
-
-(provide 'gts-engine-deepl)
-
-;;; gts-engine-deepl.el ends here
+++ /dev/null
-;;; gts-engine-google-rpc.el --- Google translation with rpc api -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; http://translate.google.com, new RPC API
-
-;;; Code:
-
-(require 'gts-engine-google)
-
-(defcustom gts-google-rpc-base-url "https://translate.google.com"
- "The base url of Google translate used by google-rpc engine.
-you can customize it according to your country region."
- :type 'string
- :group 'go-translate)
-
-\f
-;;; Components
-
-(defclass gts-google-rpc-parser (gts-google-parser)
- ((tag :initform "Detail")))
-
-(defclass gts-google-rpc-summary-parser (gts-google-summary-parser gts-google-rpc-parser)
- ((tag :initform "Summary")))
-
-(defclass gts-google-rpc-engine (gts-engine)
- ((tag :initform "Google/RPC")
- (sub-url :initform "/_/TranslateWebserverUi/data/batchexecute")
- (parser :initform (gts-google-rpc-parser))
-
- (rpc-translate :initform "MkEWBc")
- (rpc-tts :initform "jQ1olc")
- (rpc-sid :initform "FdrFJe")
- (rpc-bl :initform "cfb2h")))
-
-\f
-;;; Engine
-
-(defvar gts-google-rpc-request-headers '(("Content-Type" . "application/x-www-form-urlencoded;charset=UTF-8")))
-
-(cl-defmethod gts-with-token ((engine gts-google-rpc-engine) done fail)
- (with-slots (sub-url rpc-sid rpc-bl) engine
- (gts-do-request gts-google-rpc-base-url
- :done
- (lambda ()
- (let* ((f-sid (progn
- (re-search-forward (format "\"%s\":\"\\([^\"]*\\)\"" rpc-sid))
- (match-string 1)))
- (bl (progn (re-search-forward (format "\"%s\":\"\\([^\"]*\\)\"" rpc-bl))
- (match-string 1)))
- (url-tpl (lambda (rpcid lang)
- (format "%s%s?%s" gts-google-rpc-base-url sub-url
- (gts-format-params
- `(("rpcids" . ,rpcid)
- ("f.sid" . ,f-sid)
- ("bl" . ,bl)
- ("hl" . ,lang)
- ("soc-app" . 1)
- ("soc-platform" . 1)
- ("soc-device" . 1)
- ("_reqid" . ,(+ 1000 (random 9000)))
- ("rt" . "c")))))))
- (funcall done url-tpl)))
- :fail fail)))
-
-(cl-defmethod gts-translate ((engine gts-google-rpc-engine) task rendercb)
- (gts-with-token engine
- (lambda (url-tpl)
- (with-slots (text from to) task
- (with-slots (rpc-translate parser) engine
- (gts-do-request (funcall url-tpl rpc-translate to)
- :headers gts-google-rpc-request-headers
- :data (format
- "f.req=%s&"
- (url-hexify-string
- (let ((outer [[[rpcid inner nil "generic"]]])
- (inner [[text from to t][nil]]))
- (setf (aref (aref inner 0) 0) text)
- (setf (aref (aref inner 0) 1) from)
- (setf (aref (aref inner 0) 2) to)
- (setf (aref (aref (aref outer 0) 0) 0) rpc-translate)
- (setf (aref (aref (aref outer 0) 0) 1) (json-encode inner))
- (json-encode outer))))
- :done (lambda ()
- (gts-update-raw task (buffer-string))
- (gts-parse parser task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task err))))))
- (lambda (err)
- (gts-render-fail task
- (format "Error occurred when request for token.\n\n%s" err)))))
-
-(cl-defmethod gts-tts ((engine gts-google-rpc-engine) text lang)
- (gts-with-token engine
- (lambda (url-tpl)
- (with-slots (rpc-tts) engine
- (gts-do-request (funcall url-tpl rpc-tts "en-US")
- :headers gts-google-rpc-request-headers
- :data (format
- "f.req=%s&"
- (url-hexify-string
- (let ((outer [[[rpcid inner nil "generic"]]])
- (inner [text lang nil nil]))
- (setf (aref inner 0) text)
- (setf (aref inner 1) lang)
- (setf (aref (aref (aref outer 0) 0) 0) rpc-tts)
- (setf (aref (aref (aref outer 0) 0) 1) (json-encode inner))
- (json-encode outer))))
- :done (lambda ()
- (let (beg end json code)
- (re-search-forward "^[0-9]+$")
- (setq beg (point))
- (re-search-forward "^\\([0-9]+\\)$")
- (setq end (- (point) (length (match-string 1))))
- (setq json (json-read-from-string (string-trim (buffer-substring-no-properties beg end))))
- (when (string= (gts-aref-for json 0 0) "wrb.fr")
- (setq code (aref (json-read-from-string (gts-aref-for json 0 2)) 0))
- (erase-buffer)
- (insert code)
- (base64-decode-region (point-min) (point-max))
- (gts-tts-speak-buffer-data))))
- :fail (lambda (err) (user-error "Error when TTS. %s" err)))))
- (lambda (_) (user-error "Error occurred when request for token"))))
-
-\f
-;;; Parser
-
-(cl-defmethod gts-resp-to-json ((_ gts-google-rpc-parser) resp)
- "Convert the buffer RESP into JSON format."
- (condition-case err
- (with-temp-buffer
- (let (beg end str json)
- (insert resp)
- (goto-char (point-min))
- (re-search-forward "^[0-9]+$")
- (setq beg (point))
- (re-search-forward "^\\([0-9]+\\)$")
- (setq end (- (point) (length (match-string 1))))
- (setq str
- (decode-coding-string
- (string-trim (buffer-substring-no-properties beg end))
- 'utf-8))
- (setq json (json-read-from-string str))
- (if (string= (aref (aref json 0) 0) "wrb.fr")
- (let ((json-str (aref (aref json 0) 2)))
- (json-read-from-string json-str))
- (error "No results found"))))
- (error (user-error "Result conversion error (%s)" err))))
-
-(cl-defmethod gts-result--brief ((_ gts-google-rpc-parser) json)
- "Get the translation text from JSON."
- (mapconcat
- (lambda (item)
- (if (ignore-errors (aref item 2))
- (format " %s" (aref item 0))
- (aref item 0)))
- (gts-aref-for json 1 0 0 5)
- ""))
-
-(cl-defmethod gts-result--sphonetic ((_ gts-google-rpc-parser) json)
- "Get the text phonetic from JSON."
- (gts-aref-for json 0 0))
-
-(cl-defmethod gts-result--tphonetic ((_ gts-google-rpc-parser) json)
- "Get the translation phonetic from JSON."
- (gts-aref-for json 1 0 0 1))
-
-(cl-defmethod gts-result--details ((_ gts-google-rpc-parser) json)
- "Get the details from JSON.
-Result style: ((noun (a (x y z))) (verb (b (m n o))))."
- (cl-loop with dts = (ignore-errors (gts-aref-for json 3 5 0))
- for i across dts
- collect
- (cons
- (aref i 0)
- (cl-loop for j across (aref i 1)
- collect
- (cons
- (aref j 0)
- (cl-loop for k across (aref j 2) collect k))))))
-
-(cl-defmethod gts-result--definitions ((_ gts-google-rpc-parser) json)
- "Get the definitions from JSON.
-Result style: ((noun (a b)) (verb (c d)))."
- (cl-loop with defs = (ignore-errors (gts-aref-for json 3 1 0))
- for i across defs
- collect
- (cons
- (aref i 0)
- (cl-loop for j across (aref i 1)
- collect
- (cons (aref j 0)
- (ignore-errors (aref j 1)))))))
-
-(cl-defmethod gts-result--suggestion ((_ gts-google-rpc-parser) json)
- "Get the suggestion from JSON."
- (ignore-errors
- (replace-regexp-in-string "<b>\\|</b>\\|<i>\\|</i>" "" (gts-aref-for json 0 1 0 0 1))))
-
-
-(provide 'gts-engine-google-rpc)
-
-;;; gts-engine-google-rpc.el ends here
+++ /dev/null
-;;; gts-engine-google.el --- Google translate module -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; http://translate.google.com
-
-;;; Code:
-
-(require 'gts-implements)
-
-\f
-;;; Components
-
-(defclass gts-google-parser (gts-parser)
- ((tag :initform "Detail")))
-
-(defclass gts-google-summary-parser (gts-google-parser)
- ((tag :initform "Summary")))
-
-(defclass gts-google-engine (gts-engine)
- ((tag :initform "Google")
- (base-url :initform "http://translate.googleapis.com")
- (sub-url :initform "/translate_a/single")
- (token :initform (cons 430675 2721866130) :initarg token) ; hard code
- (token-time :initform t)
- (token-expired-time :initform (* 30 60))
- (parser :initform (gts-google-parser))))
-
-\f
-;;; Engine
-
-(defvar gts-google-request-headers '(("Connection" . "Keep-Alive")))
-
-(cl-defmethod gts-gen-url ((engine gts-google-engine) text from to)
- "Generate the url with TEXT, FROM and TO. Return a (url text from to) list."
- (format "%s%s?%s"
- (oref engine base-url)
- (oref engine sub-url)
- (mapconcat (lambda (p)
- (format "%s=%s" (url-hexify-string (car p)) (url-hexify-string (cdr p))))
- `(("client" . "gtx")
- ("ie" . "UTF-8")
- ("oe" . "UTF-8")
- ("dt" . "bd")
- ("dt" . "ex")
- ("dt" . "ld")
- ("dt" . "md")
- ("dt" . "qc")
- ("dt" . "rw")
- ("dt" . "rm")
- ("dt" . "ss")
- ("dt" . "t")
- ("dt" . "at")
- ("pc" . "1")
- ("otf" . "1")
- ("srcrom" . "1")
- ("ssel" . "0")
- ("tsel" . "0")
- ("hl" . ,to)
- ("sl" . ,from)
- ("tl" . ,to)
- ("q" . ,text)
- ("tk" . ,(gts-google-tkk (oref engine token) text)))
- "&")))
-
-(cl-defmethod gts-token-available-p ((engine gts-google-engine))
- (with-slots (token token-time token-expired-time) engine
- (and token
- (or (eq token-time t)
- (and token-time
- (<= (float-time (time-subtract (current-time) token-time))
- token-expired-time))))))
-
-(cl-defmethod gts-with-token ((engine gts-google-engine) done fail)
- (with-slots (token token-time base-url) engine
- (if (gts-token-available-p engine)
- (funcall done)
- (gts-do-request base-url
- :headers gts-google-request-headers
- :done (lambda ()
- (let ((tk (progn
- (re-search-forward ",tkk:'\\([0-9]+\\)\\.\\([0-9]+\\)")
- (cons (string-to-number (match-string 1))
- (string-to-number (match-string 2))))))
- (setf token tk)
- (setf token-time (current-time))
- (funcall done)))
- :fail fail))))
-
-(cl-defmethod gts-translate ((engine gts-google-engine) task rendercb)
- (gts-with-token engine
- (lambda ()
- (with-slots (text from to) task
- (gts-do-request (gts-gen-url engine text from to)
- :headers gts-google-request-headers
- :done (lambda ()
- (gts-update-raw task (buffer-string))
- (gts-parse (oref engine parser) task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task err)))))
- (lambda (err)
- (gts-render-fail task
- (format "Error when fetching Token-Key, check your network and proxy, or retry later\n\n%s" err)))))
-
-;; tts
-
-(cl-defmethod gts-tts-gen-urls ((engine gts-google-engine) text lang)
- "Generate the tts urls for TEXT to LANGUAGE."
- (cl-loop with texts = (gts-tts-text-splitter engine text)
- for total = (length texts)
- for index from 0
- for piece in texts
- collect
- (let ((params `(("ie" . "UTF-8")
- ("client" . "gtx")
- ("prev" . "input")
- ("q" . ,text)
- ("tl" . ,lang)
- ("total" . ,(number-to-string total))
- ("idx" . ,(number-to-string index))
- ("textlen" . ,(number-to-string (length piece)))
- ("tk" . ,(gts-google-tkk (oref engine token) piece)))))
- (format "%s/translate_tts?%s"
- (oref engine base-url)
- (mapconcat (lambda (p)
- (format "%s=%s"
- (url-hexify-string (car p))
- (url-hexify-string (cdr p))))
- params "&")))))
-
-(cl-defmethod gts-tts-text-splitter ((_ gts-google-engine) text)
- "Split TEXT by maxlen at applicable point for translating.
-Code from `google-translate', maybe improve it someday."
- (let (result (maxlen 200))
- (if (or (null maxlen) (<= maxlen 0))
- (push text result)
- ;; split long text?
- (with-temp-buffer
- (save-excursion (insert text))
- ;; strategy to split at applicable point
- ;; 1) fill-region remaining text by maxlen
- ;; 2) find end of sentence, end of punctuation, word boundary
- ;; 3) consume from remaining text between start and (2)
- ;; 4) repeat
- (let ((fill-column (* maxlen 3))
- (sentence-end-double-space nil)
- (pos (point-min)))
- (while (< pos (point-max))
- (save-restriction
- (narrow-to-region pos (point-max))
- (fill-region pos (point-max))
- (let ((limit (+ pos maxlen)))
- (if (>= limit (point-max))
- (setq limit (point-max))
- (goto-char limit)
- ;; try to split at end of sentence
- (if (> (backward-sentence) pos)
- (setq limit (point))
- ;; try to split at end of punctuation
- (goto-char limit)
- (if (re-search-backward "[,、]" pos t)
- (setq limit (1+ (point))) ; include punctuation
- (goto-char limit)
- ;; try to split at word boundary
- (forward-word-strictly -1)
- (when (> (point) pos)
- (setq limit (point))))))
- (push (buffer-substring-no-properties pos limit) result)
- (goto-char limit)
- (setq pos limit)))))))
- (reverse result)))
-
-(cl-defmethod gts-tts ((engine gts-google-engine) text lang)
- (let ((urls (gts-tts-gen-urls engine text lang))
- (speaker (split-string gts-tts-speaker)))
- (with-temp-message "Speaking..."
- (gts-tts-try-interrupt-playing-process)
- (apply #'call-process (car speaker) nil nil nil (append (cdr speaker) urls)))))
-
-\f
-;;; Parser
-
-;; detail-mode, use as default
-
-(cl-defmethod gts-parse ((parser gts-google-parser) task)
- (let* ((json (gts-resp-to-json parser (oref task raw)))
- (brief (gts-result--brief parser json))
- (sphonetic (gts-result--sphonetic parser json))
- (tphonetic (gts-result--tphonetic parser json))
- (details (gts-result--details parser json))
- (definitions (gts-result--definitions parser json))
- (suggestion (gts-result--suggestion parser json))
- (suggestionp (> (length suggestion) 0)) tbeg tend)
- (cl-flet ((phonetic (ph)
- (if (and (or definitions definitions) (> (length ph) 0))
- (propertize (format " [%s]" ph) 'face 'gts-google-buffer-phonetic-face)
- ""))
- (headline (line)
- (propertize (format "[%s]\n" line) 'face 'gts-google-buffer-headline-face)))
- (with-temp-buffer
- ;; suggestion
- (when suggestionp
- (insert (propertize "Do you mean:" 'face 'gts-google-buffer-suggestion-desc-face) " "
- (propertize suggestion 'face 'gts-google-buffer-suggestion-text-face) "?\n\n"))
- ;; phonetic & translate
- (if (or details definitions)
- (progn
- (insert (if suggestionp suggestion (oref (oref task translator) text)))
- (insert (phonetic sphonetic) " ")
- (setq tbeg (point))
- (insert (propertize brief 'face 'gts-google-buffer-brief-result-face))
- (setq tend (point))
- (insert (phonetic tphonetic) "\n\n"))
- (insert brief))
- ;; details
- (when details
- (insert (headline "Details"))
- (cl-loop for (label . items) in details
- unless (= 0 (length label))
- do (insert (format "\n%s:\n" label))
- do (cl-loop with index = 0
- for trans in items
- do (insert
- (format "%2d. " (cl-incf index))
- (car trans)
- " (" (mapconcat #'identity (cdr trans) ", ") ")"
- "\n")))
- (insert "\n"))
- ;; definitions
- (when definitions
- (insert (headline "Definitions"))
- (cl-loop for (label . items) in definitions
- unless (= 0 (length label))
- do (insert (format "\n%s:\n" label))
- do (cl-loop with index = 0
- for (exp . eg) in items
- do (insert (format "%2d. " (cl-incf index)) exp)
- when (> (length eg) 0)
- do (insert
- "\n > "
- (propertize (or eg "") 'face 'gts-google-buffer-detail-demo-face))
- do (insert "\n"))))
- ;; at last, fill and return
- (gts-update-parsed task (buffer-string) (list :tbeg tbeg :tend tend))))))
-
-;; summary-mode
-
-(cl-defmethod gts-parse ((parser gts-google-summary-parser) task)
- (let* ((json (gts-resp-to-json parser (oref task raw)))
- (result (string-trim (gts-result--brief parser json))))
- (gts-update-parsed task result (list :tbeg 1 :tend (+ 1 (length result))))))
-
-;; Extract results from response
-
-(cl-defmethod gts-resp-to-json ((_ gts-google-parser) resp)
- "Convert the buffer RESP into JSON."
- (condition-case err
- (json-read-from-string (decode-coding-string resp 'utf-8))
- (error (user-error "Result conversion error: %s" err))))
-
-(cl-defmethod gts-result--brief ((_ gts-google-parser) json)
- "Get the translation text from JSON."
- (mapconcat (lambda (item) (aref item 0)) (aref json 0) ""))
-
-(cl-defmethod gts-result--sphonetic ((_ gts-google-parser) json)
- "Get the text phonetic from JSON."
- (mapconcat (lambda (item) (if (> (length item) 3) (aref item 3) "")) (aref json 0) ""))
-
-(cl-defmethod gts-result--tphonetic ((_ gts-google-parser) json)
- "Get the translation phonetic from JSON."
- (mapconcat (lambda (item) (if (> (length item) 2) (aref item 2) "")) (aref json 0) ""))
-
-(cl-defmethod gts-result--details ((_ gts-google-parser) json)
- "Get the details from JSON.
-Result style: ((noun (a (x y z))) (verb (b (m n o))))."
- (cl-loop for i across (aref json 1)
- collect
- (cons
- (aref i 0)
- (cl-loop for j across (aref i 2)
- collect
- (cons
- (aref j 0)
- (cl-loop for k across (aref j 1) collect k))))))
-
-(cl-defmethod gts-result--definitions ((_ gts-google-parser) json)
- "Get the definitions from JSON.
-Result style: ((noun (a b)) (verb (c d)))."
- (cl-loop with defs = (ignore-errors (aref json 12))
- for i across defs
- collect
- (cons
- (aref i 0)
- (cl-loop for j across (aref i 1)
- collect
- (cons
- (aref j 0)
- (ignore-errors (aref j 2)))))))
-
-(cl-defmethod gts-result--suggestion ((_ gts-google-parser) json)
- "Get the suggestion from JSON."
- (let ((info (aref json 7))) (unless (seq-empty-p info) (aref info 1))))
-
-\f
-;;; Token Key algorithm (deprecated)
-
-;; This algorithm is from `google-translate' project.
-;; https://github.com/atykhonov/google-translate/blob/master/google-translate-tk.el
-
-(defvar gts-google-token--bit-v-len 32)
-
-(defun gts-google-token--bit-v-2comp (v)
- "Return the two's complement of V."
- (let* ((vc (vconcat v))
- (len (length vc)))
- ;; Complement of v
- (cl-loop for i from 0 below len do
- (aset vc i (logxor (aref vc i) 1)))
- ;; vc = complement of v + 1
- (cl-loop for i downfrom (1- len) to 0
- do (aset vc i (logxor (aref vc i) 1))
- when (> (aref vc i) 0) return nil)
- vc))
-
-(defun gts-google-token--number-to-bit-v (n)
- "Return a bit vector from N."
- (if (< n 0) (gts-google-token--bit-v-2comp
- (gts-google-token--number-to-bit-v (abs n)))
- (let ((v (make-vector gts-google-token--bit-v-len 0)))
- (cl-loop for i downfrom (1- gts-google-token--bit-v-len) to 0
- with q
- when (< n 1) return nil do
- (setq q (ffloor (* n 0.5)))
- (aset v i (floor (- n (* 2.0 q))))
- (setq n q))
- v)))
-
-(defun gts-google-token--bit-v-to-number (v)
- "Return a floating-point number from V."
- (if (and (> (aref v 0) 0)
- ;; Exclude [1 0 ... 0]
- (cl-loop for i from 1 below gts-google-token--bit-v-len
- thereis (> (aref v i) 0)))
- (- (gts-google-token--bit-v-to-number (gts-google-token--bit-v-2comp v)))
- (funcall (if (> (aref v 0) 0) #'- #'+)
- (cl-reduce (lambda (acc e) (+ (* acc 2.0) e))
- v :initial-value 0.0))))
-
-(defun gts-google-token--logfn (fn n1 n2)
- "Helper function for logical FN with N1 and N2."
- (let ((v1 (gts-google-token--number-to-bit-v n1))
- (v2 (gts-google-token--number-to-bit-v n2))
- (v (make-vector gts-google-token--bit-v-len 0)))
- (cl-loop for i from 0 below gts-google-token--bit-v-len do
- (aset v i (funcall fn (aref v1 i) (aref v2 i))))
- (gts-google-token--bit-v-to-number v)))
-
-(defun gts-google-token--logand (n1 n2)
- "Return a floating-point number from N1 and N2."
- (gts-google-token--logfn #'logand n1 n2))
-
-(defun gts-google-token--logxor (n1 n2)
- "Return a floating-point number from N1 and N2."
- (gts-google-token--logfn #'logxor n1 n2))
-
-(defun gts-google-token--lsh (n d)
- "Return a floating-point number.
-Shift the bits in N to the left or rihgt D places.
-D is an integer."
- (let ((v (gts-google-token--number-to-bit-v n))
- (v-result (make-vector gts-google-token--bit-v-len 0)))
- (if (< d 0)
- ;; Shift Right Logical
- (cl-loop for i from (abs d) below gts-google-token--bit-v-len
- for j from 0 do
- (aset v-result i (aref v j)))
- ;; Shift Left Logical
- (cl-loop for i from d below gts-google-token--bit-v-len
- for j from 0 do
- (aset v-result j (aref v i))))
- (gts-google-token--bit-v-to-number v-result)))
-
-(defun gts-google-token--gen-rl (a b)
- "Gen rl from A and B."
- (cl-loop for c from 0 below (- (length b) 2) by 3
- for d = (aref b (+ c 2)) do
- (setq d (if (>= d ?a) (- d 87) (- d ?0)))
- (setq d (if (= (aref b (1+ c)) ?+)
- (gts-google-token--lsh a (- d))
- (gts-google-token--lsh a d)))
- (setq a (if (= (aref b c) ?+)
- (gts-google-token--logand (+ a d) 4294967295.0)
- (gts-google-token--logxor a d))))
- a)
-
-(defun gts-google-tkk (token text)
- "Calculate the Token for search TEXT.
-
-It will use the tkk from Google translate page."
- (let* ((b (car token))
- (d1 (cdr token))
- (ub "+-3^+b+-f")
- (vb "+-a^+6")
- (a (cl-loop for c across (encode-coding-string text 'utf-8)
- for rr = (gts-google-token--gen-rl (+ (or rr b) c) vb)
- finally (return rr))))
- (setq a (gts-google-token--gen-rl a ub))
- (setq a (gts-google-token--logxor a d1))
- (if (< a 0) (setq a (+ (gts-google-token--logand a 2147483647.0) 2147483648.0)))
- (setq a (ffloor (mod a 1e6)))
- (format "%s.%s"
- (car (split-string (number-to-string a) "\\."))
- (car (split-string (number-to-string
- (gts-google-token--logxor a b))
- "\\.")))))
-
-
-(provide 'gts-engine-google)
-
-;;; gts-engine-google.el ends here
+++ /dev/null
-;;; gts-engine-stardict.el --- StarDict -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; Engine for sdcv (StarDict Console Version).
-;;
-;; sdcv is an offline translate software. It can be used when no network.
-;;
-;; Make sure sdcv is installed on your system:
-;;
-;; sudo pacman -S sdcv
-;;
-;; Then download dictionary data to ~/.stardict/dic or /usr/share/stardict/dic:
-;;
-;; # For example from http://download.huzheng.org:
-;;
-;; mkdir -p ~/.stardict/dic
-;; cd ~/.stardict/dic
-;; wget http://download.huzheng.org/zh_CN/stardict-langdao-ce-gb-2.4.2.tar.bz2
-;; wget http://download.huzheng.org/zh_CN/stardict-langdao-ce-gb-2.4.2.tar.bz2
-;; tar xvf stardict-langdao-ec-gb-2.4.2.tar.bz2
-;; tar xvf stardict-langdao-ce-gb-2.4.2.tar.bz2
-;; sdcv -l
-;;
-;; TODO: Provide more options and a better parser.
-
-;;; Code:
-
-(require 'gts-implements)
-
-(defclass gts-stardict-engine (gts-engine)
- ((tag :initform "StarDict")
- (parser :initform (gts-parser))))
-
-(defcustom gts-stardict-program "sdcv"
- "Executable command of sdcv (StarDict Console Version)."
- :type 'string
- :group 'go-translate)
-
-(defcustom gts-stardict-args '("-n" "-c" "-0" "-1")
- "Arguments passed to command `sdcv'."
- :type 'list
- :group 'go-translate)
-
-(cl-defmethod gts-translate ((engine gts-stardict-engine) task rendercb)
- (let* ((text (oref task text))
- (parser (oref engine parser))
- (result (with-temp-buffer
- (require 'ansi-color)
- (apply #'call-process gts-stardict-program nil t nil
- (append gts-stardict-args (list text))) ;--json-output
- (if (string-equal (buffer-substring 1 16) "Nothing similar")
- "No translation result found, sorry :("
- (ansi-color-apply (buffer-string))))))
- (gts-update-raw task result)
- (gts-parse parser task)
- (funcall rendercb)))
-
-(provide 'gts-engine-stardict)
-
-;;; gts-engine-stardict.el ends here
+++ /dev/null
-;;; gts-engine-youdao.el --- YouDao Dict -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; 有道词典 (dict.youdao.com), A chinese translation website.
-;;
-;; This engine is only for chinese user.
-;; > 此引擎仅供中文翻译使用
-;;
-;; Simply implement using EWW to do the parsing job for now. I am too lazy to parse and extract the html results.
-;; > 懒得去解析、组装 html，所以暂时直接借用 eww 的解析结果
-;; > 权作应急使用，*也许* 以后会增加更完善的 parser 方案
-
-;;; Code:
-
-(require 'gts-implements)
-
-(defclass gts-youdao-dict-eww-parser (gts-parser)
- ((tag :initform "EWW")))
-
-(defclass gts-youdao-dict-engine (gts-engine)
- ((tag :initform "有道词典")
- (url :initform "https://dict.youdao.com/result?word=%s&lang=%s")
- (parser :initform (gts-youdao-dict-eww-parser))))
-
-(cl-defmethod gts-translate ((engine gts-youdao-dict-engine) task rendercb)
- (with-slots (text from to meta) task
- (with-slots (url parser) engine
- (let* ((lang (cond ((string-equal from "zh") to)
- ((string-equal to "zh") from)
- (t (user-error "只支持中文跟其他语言之间的翻译"))))
- (url (format url (url-hexify-string text) (url-hexify-string lang))))
- (setf meta (list :url url))
- (gts-do-request url
- :done (lambda ()
- (gts-update-raw task (buffer-string)) ; html format response
- (gts-parse parser task)
- (funcall rendercb))
- :fail (lambda (err)
- (gts-render-fail task err)))))))
-
-(cl-defmethod gts-parse ((_ gts-youdao-dict-eww-parser) task)
- (with-slots (raw meta) task
- (with-temp-buffer
- (let ((buf (current-buffer)))
- (with-temp-buffer
- (require 'eww)
- (insert "Content-type: text/html; charset=utf-8\n\n" raw)
- (eww-render nil (plist-get meta :url) nil buf))
- (gts-update-parsed task (buffer-string) meta)))))
-
-
-(provide 'gts-engine-youdao)
-
-;;; gts-engine-youdao.el ends here
+++ /dev/null
-;;; gts-faces.el --- Face definitions -*- lexical-binding: t -*-
-
-;; Copyright (C) 2021 lorniu <lorniuNOSPAMgmail.com>
-;; SPDX-License-Identifier: MIT
-
-;;; Commentary:
-
-;; The faces and colors.
-
-;;; Code:
-
-(require 'gts-core)
-
-(defgroup go-translate-faces nil
- "The faces for this framework."
- :group 'go-translate)
-
-\f
-;;; Common
-
-(defface gts-logger-buffer-tag-face '((t :inherit font-lock-comment-face))
- "Used in the logger buffer tag keyword."
- :group 'go-translate-faces)
-
-(defface gts-logger-buffer-timestamp-face '((t :foreground "grey"))
- "Used in the logger buffer timestamp keyword."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-header-line-lang-face '((t :inherit font-lock-keyword-face))
- "Used in the buffer's header-line-format, from/to."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-header-line-desc-face '((t :inherit font-lock-variable-name-face))
- "Used in the buffer's header-line-format, description."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-error-face '((t :inherit font-lock-warning-face))
- "Used in the buffer's error text."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-source-face '((t :inherit font-lock-string-face))
- "Used in the buffer's source."
- :group 'go-translate-faces)
-
-(defface gts-render-buffer-me-header-backgroud-face '((t :background "slategray" :foreground "white" :extend t))
- "Used in the buffer's multiple engine separator."
- :group 'go-translate-faces)
-
-\f
-;;; Google Buffer Render
-
-(defface gts-google-buffer-headline-face '((t :inherit font-lock-function-name-face :weight bold))
- "Propertize the headline in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-phonetic-face '((t :inherit font-lock-string-face :slant normal))
- "Propertize the phonetic in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-suggestion-desc-face '((t :inherit font-lock-warning-face))
- "Propertize the suggestion description in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-suggestion-text-face '((t :slant italic :underline t))
- "Propertize the phonetic text in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-brief-result-face '((t :weight bold))
- "Propertize the brief result in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-source-face '((t :inherit font-lock-string-face))
- "Propertize the source in buffer rendering."
- :group 'go-translate-faces)
-
-(defface gts-google-buffer-detail-demo-face '((t :inherit font-lock-doc-face))
- "Propertize the detail demo in buffer rendering."
- :group 'go-translate-faces)
-
-\f
-;;; Posframe Render
-
-(defcustom gts-pop-posframe-forecolor "white"
- "Default foreground color of pop posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pop-posframe-backcolor "black"
- "Default background color of pop posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pin-posframe-forecolor nil
- "Default foreground color of pin posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pin-posframe-backcolor nil
- "Default background color of pin posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pin-posframe-bdcolor "#000000"
- "Default border color of pin posframe."
- :type 'string
- :group 'go-translate-faces)
-
-(defcustom gts-pin-posframe-fringe-color nil
- "Used in the posframe pip buffer fringe color."
- :type 'string
- :group 'go-translate-faces)
-
-(defface gts-pop-posframe-me-header-face '((t :foreground "grey"))
- "Used in the posframe pop buffer engine header."
- :group 'go-translate-faces)
-
-(defface gts-pop-posframe-me-header-2-face '((t (:foreground "#666666" :underline t :extend t)))
- "Used in the posframe pop buffer engine header."
- :group 'go-translate-faces)
-
-
-(provide 'gts-faces)
-
-;;; gts-faces.el ends here
--- /dev/null
+;;; go-translate-autoloads.el --- automatically extracted autoloads (do not edit) -*- lexical-binding: t -*-
+;; Generated by the `loaddefs-generate' function.
+
+;; This file is part of GNU Emacs.
+
+;;; Code:
+
+(add-to-list 'load-path (or (and load-file-name (directory-file-name (file-name-directory load-file-name))) (car load-path)))
+
+
+\f
+;;; Generated autoloads from go-translate.el
+
+(autoload 'gt-do-translate "go-translate" "\
+Translate using `gt-default-translator'.
+
+Define your default translator like this:
+
+ (setq gt-default-translator
+ (gt-translator :engines (gt-bing-engine)))
+
+ (setq gt-default-translator
+ (gt-translator :taker (gt-taker :langs '(en fr) :text 'sentence :prompt t)
+ :engines (list (gt-google-engine) (gt-deepl-engine))
+ :render (gt-buffer-render)))
+
+Or define several different translators and put them in `gt-preset-translators',
+and switch with `gt-do-setup' at any time.
+
+This is just a simple wrapper of `gt-start' method. Create other translate
+commands in the same way using your creativity.
+
+If ARG is not nil, translate with translator select by `gt-preset-translators'.
+
+(fn &optional ARG)" t)
+(register-definition-prefixes "go-translate" '("gt-"))
+
+\f
+;;; Generated autoloads from gt-core.el
+
+(autoload 'gt-do-speak "gt-core" "\
+Speak content around point.
+
+If the text under point or with selection has `gt-task' or `gt-tts-url'
+property, try to speak it with current translation engine.
+
+Otherwise try to TTS with local program or using selected engine.
+
+When TTS with specific engine, you can specify the language with `lang.' prefix." t)
+(register-definition-prefixes "gt-core" '("gt-"))
+
+\f
+;;; Generated autoloads from gt-engine-bing.el
+
+(register-definition-prefixes "gt-engine-bing" '("gt-bing-"))
+
+\f
+;;; Generated autoloads from gt-engine-chatgpt.el
+
+(register-definition-prefixes "gt-engine-chatgpt" '("gt-chatgpt-"))
+
+\f
+;;; Generated autoloads from gt-engine-deepl.el
+
+(register-definition-prefixes "gt-engine-deepl" '("gt-deepl-"))
+
+\f
+;;; Generated autoloads from gt-engine-echo.el
+
+(register-definition-prefixes "gt-engine-echo" '("gt-"))
+
+\f
+;;; Generated autoloads from gt-engine-google.el
+
+(register-definition-prefixes "gt-engine-google" '("gt-google-"))
+
+\f
+;;; Generated autoloads from gt-engine-google-rpc.el
+
+(register-definition-prefixes "gt-engine-google-rpc" '("gt-google-rpc-"))
+
+\f
+;;; Generated autoloads from gt-engine-libre.el
+
+(register-definition-prefixes "gt-engine-libre" '("gt-libre-"))
+
+\f
+;;; Generated autoloads from gt-engine-stardict.el
+
+(register-definition-prefixes "gt-engine-stardict" '("gt-stardict-"))
+
+\f
+;;; Generated autoloads from gt-engine-youdao.el
+
+(register-definition-prefixes "gt-engine-youdao" '("gt-youdao-"))
+
+\f
+;;; Generated autoloads from gt-extension.el
+
+(register-definition-prefixes "gt-extension" '("gt-"))
+
+\f
+;;; Generated autoloads from gt-faces.el
+
+(register-definition-prefixes "gt-faces" '("gt-p"))
+
+\f
+;;; Generated autoloads from gt-httpx.el
+
+(register-definition-prefixes "gt-httpx" '("gt-"))
+
+\f
+;;; Generated autoloads from gt-text-utility.el
+
+(autoload 'gt-qrcode "gt-text-utility" "\
+Genrate QR Code for STR.
+
+(fn STR)" t)
+(register-definition-prefixes "gt-text-utility" '("gt-text-"))
+\f
+;;; End of scraped data
+
+(provide 'go-translate-autoloads)
+
+;; Local Variables:
+;; version-control: never
+;; no-byte-compile: t
+;; no-update-autoloads: t
+;; no-native-compile: t
+;; coding: utf-8-emacs-unix
+;; End:
+
+;;; go-translate-autoloads.el ends here
--- /dev/null
+;; -*- no-byte-compile: t; lexical-binding: nil -*-
+(define-package "go-translate" "20240802.131"
+ "Translation framework, configurable and scalable."
+ '((emacs "28.1"))
+ :url "https://github.com/lorniu/go-translate"
+ :commit "424682b94df9efb3dd59e396677b45e4a67b7723"
+ :revdesc "424682b94df9"
+ :keywords '("convenience")
+ :authors '(("lorniu" . "lorniuNOSPAMgmail.com"))
+ :maintainers '(("lorniu" . "lorniuNOSPAMgmail.com")))
--- /dev/null
+;;; go-translate.el --- Translation framework, configurable and scalable -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+;; URL: https://github.com/lorniu/go-translate
+;; Package-Requires: ((emacs "28.1"))
+;; Keywords: convenience
+;; Package-Version: 20240802.131
+;; Package-Revision: 424682b94df9
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; Translation framework on Emacs, with high configurability and extensibility.
+;;
+;; - Support multiple translation engines, such as Google, Bing, DeepL, ChatGPT...
+;; - With variety of output styles, such as Buffer, Overlay, Childframe and so on.
+;; - With a flexible taker for easy retrieval of translated content and targets.
+;; - Support multiple paragraphs/parts and multi-language translation.
+;; - Support different http backends, such as url.el, curl. Async and non-blocking.
+;; - Support caches, proxy and more.
+;;
+;; Notice, it is not limited to just being a translation framework. It can fulfill
+;; any text transformation tasks, such as ChatGPT and more.
+;;
+;; Custom it as you need, extend it using your creativity.
+
+;; You can install it via MELPA or from github. Make sure it is on your `load-path'.
+;;
+;; For the most basic use, add the following configuration:
+;;
+;; (require 'go-translate)
+;;
+;; (setq gt-default-translator
+;; (gt-translator
+;; :taker (gt-taker :langs '(en zh))
+;; :engines (list (gt-google-engine) (gt-bing-engine))
+;; :render (gt-buffer-render)))
+;;
+;; Then start your translate with command `gt-do-translate'.
+;;
+;; See README.org for details.
+
+;;; Code:
+
+(require 'transient)
+(require 'gt-core)
+(require 'gt-extension)
+(require 'gt-engine-bing)
+(require 'gt-engine-google)
+(require 'gt-engine-google-rpc)
+(require 'gt-engine-deepl)
+(require 'gt-engine-stardict)
+(require 'gt-engine-youdao)
+(require 'gt-engine-chatgpt)
+(require 'gt-engine-libre)
+(require 'gt-engine-echo)
+(require 'gt-text-utility)
+
+;;; Mask these commands in M-x
+(dolist (cmd '(gt-prompt-next-target
+ gt-buffer-render--cycle-next
+ gt-buffer-render--refresh
+ gt-buffer-render--browser
+ gt-buffer-render--keyboard-quit
+ gt-buffer-render--toggle-readonly
+ gt-buffer-render--toggle-polyglot
+ gt-buffer-render--delete-cache
+ gt-buffer-render--show-tips
+ gt-buffer-render--unfold-source-text
+ gt-posframe-render-auto-close-handler
+ gt-stardict-switch-dict
+ gt-overlay-render-save-to-kill-ring))
+ (put cmd 'completion-predicate #'ignore))
+
+\f
+;;; Presets
+
+(defun gt-define-custom-taker ()
+ (let ((text (completing-read "Initial text: "
+ (gt-make-completion-table `(,@gt-taker-text-things nil))))
+ (pick (completing-read "Pick style: "
+ (gt-make-completion-table `(nil ,@gt-taker-pick-things))))
+ (prompt (completing-read "Prompt style: "
+ (gt-make-completion-table (list 'disable 'buffer 'minibuffer)) nil t)))
+ (gt-taker :text (intern text) :pick (intern pick)
+ :prompt (pcase prompt ("buffer" 'buffer) ("minibuffer" t) (_ nil)))))
+
+(defcustom gt-preset-takers
+ (lambda ()
+ `((,(gt-face-lazy "new..." 'bold) . ,#'gt-define-custom-taker)
+ (default . ,(gt-taker))
+ (interactively . ,(gt-taker :text t :pick t :prompt t))
+ (paragraph-at-point . ,(gt-taker :text 'paragraph :pick nil))
+ (whole-buffer . ,(gt-taker :text 'buffer :pick 'nil))
+ (whole-buffer-by-paragraph . ,(gt-taker :text 'buffer :pick 'paragraph))))
+ "Preset takers.
+
+It is an alist or a function return the alist, which the value is a valid
+instance of `gt-taker' and the key is a string or symbol, representing the
+display label of the taker.
+
+Custom your own takers and put them into this list, then change the taker
+of `gt-default-translator' at any time in `gt-do-setup'."
+ :type '(choice function
+ (alist :key-type (choice string symbol)
+ :value-type (sexp :tag "Instance of gt-taker")))
+ :group 'gt-do-translate)
+
+(defcustom gt-preset-engines
+ (lambda ()
+ `((Bing . ,(gt-bing-engine))
+ (DeepL . ,(gt-deepl-engine))
+ (Google . ,(gt-google-engine))
+ (ChatGPT . ,(gt-chatgpt-engine))
+ (ChatGPT-Stream . ,(gt-chatgpt-engine :stream t))
+ (Youdao-Dict . ,(gt-youdao-dict-engine))
+ (Youdao-Suggest . ,(gt-youdao-suggest-engine))
+ (StarDict . ,(gt-stardict-engine))
+ (LibreTranslate . ,(gt-libre-engine))
+ (GoogleRPC . ,(gt-google-rpc-engine))
+ (Google-Summary . ,(gt-google-engine :parse (gt-google-summary-parser)))
+ (Bionic_Reading . ,(gt-echo-engine :do '(clean br) :tag "Bionic Reading"))))
+ "Preset engines.
+
+It is an alist or a function return the alist, which the value is a valid
+instance of `gt-engine' and the key is a string or symbol, representing the
+display label of the engine.
+
+Custom your own engines and put them into this list, then change the engines
+of `gt-default-translator' at any time in `gt-do-setup'."
+ :type '(choice function
+ (alist :key-type (choice string symbol)
+ :value-type (sexp :tag "Instance of gt-engine")))
+ :group 'gt-do-translate)
+
+(defcustom gt-preset-renders
+ (lambda ()
+ `((,gt-buffer-render-buffer-name . ,(gt-buffer-render))
+ (insert/after . ,(gt-insert-render :type 'after))
+ (insert/replace . ,(gt-insert-render :type 'replace))
+ (overlay/after . ,(gt-overlay-render :type 'after))
+ (overlay/help-echo . ,(gt-overlay-render :type 'help-echo))
+ (message->echo-area . ,(gt-render))
+ (save->kill-ring . ,(gt-kill-ring-render))
+ (Pop-Posframe . ,(gt-posframe-pop-render))
+ (Pin-Posframe . ,(gt-posframe-pin-render))
+ (overlay-or-insert . ,(lambda ()
+ (if buffer-read-only
+ (gt-overlay-render :type 'after :then (gt-kill-ring-render))
+ (gt-insert-render :type 'after))))
+ (system-notification . ,(gt-alert-render))))
+ "Preset renders.
+
+It is an alist or a function return the alist, which the value is a valid
+instance of `gt-render' and the key is a string or symbol, representing the
+display label of the render.
+
+Custom your own render and put them into this list, then change the render
+of `gt-default-translator' at any time in `gt-do-setup'."
+ :type '(choice function
+ (alist :key-type (choice string symbol)
+ :value-type (sexp :tag "Instance of gt-render")))
+ :group 'gt-do-translate)
+
+(defcustom gt-preset-translators
+ (lambda ()
+ `((default . ,(gt-translator :taker (cdar (gt-ensure-plain gt-preset-takers))
+ :engines (cdar (gt-ensure-plain gt-preset-engines))
+ :render (cdar (gt-ensure-plain gt-preset-renders))))
+ (Text-Utility . ,(gt-text-utility
+ :taker (gt-taker :pick nil)
+ :render (gt-buffer-render)))))
+ "Preset translators.
+
+It is an alist or a function return the alist, which the value is a valid
+instance of `gt-translator' and the key is a string or symbol, representing the
+display label of the translator.
+
+Custom your own translator and put them into this list, then change the the
+default translator to one of them at any time in `gt-do-setup'."
+ :type '(choice function
+ (alist :key-type (choice string symbol)
+ :value-type (sexp :tag "Instance of gt-translator")))
+ :group 'gt-do-translate)
+
+(defcustom gt-default-translator nil
+ "The translator used by `gt-do-translate'.
+
+If you leave this nil, then the first translator in `gt-preset-translators'
+will be used as the default translator."
+ :type '(restricted-sexp :match-alternatives (gt-translator-p 'nil))
+ :group 'gt-do-translate)
+
+(defun gt-ensure-default-translator ()
+ "Initial `gt-default-translator' if possible and make sure it's valid."
+ (unless gt-default-translator
+ (setq gt-default-translator (cdar (gt-ensure-plain gt-preset-translators))))
+ (if (cl-typep gt-default-translator 'gt-translator)
+ (let (gt-debug-p) (gt-reset gt-default-translator))
+ (user-error "The `gt-default-translator' is unavailable"))
+ gt-default-translator)
+
+(defun gt-translator-info (translator)
+ "Return TRANSLATOR's basic info for displaying."
+ (with-slots (taker engines render _taker _engines _render) translator
+ (cl-macrolet ((desc1 (name &rest body)
+ `(if (not (slot-boundp translator ',(intern (format "_%s" name)))) "unbound"
+ (when-let (,name (or ,name ,(intern (format "_%s" name))))
+ (if (gt-functionp ,name)
+ (replace-regexp-in-string "[ \n\t]+" " " (format "%s" ,name))
+ ,@body)))))
+ (list (desc1 taker (if (consp taker) (format "%s" taker)
+ (cl-flet ((desc2 (slot) (when (slot-boundp taker slot)
+ (format "%s: %s" slot (slot-value taker slot)))))
+ (format "<%s> %s" (gt-desc taker)
+ (string-join (remove nil (mapcar #'desc2 '(langs text pick prompt))) ", ")))))
+ (desc1 engines (mapconcat (lambda (en) (concat (format "%s" (oref en tag)) (if (gt-stream-p en) " (stream)")))
+ (ensure-list (gt-ensure-plain engines)) ", "))
+ (desc1 render (if (consp render) (format "%s" render)
+ (gt-desc (gt-ensure-plain render))))))))
+
+(defun gt-set-taker (&optional translator taker)
+ "Set TRANSLATOR's TAKER to one from `gt-preset-takers'."
+ (interactive)
+ (unless translator (setq translator gt-default-translator))
+ (unless taker
+ (let ((cands (gt-ensure-plain gt-preset-takers)))
+ (setq taker (gt-ensure-plain
+ (alist-get
+ (completing-read "Taker to use: " (gt-make-completion-table cands) nil t)
+ cands nil nil #'string-equal)))))
+ (oset translator taker nil)
+ (oset translator _taker taker)
+ (message "Changed taker done."))
+
+(defun gt-set-engines (&optional translator engines)
+ "Set TRANSLATOR's ENGINES to ones from `gt-preset-engines'."
+ (interactive)
+ (unless translator (setq translator gt-default-translator))
+ (unless engines
+ (let ((cands (gt-ensure-plain gt-preset-engines)))
+ (setq engines
+ (mapcar (lambda (item)
+ (let ((engine (gt-ensure-plain (alist-get item cands nil nil #'string-equal))))
+ (if (cl-typep engine 'gt-engine) engine
+ (user-error "Invalid engine detected. Abort"))))
+ (completing-read-multiple "Engines to use (can choose multiple): "
+ (gt-make-completion-table cands))))))
+ (oset translator engines nil)
+ (oset translator _engines engines)
+ (message "Changed engines done."))
+
+(defun gt-set-render (&optional translator render)
+ "Set TRANSLATOR's RENDER to one from `gt-preset-renders'."
+ (interactive)
+ (unless translator (setq translator gt-default-translator))
+ (unless render
+ (let ((cands (gt-ensure-plain gt-preset-renders)))
+ (setq render (gt-ensure-plain
+ (alist-get
+ (completing-read "Render to use: " (gt-make-completion-table cands) nil t)
+ cands nil nil #'string-equal)))))
+ (oset translator render nil)
+ (oset translator _render render)
+ (message "Changed render done."))
+
+(defun gt-translator-copy-of-presets ()
+ (let* ((tss (gt-ensure-plain gt-preset-translators))
+ (tsn (completing-read "Preset translator: " tss nil t))
+ (translator (alist-get tsn tss nil nil #'string-equal)))
+ (list (clone translator) tsn)))
+
+(defun gt-switch-translator ()
+ "Switch `gt-default-translator' to another defined in `gt-preset-translators'."
+ (interactive)
+ (cl-destructuring-bind (translator name)
+ (gt-translator-copy-of-presets)
+ (setq gt-default-translator translator)
+ (gt-ensure-default-translator)
+ (message "Switch default translator to: %s" name)))
+
+(transient-define-prefix gt-do-setup ()
+ "Setup `gt-default-translator' in user interface provided by transient."
+ :transient-non-suffix #'transient--do-exit
+ [:description
+ (lambda ()
+ (format "Current Default Translator:\n\n %s\n"
+ (condition-case err
+ (apply #'format "Taker: %s\n Engines: %s\n Render: %s" (gt-translator-info (gt-ensure-default-translator)))
+ (error (format "%s" err)))))
+ [("t" "Set taker..." gt-set-taker :transient t)]
+ [("e" "Set engines..." gt-set-engines :transient t)]
+ [("r" "Set render..." gt-set-render :transient t)]
+ [("c" "Switch preset translator..." gt-switch-translator)]]
+ (interactive)
+ (gt-ensure-default-translator)
+ (transient-setup 'gt-do-setup))
+
+\f
+;;; Entrance
+
+;;;###autoload
+(defun gt-do-translate (&optional arg)
+ "Translate using `gt-default-translator'.
+
+Define your default translator like this:
+
+ (setq gt-default-translator
+ (gt-translator :engines (gt-bing-engine)))
+
+ (setq gt-default-translator
+ (gt-translator :taker (gt-taker :langs '(en fr) :text 'sentence :prompt t)
+ :engines (list (gt-google-engine) (gt-deepl-engine))
+ :render (gt-buffer-render)))
+
+Or define several different translators and put them in `gt-preset-translators',
+and switch with `gt-do-setup' at any time.
+
+This is just a simple wrapper of `gt-start' method. Create other translate
+commands in the same way using your creativity.
+
+If ARG is not nil, translate with translator select by `gt-preset-translators'."
+ (interactive "P")
+ (let ((gt-default-translator (if arg (car (gt-translator-copy-of-presets)) gt-default-translator)))
+ (gt-ensure-default-translator)
+ (gt-start gt-default-translator)))
+
+(provide 'go-translate)
+
+;;; go-translate.el ends here
--- /dev/null
+;;; gt-core.el --- Core implement of the Translator -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+;; Package-Requires: ((emacs "28.1"))
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; The core implement of the translator
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'subr-x)
+(require 'dom)
+(require 'eieio)
+(require 'text-property-search)
+
+(defgroup go-translate nil
+ "Translation framework on Emacs, with high configurability and extensibility."
+ :group 'external
+ :prefix 'gt-)
+
+(defcustom gt-debug-p nil
+ "Whether enable the debug message."
+ :type 'boolean
+ :group 'go-translate)
+
+\f
+;;; Components and Variables
+
+(defclass gt-single ()
+ ((insts :allocation :class :initform nil))
+ :abstract t
+ :documentation "Only create one instance for same slots.")
+
+(cl-defmethod make-instance ((class (subclass gt-single)) &rest slots)
+ (if-let* ((key (sha1 (format "%s" slots)))
+ (insts (oref-default class insts))
+ (old (cdr-safe (assoc key insts))))
+ old
+ (let ((inst (cl-call-next-method)))
+ (prog1 inst
+ (oset-default class insts `((,key . ,inst) ,@insts))))))
+
+(defclass gt-validator ()
+ ((if :initarg :if
+ :type (or function symbol list)
+ :documentation "See `gt-valid' for details."))
+ :abstract t
+ :documentation "Use to detect whether component is available")
+
+(defclass gt-task ()
+ ((text
+ :initarg :text
+ :type (or string list)
+ :documentation "Source text list to be translated.")
+ (src
+ :initarg :src
+ :initform nil
+ :type symbol
+ :documentation "Generally, the source language.")
+ (tgt
+ :initarg :tgt
+ :type symbol
+ :documentation "Generally, the target language.")
+ (meta
+ :initform nil
+ :initarg :meta
+ :type t
+ :documentation "Extra data passed in translation.")
+ (res
+ :initform nil
+ :type (or string list function)
+ :documentation "Translation result.")
+ (err
+ :initform nil
+ :documentation "Translation error.")
+ (cache
+ :initform nil
+ :documentation "Used to temporarily save the data from cache.")
+ (markers
+ :initform nil
+ :documentation "Markers tracking output bounds.")
+ (process
+ :initform nil
+ :documentation "Which process current task running.")
+
+ (id
+ :initform (gensym "task-")
+ :documentation "Used to distinguish between different tasks.")
+ (version
+ :initform nil
+ :initarg :version
+ :documentation "If this is different with the one in translator, task is expired.")
+
+ (engine
+ :initarg :engine
+ :documentation "Engine of current task.")
+ (render
+ :initarg :render
+ :documentation "Render of current task.")
+ (translator
+ :initarg :translator
+ :documentation "Translator of current task."))
+ :documentation
+ "An object contains basic translation infomations.
+Its life cycle is in one translation. It is created by translator, then derived
+to engines for result, at last extracted by render for output.")
+
+(defclass gt-taker (gt-single gt-validator)
+ ((text
+ :initarg :text
+ :type (or function symbol string)
+ :documentation "See `gt-taker-text' for details.")
+ (pick
+ :initarg :pick
+ :type (or function symbol)
+ :documentation "See `gt-taker-pick' for details.")
+ (pick-pred
+ :initarg :pick-pred
+ :initform nil
+ :type (or function null)
+ :documentation "Filter the picked element with this function.")
+ (langs
+ :initarg :langs
+ :type list
+ :documentation "See `gt-langs' for details.")
+ (prompt
+ :initarg :prompt
+ :type (or function symbol)
+ :documentation "See `gt-taker-prompt' for details.")
+ (then
+ :initarg :then
+ :documentation "A function with current translator as argument.
+Used to do extra works after taking done. For example, one can filter the
+source text list to remove unnecessary elements, or modifiy the translate
+target as a final step."))
+ :documentation
+ "A component used to take the translate source text and targets for translator.
+
+The steps are:
+1. take the initial text by `text'
+2. get the available targets from `langs'
+3. ensure the text and langs via `prompt' if necessary
+4. split or filter text via `pick' if possible
+
+So you can define a taker fully like this:
+
+ (gt-taker :text `buffer :langs `(en it) :prompt `buffer :pick `sentence)
+
+Or use the default value or corresponding variables as:
+
+ (setq gt-langs `(en it))
+ (gt-taker)
+
+Then use the taker in the translator and start your translation.")
+
+(defclass gt-parser (gt-single gt-validator)
+ ((tag
+ :initarg :tag
+ :initform nil
+ :type (or symbol string)
+ :documentation "Display label for this parser."))
+ :documentation
+ "It is a component of `gt-engine', used to parse the response of the engine
+to a user-friendly string. One engine can have different parsers, but can only
+use one of them at a time.")
+
+(defclass gt-engine (gt-single gt-validator)
+ ((tag
+ :initarg :tag
+ :type (or string symbol)
+ :documentation "Display label for this engine.")
+ (parse
+ :initarg :parse
+ :initform (gt-parser)
+ :type (or function gt-parser)
+ :documentation "Used to generate user-friendly result from response.")
+ (delimiter
+ :initarg :delimiter
+ :type (or null string)
+ :documentation "The delimiter for multiple paragraphs or parts translation.")
+ (stream
+ :initarg :stream
+ :type boolean
+ :initform nil
+ :documentation "Enable stream support for this engine.
+This effect both engine and render. If this is t, then retrieve results
+part by part. Render supporting stream output should refresh the display
+every time new data arrived.")
+ (cache
+ :initarg :cache
+ :type (or symbol function gt-cacher)
+ :documentation "Cache style used by the engine.
+If this is nil, current engine will use no cache at all.
+If this is literally symbol, see `gt-valid-literally' for details.
+If this is a cacher, then cache using the cacher instead.")
+ (salt
+ :initarg :salt
+ :initform nil
+ :documentation "Distinguish from... now for cache key only.")
+ (then
+ :initarg :then
+ :type function
+ :documentation "Function run after result are responsed and parsed.
+Take current task as argument. you can do extra works for current task
+before rendering."))
+ :documentation "Translate engine, retrieve the result and parse it.
+
+If `delimiter' is non nil, the translation for multiple paragraphs or parts will
+take a strategy as `join-translate-split'. That is, join the source text list to
+a single string separated by `delimiter', translate the whole string, and then
+split the result by `delimiter' into multiple parts. This assumes that the
+`delimiter' in string is kept by engine in the translation progress.
+
+Set `delimiter' to nil to avoid this strategy. In that case, a string list will
+be passed to the engine, and a translated string list is expected.
+
+Also in some cases, you should turn the cache off by setting `no-cache' to t."
+ :abstract t)
+
+(defclass gt-render (gt-single gt-validator)
+ ((output
+ :initarg :output
+ :initform nil
+ :type (or function null)
+ :documentation "If this is not nil, then will override the default output logic.")
+ (then
+ :initarg :then
+ :initform nil
+ :type (or function gt-render null)
+ :documentation "Chain results to next render if possible.
+If this is a function, pass current translator as argument and execute it only.")
+ (prefix
+ :initarg :prefix
+ :type (or function t)
+ :documentation "Custom prefix displayed in the render.
+If this is nil, then don't display prefix. If this is function use its return value
+as prefix. If this is a string, use the string as prefix."))
+ :documentation
+ "A component used to output the all the results made by translator.
+Method `gt-init' only works once before output, method `gt-output' will run after
+every task finished.")
+
+(defclass gt-translator ()
+ ((text
+ :type list
+ :initform nil
+ :initarg :text
+ :documentation "The text taken by taker, and prepare to translate.
+This should be a list, every element is a string as one pargraph or one part.
+This list will be sent to translate engines later.")
+
+ (bounds
+ :type list
+ :initform nil
+ :documentation "The bounds in buffer corresponds to the `text' slot.
+The first element is the working buffer, while rest are buffer bounds.")
+
+ (target
+ :type list
+ :initform nil
+ :documentation "The target taken by taker.
+
+This should be a list. Generally, the first element is the source language and
+the rest are the target languages. Target languages can be one or multiple,
+that is, in one translation, can translate same text into multiple languages.
+
+Of course, the target may be more than just the languages. If translator is not
+used to translate, then target may be something else representing the transform
+targets.")
+
+ (tasks
+ :initform nil
+ :type list
+ :documentation "All tasks created according the source text and targets.")
+
+ (total
+ :initform 0
+ :type (integer 0 *)
+ :documentation "Total tasks in current translation.")
+
+ (state
+ :initform 0
+ :type (member 0 1 2 3 4 9)
+ :documentation "The inner state of the translator for current translation:
+0: new translator
+1: all tasks added
+2: render prepared
+3: all result parsed
+4: translate abort")
+
+ (keep
+ :initform nil
+ :type boolean
+ :documentation "If t then don't clean text and target in a new translation.")
+
+ (version
+ :documentation "Used to distinguish with expired translations.")
+
+ (taker
+ :initarg :taker
+ :initform nil
+ :type (or function gt-taker list)
+ :documentation "Used to take input for the translator.
+If this is a function, use its return value as the taker. It will take the
+source text and targets, and save them into `text', `bounds' and `target' slots
+for the following translate task. If this is a list, use the first available one.")
+
+ (engines
+ :initarg :engines
+ :initform nil
+ :type (or function gt-engine list)
+ :documentation "The engines used to translate.
+This should be one or more `gt-engine' instances or a function that return them.
+The tasks created after `gt-take' will be passed to every engines. Every engine
+should translate the task and parse the result. After every task finished, the
+rendering process will be performed.")
+
+ (render
+ :initarg :render
+ :initform nil
+ :type (or function gt-render list)
+ :documentation "Used to output the translation results.
+This should be a `gt-render' instance or a function return one.
+If this is a list, use the first available one.")
+
+ (_taker
+ :type (or function gt-taker list)
+ :documentation "Backup of initial value of `taker', which may be a
+function or `gt-taker' object. The value will be normalized at the start of
+every translation and stored into the `taker' slot. Avoid changing this during
+translation progress unless you are confident in what you are doing.")
+
+ (_engines
+ :type (or function gt-engine list)
+ :documentation "Backup of initial `engines' like above.")
+
+ (_render
+ :type (or function gt-render list)
+ :documentation "Backup of initial `render' like above.")
+
+ (bag :initform nil))
+ :documentation "Core component of the translation.
+
+The basic components of a translator is taker, engines and render:
+1. Use `gt-taker' to capture the source text and target
+2. Then use one or more `gt-engine' to get the translate result
+3. At last use a `gt-render' to output the results to user.
+
+The start a translation, call `gt-start' on a translator instance like this:
+
+ (gt-start (make-instance `gt-translator
+ :taker (gt-taker)
+ :engines (gt-google-engine)
+ :render (gt-buffer-render)))
+
+That is: 1) define the translator 2) executable `gt-start'.")
+
+(defconst gt-lang-codes
+ '((en . "English")
+ (zh . "Chinese")
+ (ru . "Russian")
+ (fr . "French")
+ (it . "Italian")
+ (es . "Spanish")
+ (de . "German")
+ (ko . "Korean")
+ (ja . "Japanese")
+ (yue . "Cantonese")
+ (af . "Afrikaans")
+ (ak . "Akan")
+ (am . "Amharic")
+ (ar . "Arabic")
+ (as . "Assamese")
+ (asa . "Asu")
+ (az . "Azerbaijani")
+ (be . "Belarusian")
+ (bem . "Bemba")
+ (bez . "Bena")
+ (bg . "Bulgarian")
+ (bm . "Bambara")
+ (bn . "Bengali")
+ (bo . "Tibetan")
+ (bs . "Bosnian")
+ (ca . "Catalan")
+ (cgg . "Chiga")
+ (chr . "Cherokee")
+ (cs . "Czech")
+ (da . "Danish")
+ (dav . "Taita")
+ (ebu . "Embu")
+ (ee . "Ewe")
+ (el . "Greek")
+ (eo . "Esperanto")
+ (et . "Estonian")
+ (eu . "Basque")
+ (fa . "Persian")
+ (ff . "Fulah")
+ (fi . "Finnish")
+ (fil . "Filipino")
+ (fo . "Faroese")
+ (ga . "Irish")
+ (gl . "Galician")
+ (gsw . "Swiss German")
+ (gu . "Gujarati")
+ (guz . "Gusii")
+ (gv . "Manx")
+ (ha . "Hausa")
+ (haw . "Hawaiian")
+ (he . "Hebrew")
+ (hi . "Hindi")
+ (hr . "Croatian")
+ (hu . "Hungarian")
+ (hy . "Armenian")
+ (id . "Indonesian")
+ (ig . "Igbo")
+ (ii . "Sichuan Yi")
+ (is . "Icelandic")
+ (jmc . "Machame")
+ (ka . "Georgian")
+ (kab . "Kabyle")
+ (kam . "Kamba")
+ (kde . "Makonde")
+ (kea . "Kabuverdianu")
+ (khq . "Koyra Chiini")
+ (ki . "Kikuyu")
+ (kk . "Kazakh")
+ (kl . "Kalaallisut")
+ (kln . "Kalenjin")
+ (km . "Khmer")
+ (kn . "Kannada")
+ (kok . "Konkani")
+ (kw . "Cornish")
+ (lag . "Langi")
+ (lg . "Ganda")
+ (lt . "Lithuanian")
+ (luo . "Luo")
+ (luy . "Luyia")
+ (lv . "Latvian")
+ (mas . "Masai")
+ (mer . "Meru")
+ (mfe . "Morisyen")
+ (mg . "Malagasy")
+ (mk . "Macedonian")
+ (ml . "Malayalam")
+ (mr . "Marathi")
+ (ms . "Malay")
+ (mt . "Maltese")
+ (my . "Burmese")
+ (naq . "Nama")
+ (nd . "North Ndebele")
+ (ne . "Nepali")
+ (nl . "Dutch")
+ (nn . "Norwegian Nynorsk")
+ (nyn . "Nyankole")
+ (om . "Oromo")
+ (or . "Oriya")
+ (pa . "Punjabi")
+ (pl . "Polish")
+ (ps . "Pashto")
+ (pt . "Portuguese")
+ (rm . "Romansh")
+ (ro . "Romanian")
+ (rof . "Rombo")
+ (rw . "Kinyarwanda")
+ (rwk . "Rwa")
+ (saq . "Samburu")
+ (seh . "Sena")
+ (ses . "Koyraboro Senni")
+ (sg . "Sango")
+ (shi . "Tachelhit")
+ (si . "Sinhala")
+ (sk . "Slovak")
+ (sl . "Slovenian")
+ (sn . "Shona")
+ (so . "Somali")
+ (sq . "Albanian")
+ (sr . "Serbian")
+ (sv . "Swedish")
+ (sw . "Swahili")
+ (ta . "Tamil")
+ (te . "Telugu")
+ (teo . "Teso")
+ (th . "Thai")
+ (ti . "Tigrinya")
+ (to . "Tonga")
+ (tr . "Turkish")
+ (tzm . "Central Morocco Tamazight")
+ (uk . "Ukrainian")
+ (ur . "Urdu")
+ (uz . "Uzbek")
+ (vi . "Vietnamese")
+ (vun . "Vunjo")
+ (xog . "Soga")
+ (cy . "Welsh")
+ (yo . "Yoruba")
+ (zu . "Zulu")))
+
+(defconst gt-word-classes
+ '(pron adj adv adt art aux conj prep det abbr int vt vi v n a))
+
+(defvar gt-current-command nil)
+
+(defvar gt-current-translator nil)
+
+(defvar-local gt-tracking-marker nil)
+
+(cl-defgeneric gt-init (object &rest _args)
+ "Initialization for OBJECT.")
+
+(cl-defgeneric gt-desc (object)
+ "Return the string representation of the OBJECT."
+ (format "%s" (eieio-object-class object)))
+
+\f
+;;; Utility
+
+(defun gt-aref (vector &rest ns)
+ "Recursively find the element in VECTOR. NS is indexes, as the path."
+ (while ns
+ (setq vector (aref vector (pop ns))))
+ vector)
+
+(defmacro gt-orefs (instance &rest slots)
+ "Get all the SLOTS in INSTANCE as a list."
+ `(list ,@(cl-loop for slot in slots
+ collect `(slot-value ,instance ',slot))))
+
+(defun gt-ensure-plain (obj &rest args)
+ "Ensure OBJ is non-function and non-symbol.
+If OBJ is a function, call it with ARGS and return the result.
+If OBJ is symbol, return its value."
+ (if (functionp obj) (apply obj args) obj))
+
+(defun gt-functionp (object)
+ "Check if OBJECT is a function and not a class."
+ (and (functionp object) (not (class-p object))))
+
+(defun gt-clean-properties (text &optional props)
+ "Remove specified PROPS from TEXT."
+ (unless props (setq props '(gt-result gt-task gt-done read-only)))
+ (remove-list-of-text-properties 0 (length text) props text)
+ text)
+
+(defun gt-face-lazy (str face &optional display)
+ "Propertize STR to add FACE only when no face exists on it.
+Set DISPLAY property to STR if it is not nil.
+
+For example:
+
+ (gt-face-lazy s `font-lock-doc-face `(space (:width 30) raise 0.5))
+
+When `space' in DISPLAY, prepend a space to the STR."
+ (if (or (null face)
+ (with-temp-buffer
+ (insert str)
+ (or (text-property-search-backward 'face)
+ (text-property-search-backward 'font-lock-face)
+ (text-property-search-backward 'display))))
+ str
+ (let ((r (if face (propertize str 'face face) str))
+ (ds (cl-loop for (k v) on display by #'cddr
+ if (eq k 'space) append v into spaces
+ else append (list k v) into normals
+ finally (return (cons normals spaces)))))
+ (when-let (normals (car ds))
+ (setq r (propertize r 'display normals)))
+ (when-let (spaces (cdr ds))
+ (setq r (concat (propertize " " 'display (cons 'space spaces)) r)))
+ r)))
+
+(defun gt-line-height-separator (pixel)
+ "This can set line-height of the following line to PIXEL."
+ (concat (propertize "\s" 'display `(space :height (,pixel)))
+ (propertize "\n" 'line-height t)))
+
+(defmacro gt-simple-keymap (&rest definitions)
+ "A small wrapper to define new keymap for DEFINITIONS."
+ `(let ((map (make-sparse-keymap)))
+ (progn
+ ,@(cl-loop for (key value) on definitions by #'cddr
+ for v = (if (memq (car value) '(function quote lambda))
+ value
+ `(lambda () (interactive) ,value))
+ collect `(define-key map ,key ,v)))
+ map))
+
+(defun gt-collect-text (text-or-bounds)
+ "Collect the text corresponding to parts in TEXT-OR-BOUNDS."
+ (let* ((items (ensure-list text-or-bounds)) (car (car items)))
+ (unless (stringp car)
+ (with-current-buffer (if (bufferp car) car (current-buffer))
+ (setq items
+ (mapcar (lambda (bd) (buffer-substring (car bd) (cdr bd)))
+ (if (bufferp car) (cdr items) items)))))
+ (mapcar #'gt-clean-properties items)))
+
+(defun gt-lookup-password (&rest params)
+ "Query password stored in '.authinfo'.
+PARAMS contains search keys like :user, :host same as `auth-source-search'."
+ (when-let (secret (plist-get (car (apply 'auth-source-search params)) :secret))
+ (if (functionp secret)
+ (funcall secret)
+ secret)))
+
+(defun gt-insert-text-at-marker (str marker &optional end-marker keep-cursor)
+ "Insert STR to position of MARKER.
+If END-MARKER exists, delete the content between the markers first.
+If KEEP-CURSOR is not nil, keep the cursor at front."
+ (with-current-buffer (marker-buffer marker)
+ (let ((inhibit-read-only t))
+ (when end-marker
+ (set-marker-insertion-type end-marker t)
+ (delete-region marker end-marker))
+ (goto-char marker)
+ (deactivate-mark)
+ (if keep-cursor
+ (save-excursion (insert str))
+ (insert str)))))
+
+(defun gt-parse-html-dom (str)
+ "Parse html STR and return the DOM body."
+ (with-temp-buffer
+ (insert str)
+ (xml-remove-comments (point-min) (point-max))
+ (dom-by-tag (libxml-parse-html-region) 'body)))
+
+(declare-function let-alist--deep-dot-search "ext:let-alist" t t)
+
+(defmacro gt-plist-let (varlist &rest body)
+ "Let-bind dotted symbols to plist and execute BODY like `let-alist'.
+
+The last form of VARLIST is the plist to be bound with dot, bind other variables
+like those in `let*'.
+
+For example:
+
+ (gt-plist-let plist (list .a .b))
+
+ (gt-plist-let \\=`(:a 3 :b 4) (+ .a .b))
+
+ (gt-plist-let ((x 1) \\='(:y 2 :z 3)) (+ x .y .z))
+
+See gt-tests.el for details."
+ (declare (indent 1) (debug t))
+ (require 'let-alist)
+ (let ((var (make-symbol "plist")))
+ `(let* (,@(if (or (atom varlist)
+ (eq (car varlist) 'quote)
+ (eq (car varlist) '\`))
+ `((,var ,varlist))
+ `(,@(butlast varlist) ,(cons var (last varlist))))
+ ,@(cl-loop for (.k . k) in (delete-dups (let-alist--deep-dot-search body))
+ collect `(,.k (plist-get ,var ,(intern (format ":%s" k))))))
+ ,@body)))
+
+(defun gt-make-completion-table (items &optional order)
+ "Make completion table that ensure ITEMS sort by original ORDER."
+ (lambda (input pred action)
+ (if (eq action 'metadata)
+ `(metadata (category . "go-translate")
+ (display-sort-function . ,(or order #'identity)))
+ (complete-with-action action items input pred))))
+
+(defmacro gt-read-from-buffer (&rest forms)
+ "Read text in a new created buffer interactively.
+
+Available options can be specified as keyword arguments:
+ :buffer The buffer used for reading user input
+ :initial-contents The initial contents of the buffer
+ :keymap The keymap to use in the buffer
+ :window-config The window configuration for the window display the buffer
+ :catch Catch tag used in for inner `throw'
+ :apply-key The keybinding for applying changes (default: \"C-c C-c\")
+ :cancel-key The keybinding for canceling changes (default: \"C-c C-k\")
+ :apply-hook Hook run before apply operation
+ :cancel-hook Hook run before cancel operation
+
+Other FORMS is used to do extra initialization, you can config head line, mode
+line format or bind keys here.
+
+User can modify the buffer, and submit with `apply-key', then the contents of
+the buffer will returned as the result."
+ (gt-plist-let
+ ((cl-loop for item in forms by #'cddr
+ while (keywordp item) append (list (pop forms) (pop forms))))
+ (let ((buffer (or .buffer (format "*gt-%s*" (gensym "tmp-"))))
+ (tag (or .catch ''gt-read-from-buffer))
+ (apply-key (or .apply-key "C-c C-c"))
+ (cancel-key (or .cancel-key "C-c C-k")))
+ `(if (and (cl-plusp (recursion-depth)) (buffer-live-p (get-buffer ,buffer)))
+ (throw 'exit t) ; avoid recursion
+ (save-window-excursion
+ (catch ,tag
+ (unwind-protect
+ (with-current-buffer (get-buffer-create ,buffer)
+ ,(if .keymap `(use-local-map ,.keymap))
+ (local-set-key (kbd ,apply-key)
+ (lambda ()
+ (interactive)
+ ,(if .apply-hook `(funcall ,.apply-hook))
+ (throw ,tag (buffer-string))))
+ (local-set-key (kbd ,cancel-key)
+ (lambda ()
+ (interactive)
+ ,(if .cancel-hook `(funcall ,.cancel-hook))
+ (throw ,tag nil)))
+ (add-hook 'kill-buffer-query-functions
+ (lambda () ; only allow quit with C-c C-k
+ (not (and (memq this-command '(kill-buffer kill-this-buffer))
+ (message "Quit the buffer using `%s' please" ,cancel-key))))
+ nil t)
+ (erase-buffer)
+ ,(if .initial-contents `(insert ,.initial-contents))
+ ,@forms
+ (pop-to-buffer ,buffer ,.window-config)
+ (recursive-edit))
+ (ignore-errors (kill-buffer ,buffer)))))))))
+
+(cl-defgeneric gt-word-p (lang text)
+ "Whether TEXT is a single word in LANG.
+This is a generic method, improve it for specific LANG as you wish."
+ (setq text (string-trim text))
+ (if (eq lang 'zh)
+ (and (< (length text) 5)
+ (with-temp-buffer
+ (insert text)
+ (goto-char (point-min))
+ (while (re-search-forward "\\s." nil t) (replace-match ""))
+ (equal (thing-at-point 'word) text)))
+ (with-temp-buffer
+ (insert text)
+ (equal (thing-at-point 'word) text))))
+
+\f
+;;; Validator Trait
+
+;; add validate feature to `taker/engine/render/cache' through `:if' slot
+
+(cl-defgeneric gt-valid-literally (v text src tgt)
+ "Check literally symbol or form V to determine next step.
+
+It can be used by cacher and engine.
+
+V should be a symbol like `word', `parts', `src:en', `tgt:en', `selection',
+`xxx-mode', `read-only', or symbol with `not-' or `no-' prefix such as
+`not-word', `not-src:en', `no-parts' etc.
+
+V also can be a list form grouping above symbols with `and/or', for example:
+
+ (or word not-parts (and tgt:cn #`xxxx)).
+
+TEXT, SRC and TGT are translation text and targets.
+
+This is a generic method, you can extend the V as you wish."
+ (:method :around (v text src tgt)
+ (cond ((or (null v) (eq v t)) v)
+ ((symbolp v)
+ (setq text (ensure-list text))
+ (let ((vn (symbol-name v)) (notp nil))
+ (when (string-match "^not?-\\(.*\\)" vn) ; not-xxx style
+ (setq vn (match-string 1 vn))
+ (setq v (intern vn))
+ (setq notp t))
+ (funcall
+ (if notp #'not #'identity)
+ (cl-call-next-method v text src text))))
+ ((consp v) ; compose as: (or word (and not-parts src:zh))
+ (unless (member (car v) '(or and)) (push 'or v))
+ (funcall (if (eq (pop v) 'or) #'cl-some #'cl-every) #'identity
+ (mapcar (lambda (x) (gt-valid-literally x text src tgt)) v)))))
+ (let ((vn (symbol-name v)))
+ (cond
+ ((eq v 'word) (and (car text) ; text is word
+ (not (cdr text))
+ (gt-word-p (intern-soft src) (car text))))
+ ((eq v 'parts) (cdr text)) ; text is multiple parts
+ ((eq v 'selection) (use-region-p)) ; use region is active
+ ((eq v 'read-only) buffer-read-only) ; buffer is read-only
+ ((string-suffix-p "-mode" vn) ; major-mode or minor-mode
+ (if (boundp v) (symbol-value v) (eq major-mode v)))
+ ((string-match "^\\(src\\|tgt\\):\\(.+\\)" vn)
+ (member (match-string 2 vn) ; src/tgt is specific one, as src:en
+ (mapcar (lambda (item) (format "%s" item))
+ (ensure-list (if (equal (match-string 1 vn) "src") src tgt))))))))
+
+(cl-defgeneric gt-valid (component &rest _args)
+ "Validate COMPONENT, return t if it's available."
+ (:method ((component gt-validator) carrier)
+ "Determine if current COMPONENT is available through `if' slot.
+Slot value can be a function, a symbol or a list. CARRIER maybe a task, a
+translator or a list to provide more validation data."
+ (let (text src tgt)
+ (cond
+ ((cl-typep carrier 'gt-task)
+ (setq text (oref (oref carrier translator) text)
+ src (oref carrier src)
+ tgt (oref carrier tgt)))
+ ((cl-typep carrier 'gt-translator)
+ (setq text (oref carrier text)
+ src (car (oref carrier target))
+ tgt (cdr (oref carrier target))))
+ ((consp carrier)
+ (setq text (car carrier)
+ src (cadr carrier)
+ tgt (caddr carrier)))
+ (t (user-error "Carrier type is not supported")))
+ (with-slots (if) component
+ (cond ((not (slot-boundp component 'if)) t)
+ ((and (functionp if) (= 2 (car (func-arity if))))
+ (funcall if component carrier))
+ ((and (functionp if) (= 1 (car (func-arity if))))
+ (funcall if carrier))
+ (t (gt-valid-literally if text src tgt)))))))
+
+\f
+;;; Logging
+
+(defvar gt-log-buffer-name "*gt-log*"
+ "Log buffer for translator.")
+
+(defun gt-log (tag &rest messages)
+ "Log MESSAGES to `gt-log-buffer-name'.
+TAG is a label for message being logged."
+ (declare (indent 1))
+ (when gt-debug-p
+ (with-current-buffer (get-buffer-create gt-log-buffer-name)
+ (goto-char (point-max))
+ (if (and (null messages) (stringp tag))
+ (insert tag)
+ (let* ((tag (when tag
+ (concat
+ (gt-face-lazy (cl-subseq (format "%-.1f" (time-to-seconds)) 6) 'gt-logger-buffer-timestamp-face)
+ (gt-face-lazy (if (ignore-errors (string-blank-p tag)) tag (format " [%s]" tag)) 'gt-logger-buffer-tag-face)
+ " ")))
+ (count (if (numberp (car messages)) (pop messages) (length tag)))
+ (messages (mapconcat (lambda (s) (format "%s" s)) (delq nil messages) "\n"))
+ (msg (if (string-blank-p messages)
+ messages
+ (with-temp-buffer
+ (insert messages)
+ (goto-char (point-min))
+ (unless (= (length tag) count)
+ (insert "\n")
+ (goto-char (point-min)))
+ (while (re-search-forward "\n" nil t)
+ (save-excursion
+ (beginning-of-line)
+ (insert (make-string count ? ))))
+ (buffer-string)))))
+ (insert (or tag "") (or msg "") "\n"))))))
+
+(defmacro gt-log-funcall (fmt &rest objects)
+ `(gt-log ""
+ (gt-face-lazy
+ (format ,(if (string-match-p "^[ \n]" fmt) fmt (concat "gt-" fmt))
+ ,@(cl-loop
+ for o in objects collect
+ `(let ((obj ,o)) (if (eieio-object-p obj) (gt-desc obj) obj))))
+ 'font-lock-doc-face)))
+
+\f
+;;; Caching
+
+(defclass gt-cacher (gt-validator)
+ ((storage :initform nil :documentation "Where to save the caches."))
+ "Used to cache the translate results."
+ :abstract t)
+
+(defcustom gt-cache-alive-time (* 30 60)
+ "Default cache alive time."
+ :type 'integer
+ :group 'go-translate)
+
+(defvar gt-default-cacher nil)
+
+;; generic
+
+(defun gt-cacher-barking ()
+ (unless gt-default-cacher
+ (user-error "Make sure `gt-default-cacher' is properly configured. eg:\n
+ (setq gt-default-cacher (gt-memory-cacher))")))
+
+(cl-defgeneric gt-cache-get (_cacher _key &rest _)
+ "Query result of KEY from CACHER."
+ (:argument-precedence-order _key _cacher)
+ (gt-cacher-barking))
+
+(cl-defgeneric gt-cache-set (_cacher _key &rest _)
+ "Save result of KEY to CACHER."
+ (:argument-precedence-order _key _cacher)
+ (gt-cacher-barking))
+
+(cl-defgeneric gt-cache-purge (cacher &optional only-expired)
+ "Purge the storage of CACHER.
+If ONLY-EXPIRED not nil, purge caches expired only.")
+
+;; implement of caching in memory
+
+(defclass gt-memory-cacher (gt-cacher gt-single) ())
+
+(cl-defmethod gt-cache-get ((cacher gt-memory-cacher) key)
+ (with-slots (storage expired) cacher
+ (when-let (cache (ignore-errors (gethash key storage)))
+ (if (> (time-to-seconds) (cdr cache))
+ (remhash key storage)
+ (gt-log 'memory-cacher (format "get [%s] from caches (%s)" key (hash-table-count storage)))
+ (car cache)))))
+
+(cl-defmethod gt-cache-set ((cacher gt-memory-cacher) key value)
+ (with-slots (storage) cacher
+ (unless storage
+ (setf storage (make-hash-table :test #'equal)))
+ (if (null value)
+ (remhash key storage)
+ (let ((existp (gethash key storage))
+ (etime (+ (time-to-seconds) gt-cache-alive-time)))
+ (puthash key (cons value etime) storage)
+ (gt-cache-purge cacher t)
+ (gt-log 'memory-cacher
+ (format "%s [%s] to caches (%s)" (if existp "update" "add") key (hash-table-count storage)))))))
+
+(cl-defmethod gt-cache-purge ((cacher gt-memory-cacher) &optional only-expired)
+ (with-slots (storage) cacher
+ (when storage
+ (if only-expired
+ (maphash (lambda (key value)
+ (when (> (time-to-seconds) (cdr value))
+ (remhash key storage)))
+ storage)
+ (clrhash storage)))))
+
+;; caching task
+
+(cl-defmethod gt-valid ((cacher gt-cacher) (task gt-task) pred text)
+ (with-slots (src tgt) task
+ (or (and (null pred) (not (slot-boundp cacher 'if)))
+ (let ((pred (or pred (oref cacher if))))
+ (or (and (functionp pred) (funcall pred task))
+ (gt-valid-literally pred text src tgt))))))
+
+(cl-defmethod gt-cache-key ((task gt-task) &optional n)
+ "Generate caching key for the Nth text in TASK."
+ (with-slots (text src tgt engine parse) task
+ (sha1 (format "%s:%s:%s:%s:%s:%s"
+ (nth (or n 0) (ensure-list text)) src tgt
+ (gt-desc engine)
+ (gt-desc (oref engine parse))
+ (or (oref engine salt) "1")))))
+
+(cl-defmethod gt-cache-get (cacher (task gt-task))
+ (let ((results (cl-loop
+ for i from 1 to (length (ensure-list (oref task text)))
+ collect (gt-cache-get cacher (gt-cache-key task (1- i))))))
+ (when (cl-some #'identity results)
+ (gt-log 'render (format "%s: result from cache!" (oref task id))))
+ results))
+
+(cl-defmethod gt-cache-set (cacher (task gt-task) &optional pred)
+ (with-slots (text src tgt res) task
+ (cl-loop for c in text
+ for r in res
+ for i from 0
+ if (gt-valid cacher task pred c)
+ do (gt-cache-set cacher (gt-cache-key task i) r))))
+
+(defun gt-purge-cache (cacher)
+ "Purge storage of CACHER."
+ (interactive (list gt-default-cacher))
+ (when (y-or-n-p (format "Purge all caches from %s now?" (gt-desc cacher)))
+ (gt-cacher-barking)
+ (gt-cache-purge (or cacher gt-default-cacher))
+ (message "Cache purged.")))
+
+\f
+;;; Http Client
+
+(require 'gt-httpx)
+
+(defvar plz-curl-program)
+
+(defvar gt-default-http-client
+ (if (and (require 'plz nil t) (executable-find plz-curl-program))
+ (gt-plz-http-client)
+ (gt-url-http-client)))
+
+(cl-defmethod gt-request (&rest args &key url method headers data filter done fail sync retry cache)
+ "Simple wrapper for http client, and add cache support."
+ (ignore method headers filter sync retry)
+ (let ((client (gt-ensure-plain gt-default-http-client (url-host (url-generic-parse-url url)))))
+ (if (and client (eieio-object-p client) (object-of-class-p client 'gt-http-client))
+ (let* ((ckey (sha1 (format "%s%s" url data)))
+ (donefn (when done
+ (lambda (raw)
+ ;; try to cache the result
+ (when cache
+ (let ((gt-cache-alive-time (if (numberp cache) cache gt-cache-alive-time)))
+ (gt-cache-set gt-default-cacher ckey raw)))
+ (funcall done raw)))))
+ ;; try to get from cache first
+ (if-let (r (and cache (gt-cache-get gt-default-cacher ckey)))
+ (progn (gt-log 'cacher (format "Find %s in cache..." ckey))
+ (if donefn (funcall donefn r) r))
+ (cl-remf args :cache)
+ (apply #'gt-request client `(:done ,donefn ,@args))))
+ (let ((errmsg "Make sure `gt-default-http-client' is available. eg:\n\n(setq gt-default-http-client (gt-url-http-client))\n\n\n"))
+ (if fail (funcall fail errmsg) (user-error errmsg))))))
+
+\f
+;;; Taker
+
+(defcustom gt-langs nil
+ "Translation languages or targets.
+
+This is a list which element is a language string or symbol described in
+ISO 939-1. The taker will use this to determine the translate source and target.
+
+For example, if you want to translate between a and b, just set like:
+
+ (setq gt-langs `(a b)) or (setq gt-langs `(\"a\" \"b\"))
+
+If your working languages is more than two, just set like:
+
+ (setq gt-langs `(a b c d ..))
+
+The taker will choose the most possible translate source and target from
+the list, also you can switch between them in the following translation.
+
+Notice, the value can be overrided by `langs' slot in taker of translator. So
+config it for specific translator using slot is effectively."
+ :type '(repeat (choice string symbol))
+ :group 'go-translate)
+
+(defcustom gt-polyglot-p nil
+ "Toggle polyglot for translation.
+
+If this is t, the text will be translated into multiple targets.
+
+For example, assuming `gt-langs' or slot of `langs' is (a b c), the text
+may be translated from a to a and c if this is t, but translated from
+a to b or a to c if this is nil."
+ :type 'boolean
+ :group 'go-translate)
+
+(defvar gt-taker-text-things '(word paragraph sentence buffer line page list sexp defun symbol))
+
+(defvar gt-taker-pick-things '(word paragraph sentence line list sexp defun page symbol))
+
+(defcustom gt-taker-text 'word
+ "The initial text taken by taker of translator.
+
+If the region is actived, take the selection text. Otherwise, if this is a
+symbol, then try to use `thing-at-point' to take the text at point. If this
+is a function then invoke it and use its result as the initial text. Specially
+if this is t, take the text interactively.
+
+The default value is to take current active region or current word at point.
+
+Notice, the value can be overrided by `text' slot in taker of translator. So
+config it for specific translator using slot is effectively."
+ :type `(choice function
+ (choice ,@(mapcar (lambda (item) `(const ,item)) gt-taker-text-things)))
+ :group 'go-translate)
+
+(defcustom gt-taker-pick 'paragraph
+ "Filter the initial text and pick some for translation.
+
+If this is nil, do not pick and use the initial text as source text to
+translate directly.
+
+If this is a symbol, then pick elements by thing from initial text for
+translation, thing is just like those in `thing-at-point'.
+
+If this is a function then pass the initial text into it and use its result
+as source text to translate.
+
+Specially if this is t, pick the text interactively.
+
+The default value is paragraph, that is, try to split initial text into
+paragraphs and do a multiple parts translation.
+
+Notice, the value can be overrided by `pick' slot in taker of translator. So
+config it for specific translator using slot is effectively."
+ :type `(choice function
+ (choice ,@(mapcar (lambda (item) `(const ,item)) gt-taker-pick-things)))
+ :group 'go-translate)
+
+(defcustom gt-taker-prompt nil
+ "Whether or how to prompt for initial text and target.
+
+If you want to take the translation text and target interactively, set this to
+a non nil value.
+
+If this is t, then read and confirm using minibuffer. If this is `buffer' then
+open a new buffer instead to do the stuff.
+
+Notice, the value can be overrided by `prompt' slot in taker of translator. So
+config it for specific translator using slot is effectively."
+ :type '(choice (const :tag "Off" nil)
+ (const :tag "With-Minibuffer" t)
+ (const :tag "With-Buffer" buffer)
+ symbol)
+ :group 'go-translate)
+
+(defcustom gt-lang-rules
+ (list (cons 'ja "[\u3040-\u30FF]")
+ (cons 'ko "[\uAC00-\uD7A3]")
+ (cons 'ru "[\u0410-\u044F]") ; if matched then text is ru, otherwise it's not
+ (cons 'zh (lambda () (re-search-forward "[\u4e00-\u9fa5]" nil t))))
+ "Language match rules used to check the language of a given text.
+
+This is alist, key is the language and value is a regexp string or function.
+
+This is used by `gt-available-langs' to determine who are source language from
+target list by matching this. Text will match against the rules one by one,
+if matched, the language in rule serves as the source language, otherwise the
+language is excluded from the source candidates.
+
+This is not perfect. It's not an easy thing to check the language precisely.
+Maybe use the third party, for example python's langid, to check language is a
+good idea.
+
+Please add rule for your own languages if possible, or fixup the mistakes in the
+default rules to fit your need."
+ :type '(alist :key-type (symbol :tag "Lang")
+ :value-type (choice (function :tag "Function Rule")
+ (regexp :tag "Regexp rule")))
+ :group 'go-translate)
+
+(defvar gt-skip-lang-rules-p nil)
+
+(defvar gt-ignore-target-history-p nil)
+
+(defvar gt-last-target nil)
+
+(defvar gt-target-history nil)
+
+(cl-defgeneric gt-langs-maybe (text langs)
+ "Which languages this TEXT maybe belongs to, pick from LANGS."
+ (let* ((srcs langs)
+ (hit (catch 'gt-langs
+ (with-temp-buffer
+ ;; insert text
+ (insert text)
+ ;; clear punctuations
+ (goto-char (point-min))
+ (while (re-search-forward "\\s.\\|\n" nil t) (replace-match ""))
+ ;; apply rules
+ (cl-loop with rules = (cl-loop for r in gt-lang-rules if (member (car r) langs) collect r)
+ for (l . m) in rules
+ do (goto-char (point-min))
+ do (if (if (functionp m) (funcall m) (re-search-forward m nil t))
+ (throw 'gt-langs l) ; hit the one, return directly
+ (setq srcs (remove l srcs))) ; not the one, exclude it
+ finally (return nil))))))
+ (if hit (ensure-list hit) srcs)))
+
+(cl-defgeneric gt-thing-at-point (thing _mode)
+ "Retrieve text at point or from the selected region.
+
+If there is an active region, return its bounds. Otherwise return
+the bounds of the thing at point as a list of cons cells.
+
+THING should be an element of `gt-taker-text-things', it is used as the type
+of thing to take. If it is nil, it uses the value of `gt-taker-text'.
+If it is t, prompt the user to choose one from the list.
+
+This is a generic method, so you can extend the THING or override it for
+specific MODE."
+ (:method :around (thing mode)
+ (if (use-region-p)
+ (region-bounds)
+ (when thing
+ (cl-call-next-method thing mode))))
+ (unless (member thing gt-taker-text-things)
+ (setq thing (intern (completing-read "Take _ at point as source text: " gt-taker-text-things nil t nil 'gt-text-hist))))
+ (gt-log 'taker (format "take text by: %s" thing))
+ (if (eq thing 'buffer)
+ (let ((beg (save-excursion
+ (goto-char (point-min))
+ (skip-chars-forward " \t\n")
+ (beginning-of-line)
+ (point)))
+ (end (save-excursion
+ (goto-char (point-max))
+ (skip-chars-backward " \t\n")
+ (point))))
+ (when (> end beg)
+ (list (cons beg end))))
+ (when-let (rt (bounds-of-thing-at-point thing))
+ (list rt))))
+
+(cl-defgeneric gt-forward-thing (thing _mode)
+ "Get bound of THING after point and goto the end of THING.
+
+THING is is the ones in `gt-taker-pick-things'.
+
+This is a generic method, so you can override it for specific MODE."
+ (let ((ori (point)) pt end)
+ (pcase thing
+ ((or 'word 'symbol) (skip-syntax-forward "^w"))
+ (_ (skip-chars-forward " \r\n\t\f")
+ (when (string-match-p "[\n\r]" (buffer-substring ori (point)))
+ (skip-chars-backward " \t\f"))))
+ (setq pt (point))
+ (forward-thing thing)
+ (setq end (if (memq thing '(paragraph))
+ (point)
+ (save-excursion (skip-chars-backward " \r\n\t\f") (point))))
+ (when (> end pt) (cons pt end))))
+
+(defun gt-available-langs (langs text)
+ "Find available translation languages for given TEXT.
+
+LANGS is a list of languages to choose from, TEXT is used to determine
+the available ones according rules in `gt-taker-lang-match-alist'.
+
+Return a list of language pairs (src . rest) where src is the source
+language and rest is the target languages. Rest should be a list contains
+one or more languages."
+ (if (cdr langs)
+ (setq langs (mapcar #'intern-soft langs))
+ (user-error "At least two languages should be configed, current: %s" langs))
+ (let* ((str (string-join (or (ensure-list text) "")))
+ (srcs (or (if gt-skip-lang-rules-p langs (gt-langs-maybe str langs))
+ (user-error "Maybe no language match current translation")))
+ (pairs (if gt-polyglot-p
+ (cl-loop for lang in srcs
+ collect (cons lang (remove lang langs)))
+ (cl-loop for lang in srcs
+ append (cl-loop for tgt in (remove lang langs)
+ collect (list lang tgt))))))
+ (if gt-ignore-target-history-p
+ pairs
+ (let* ((head (cl-delete-duplicates (cl-remove-if-not (lambda (l) (member l pairs)) gt-target-history)))
+ (tail (cl-remove-if (lambda (l) (member l head)) pairs)))
+ (append head tail)))))
+
+(defun gt-pick-items-by-thing (text-or-bounds &optional thing pred)
+ "Pick elements by THING from TEXT-OR-BOUNDS.
+
+THING is the one in `gt-taker-pick-things', PRED is a function with one
+argument that used to filter the pick element.
+
+TEXT-OR-BOUNDS is a string or bound cell in the buffer. If it is a string,
+should return a list of strings representing the pieces picked from the text.
+If it is a bound, return a list of sub-bounds."
+ (if (null thing)
+ text-or-bounds
+ (unless (memq thing gt-taker-pick-things)
+ (setq thing (intern (completing-read "Pick _ for source text: " gt-taker-pick-things nil t nil 'gt-pick-hist))))
+ (cl-flet ((ps (beg end mode)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region beg end)
+ (goto-char (point-min))
+ (let (bds)
+ (while (not (save-excursion (skip-chars-forward " \r\n\t\f") (eobp)))
+ (when-let (bd (gt-forward-thing thing mode))
+ (cl-destructuring-bind (a . b) bd
+ (when (or (null pred) (funcall pred (buffer-substring a b)))
+ (push (cons a b) bds)))))
+ (nreverse bds))))))
+ (gt-log 'taker (format "pick from text by: %s" thing))
+ (let ((mode major-mode))
+ (cond ((stringp text-or-bounds)
+ (with-temp-buffer
+ (insert text-or-bounds)
+ (mapcar (lambda (p) (buffer-substring (car p) (cdr p)))
+ (ps (point-min) (point-max) mode))))
+ ((consp text-or-bounds)
+ (let ((bd text-or-bounds)) ; (a . b) or (buffer (a . b))
+ (with-current-buffer (if (bufferp (car bd)) (pop bd) (current-buffer))
+ (if (consp (car bd)) (setq bd (car bd)))
+ (ps (car bd) (cdr bd) mode))))
+ (t (user-error "Pick items error, maybe invalid input")))))))
+
+(cl-defgeneric gt-take (taker translator)
+ "Take source text and targets for TRANSLATOR.
+
+This is core method of TAKER. It combines `gt-text', `gt-target', `gt-prompt'
+and `gt-pick' together, saves text/bounds/target to be used in later translation
+into the translator instance at last.
+
+See type `gt-taker' for more description."
+ (:method :before ((taker gt-taker) translator)
+ (gt-log-funcall "take (%s %s)" taker translator))
+ (:method ((taker gt-taker) translator)
+ (with-slots (text bounds target keep) translator
+ (let ((prompt (and (null text) (null target)
+ (if (slot-boundp taker 'prompt)
+ (oref taker prompt)
+ gt-taker-prompt)))
+ (nopick (or (and text keep)
+ (gt-functionp (if (slot-boundp taker 'text)
+ (oref taker text)
+ gt-taker-text)))))
+ ;; 1) text
+ (unless text
+ (let ((rs (ensure-list (gt-text taker translator))))
+ ;; bounds: (buffer (a . b) (c . d))
+ (if (stringp (car rs))
+ (setf bounds (list (current-buffer)))
+ (unless (bufferp (car rs))
+ (push (current-buffer) rs))
+ (setf bounds rs))
+ ;; text: ("aaa" "bbb")
+ (setf text (gt-collect-text rs))))
+ ;; 2) target
+ (unless target
+ (setf target (gt-target taker translator)))
+ ;; 3) prompt
+ (when prompt (gt-prompt taker translator prompt))
+ (unless text (user-error "No source text found at all"))
+ ;; 4) pick
+ (unless nopick (gt-pick taker translator)))))
+ (:method :after ((taker gt-taker) translator)
+ (with-slots (text target) translator
+ (unless text
+ (user-error "Source Text should not be null"))
+ (with-slots (then) taker ; if `then' slot exists
+ (when (and (slot-boundp taker 'then) then (gt-functionp then))
+ (funcall then translator))))))
+
+(cl-defgeneric gt-text (_taker translator)
+ "Used to take initial text for TRANSLATOR.
+Return text, text list or bounds in buffer. This is non-destructive."
+ (:method ((taker gt-taker) _translator)
+ "Return the text selected by the TAKER."
+ (let ((text (if (slot-boundp taker 'text)
+ (oref taker text)
+ gt-taker-text)))
+ (cond ((symbolp text) (gt-thing-at-point text major-mode))
+ ((gt-functionp text) (funcall text))
+ (t text)))))
+
+(cl-defgeneric gt-target (_taker translator &optional dir)
+ "Used to pick target for TRANSLATOR.
+Return the target will be used. If DIR is `next or `prev, return the next or
+previous one. This is non-destructive."
+ (:method ((taker gt-taker) translator &optional dir)
+ (when-let* ((langs (ensure-list
+ (if (slot-boundp taker 'langs)
+ (oref taker langs)
+ gt-langs)))
+ (tgts (if (car langs)
+ (gt-available-langs langs (oref translator text))
+ (cdr langs)))
+ (index (let ((n (cl-position gt-last-target tgts :test #'equal)))
+ (if n (+ n (pcase dir ('next 1) ('prev -1) (_ 0))) 0)))
+ (target (nth (if (>= index (length tgts))
+ 0
+ (if (< index 0) (- (length tgts) 1) index))
+ tgts)))
+ (setq gt-last-target target))))
+
+(defvar gt-prompt-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map minibuffer-local-map)
+ (define-key map "\C-g" #'top-level)
+ (define-key map "\C-n" #'gt-prompt-next-target)
+ (define-key map "\C-p" (lambda () (interactive) (gt-prompt-next-target t)))
+ (define-key map "\C-l" #'delete-minibuffer-contents)
+ map)
+ "The keymap used when taker prompt with minibuffer.")
+
+(defvar gt-prompt-target nil)
+
+(defvar gt-prompt-overlay nil)
+
+(defun gt-prompt-prefix (target)
+ (when target
+ (format "[%s%s] "
+ (if-let (src (car target)) (format "%s > " src) "")
+ (mapconcat (lambda (s) (format "%s" s)) (ensure-list (cdr target)) ", "))))
+
+(defun gt-prompt-next-target (&optional backwardp)
+ "Switch to next target in prompt minibuffer.
+If BACKWARDP is not nil then switch to previous one."
+ (interactive)
+ (let ((gt-skip-lang-rules-p (or current-prefix-arg (string-blank-p (minibuffer-contents)))))
+ (setq gt-prompt-target
+ (gt-target (oref gt-current-translator taker)
+ (make-instance (eieio-object-class gt-current-translator)
+ :text (list (minibuffer-contents)))
+ (if backwardp 'prev 'next)))
+ (overlay-put gt-prompt-overlay 'before-string (gt-prompt-prefix gt-prompt-target))))
+
+(cl-defgeneric gt-prompt (_taker translator _type)
+ "Prompt user with inital text and target, then update TRANSLATOR with new values."
+ (:method :before ((_taker gt-taker) translator _type)
+ (when (cdr (oref translator text)) ; for solo part only
+ (user-error "Multiple part text cannot be prompted")))
+ (:method ((_ gt-taker) translator _type)
+ (with-slots (text bounds target) translator
+ (let* ((minibuffer-allow-text-properties t)
+ (newtext (minibuffer-with-setup-hook
+ (lambda ()
+ (setq gt-prompt-target target)
+ (setq gt-prompt-overlay (make-overlay 1 2))
+ (overlay-put gt-prompt-overlay 'before-string (gt-prompt-prefix gt-prompt-target)))
+ (read-from-minibuffer "Text: " (car text) gt-prompt-map))))
+ (when (string-blank-p newtext)
+ (user-error "Text should not be null"))
+ (unless (equal newtext (car text))
+ (setf bounds (list (car bounds))))
+ (setf text (ensure-list newtext))
+ (setf target gt-prompt-target)))))
+
+(cl-defgeneric gt-pick (_taker translator)
+ "Update TRANSLATOR with pieces picked from initial text or bounds."
+ (:method :around ((taker gt-taker) translator)
+ (with-slots (text bounds) translator
+ (unless (bufferp (car bounds)) ; ensure buffer is recorded
+ (push (current-buffer) bounds))
+ (when (and (not (cdr text)) ; for solo part only
+ (if (slot-boundp taker 'pick) (oref taker pick) gt-taker-pick)) ; pick is non-nil
+ (cl-call-next-method taker translator))))
+ (:method ((taker gt-taker) translator)
+ (with-slots (text bounds) translator
+ (if-let* ((buf (car bounds))
+ (car (if (cdr bounds) (cl-subseq bounds 0 2) ; buffer bound
+ (or (car text) ; text
+ (user-error "Where should I pick from?"))))
+ (pick (if (slot-boundp taker 'pick) (oref taker pick) gt-taker-pick))
+ (res (ensure-list
+ (cond
+ ((gt-functionp pick) (funcall pick car))
+ ((memq pick gt-taker-pick-things)
+ (gt-pick-items-by-thing car pick (oref taker pick-pred)))
+ ((symbolp pick) (gt-pick pick translator))))))
+ ;; string pieces vs bound pieces
+ (if (stringp (car res))
+ (setf text res)
+ (unless (bufferp (car res)) (push buf res))
+ (setf bounds res text (gt-collect-text res)))
+ (user-error "Nothing picked, empty request")))))
+
+\f
+;;; Engine
+
+(defcustom gt-cache-p t
+ "Whether enable the cache."
+ :type 'boolean
+ :group 'go-translate)
+
+(defconst gt-text-delimiter "314141592926666")
+
+(defun gt-current-cacher (engine task)
+ "Return the cacher used by ENGINE for current TASK."
+ (let (cacher condition)
+ (when gt-cache-p
+ (let ((cc (gt-ensure-plain
+ (if (slot-boundp engine 'cache) (if-let (c (gt-ensure-plain (oref engine cache) task)) c) t)
+ task)))
+ (cond ((null cc))
+ ((eq cc t) (setq cacher gt-default-cacher condition nil))
+ ((symbolp cc) (setq cacher gt-default-cacher condition cc))
+ (t (setq cacher cc condition nil)))))
+ (cl-values cacher condition)))
+
+(cl-defmethod initialize-instance :after ((engine gt-engine) &rest _)
+ (unless (slot-boundp engine 'tag)
+ (oset engine tag (gt-desc engine))))
+
+(cl-defmethod gt-init ((engine gt-engine) task)
+ "Preprocessing text in TASK for ENGINE. Try cache first if possible."
+ (with-slots (id text cache) task
+ (gt-log-funcall "init (%s %s)" engine id)
+ ;; if stream, not cache
+ (if (gt-stream-p engine) (oset engine cache nil))
+ ;; query cache first
+ (when-let (cacher (car-safe (gt-current-cacher engine task)))
+ (setf cache (gt-cache-get cacher task)))
+ ;; only translate the parts not in cache
+ (if (and cache (cl-every #'identity cache))
+ (gt-next engine task)
+ (let ((text-left (if cache (cl-loop for c in text for r in cache unless r collect c) text)))
+ ;; join with delimiter if possible
+ (if-let (delimiter (if (slot-boundp engine 'delimiter) (oref engine delimiter) gt-text-delimiter))
+ (setf text (string-join text-left (concat "\n\n" delimiter "\n\n")))
+ (setf text text-left))))))
+
+(cl-defgeneric gt-translate (engine task &optional next)
+ "Translate or transform text in TASK and parse the results using ENGINE.
+
+The raw response will save into `res' slot of translator. Then NEXT runs, that
+will do the parse and render job. See type `gt-engine' for more description."
+ (:method :around ((engine gt-engine) task &optional _next)
+ (gt-log-funcall "translate (%s %s)" engine (oref task id))
+ (gt-init engine task)
+ (with-slots (id text err res render translator process) task
+ (unless (or res err)
+ (gt-log 'next (format "%s: %s prepare to translate" id (gt-desc engine)))
+ (let ((ret (cl-call-next-method
+ engine task
+ (lambda (task)
+ (if (equal (oref translator version) (oref task version))
+ (condition-case err1
+ (if (gt-stream-p engine)
+ (if gt-http-client-stream-abort-flag
+ (gt-log 'next (format "%s: %s translate streaming abort!" id (gt-desc engine)))
+ (gt-next-for-stream render task))
+ (gt-log 'next (format "%s: %s translate success!" id (gt-desc engine)))
+ (gt-next engine task))
+ (gt-fail task err1))
+ (gt-log 'next (format "%s: ----- expired -----" id)))))))
+ (if (processp ret) (setf process ret))))))
+ (:method ((engine gt-engine) _task _next)
+ (user-error "Method `gt-translate' of %s is not implement" (gt-desc engine))))
+
+(cl-defgeneric gt-parse (_parser task)
+ "Parse results of TASK to user-friendly string."
+ (:method :before ((parser gt-parser) task)
+ (gt-log-funcall "parse (%s %s)" parser (oref task id)))
+ (:method ((_ gt-parser) _task) nil))
+
+(cl-defgeneric gt-stream-p (_engine)
+ "Whether streaming query is on for ENGINE."
+ nil)
+
+(cl-defgeneric gt-next (_engine task)
+ "Chain to the parse and render phase for TASK."
+ (:method ((engine gt-engine) task)
+ (gt-log-funcall "next (%s %s)" engine (oref task id))
+ (with-slots (text res meta cache translator) task
+ (with-slots (parse delimiter then) engine
+ ;; parse
+ (when res
+ (when-let (parser (and (slot-boundp engine 'parse) parse))
+ (if (gt-functionp parser)
+ (funcall parser task)
+ (gt-parse parser task)))
+ ;; split with delimiter if possible
+ (when-let (delimiter (and (stringp res) (if (slot-boundp engine 'delimiter) delimiter gt-text-delimiter)))
+ (setf res (mapcar (lambda (item) (string-trim item "\n+")) (split-string res delimiter))))
+ (setf res (ensure-list res))
+ ;; run res-hook if possible
+ (when-let (hook (plist-get meta :res-hook))
+ (setf res (funcall hook res))))
+ ;; resume text and merge cache to res
+ (setf text (oref translator text))
+ (if cache (setf res (cl-loop for c in cache if (null c) collect (pop res) else collect c)))
+ ;; verify
+ (unless res
+ (user-error "No translate result found"))
+ (unless (= (length (remove nil res)) (length text))
+ (user-error "Source text and result text have no same length"))
+ ;; set cache if possible
+ (cl-destructuring-bind (cacher condition) (gt-current-cacher engine task)
+ (when cacher (gt-cache-set cacher task condition)))
+ ;; invoke then when it is exists
+ (when (and (slot-boundp engine 'then) then (gt-functionp then))
+ (funcall then task))
+ ;; all right, render
+ (gt-update-state translator)
+ (gt-output (oref translator render) translator)))))
+
+(cl-defgeneric gt-next-for-stream (_render task)
+ "Output result in TASK to specific marker position directly.
+Notice, the result should propertized with `gt-result' to avoid issue.
+This is used for streaming output for _RENDER."
+ (:method :around ((render gt-render) task)
+ (with-slots (markers) task
+ (if (null markers)
+ (progn
+ (setq gt-http-client-stream-abort-flag t)
+ (message "Stream output is unavailable for current task."))
+ (setf markers (ensure-list markers))
+ (cl-call-next-method render task))))
+ (:method ((_render gt-render) task)
+ (with-slots (markers res) task
+ (save-excursion
+ (gt-insert-text-at-marker
+ (propertize (string-join (ensure-list res) "\n") 'gt-result 'stream)
+ (car markers) (cdr markers) t)))))
+
+\f
+;;; Text to Speech
+
+(defcustom gt-tts-speaker (cl-find-if #'executable-find (list "mpv" "mplayer" "cvlc"))
+ "The program used to speak the translation result.
+It also can be a command with options like `mpv --af=xxx'.
+The value should not contain any space in the command path."
+ :type 'string
+ :group 'go-translate)
+
+(defvar gt-tts-langs nil)
+
+(defvar gt-tts-last-engine nil)
+
+(defvar gt-tts-speak-process nil)
+
+(defun gt-interrupt-speak-process ()
+ (when (and gt-tts-speak-process (process-live-p gt-tts-speak-process))
+ (ignore-errors (kill-process gt-tts-speak-process))
+ (setq gt-tts-speak-process nil)))
+
+(cl-defmethod gt-play-audio (data &optional wait)
+ "Play DATA with `gt-tts-playing-process'.
+DATA is raw audio data or audio url, or a buffer contains the raw data.
+If WAIT is not nil, play after current process finished."
+ (unless (and gt-tts-speaker (executable-find (car (split-string gt-tts-speaker))))
+ (user-error "You should install `mpv' first or config `gt-tts-speaker' correctly"))
+ (when wait
+ (condition-case _
+ (while (and gt-tts-speak-process (process-live-p gt-tts-speak-process))
+ (sleep-for 0.5))
+ (quit (gt-interrupt-speak-process) (user-error ""))))
+ (gt-interrupt-speak-process)
+ (cl-flet ((speak ()
+ (let ((proc (make-process
+ :name (format "gt-tts-process-%s" (+ 1000 (random 1000)))
+ :command (append (split-string-shell-command gt-tts-speaker) (list "-"))
+ :buffer nil
+ :noquery t
+ :sentinel (lambda (_ s) (if (string-match-p "finished" s) (message "")))
+ :connection-type 'pipe)))
+ (message "Speaking...")
+ (setq gt-tts-speak-process proc)
+ (process-send-region proc (point-min) (point-max))
+ (if (process-live-p proc) (process-send-eof proc)))))
+ (if (bufferp data)
+ (with-current-buffer data (speak))
+ (with-temp-buffer
+ (let ((buf (current-buffer)) state)
+ (if (string-prefix-p "http" data)
+ (progn (gt-request :url data
+ :cache 10
+ :done (lambda (raw)
+ (setq state 'done)
+ (with-current-buffer buf (insert raw)))
+ :fail (lambda (err) (setq state err)))
+ (while (null state)
+ (accept-process-output nil 0.5)))
+ (insert data))
+ (if (and state (not (eq state 'done))) (signal 'user-error state))
+ (speak))))))
+
+(cl-defgeneric gt-speak (engine text &optional lang)
+ "Speak TEXT with LANG by ENGINE."
+ (:method ((_ (eql 'local)) text &optional _lang)
+ "TEXT to speech with local program."
+ (cond ((and (eq system-type 'darwin) (executable-find "say"))
+ (with-temp-buffer
+ (insert text)
+ (shell-command-on-region (point-min) (point-max) "say" t)))
+ ((and (memq system-type '(cygwin windows-nt)) (executable-find "powershell"))
+ (let ((cmd (format "$w = New-Object -ComObject SAPI.SpVoice; $w.speak(\\\"%s\\\")" text)))
+ (shell-command (format "powershell -Command \"& {%s}\""
+ (encode-coding-string
+ (replace-regexp-in-string "\n" " " cmd)
+ (keyboard-coding-system))))))
+ (t (user-error "No suitable local TTS service found"))))
+ (:method ((_ (eql 'interact)) text &optional noprompt)
+ "Text to speech with local program or using selected engine."
+ (let* ((prompt "Text to Speech: ")
+ (regexp (format "^ *\\(%s\\)\\." (mapconcat #'symbol-name (mapcar #'car gt-lang-codes) "\\|")))
+ (engines `(locally ,@(cl-loop
+ for m in (cl--generic-method-table (cl--generic #'gt-speak))
+ for n = (car (cl--generic-method-specializers m))
+ unless (or (consp n) (memq n '(t gt-engine))) collect n)))
+ (overlay nil)
+ (text (if noprompt text
+ (minibuffer-with-setup-hook
+ (lambda ()
+ (use-local-map (make-composed-keymap nil (current-local-map)))
+ (setq overlay (make-overlay (1- (length prompt)) (length prompt)))
+ (unless gt-tts-last-engine (setq gt-tts-last-engine 'locally))
+ (overlay-put overlay 'display (format " (%s):" gt-tts-last-engine))
+ (local-set-key (kbd "C-n")
+ (lambda ()
+ (interactive)
+ (setq gt-tts-last-engine
+ (let ((i (cl-position gt-tts-last-engine engines)))
+ (nth (if (>= (+ i 1) (length engines)) 0 (1+ i)) engines)))
+ (overlay-put overlay 'display (format " (%s):" gt-tts-last-engine)))))
+ (read-string prompt (if (consp text) (buffer-substring (caar text) (cdar text)) text)))))
+ (lang (if (string-match regexp text)
+ (prog1 (intern-soft (match-string 1 text))
+ (setq text (substring text (match-end 0))))
+ (car (gt-langs-maybe text (or gt-tts-langs (mapcar #'car gt-lang-codes)))))))
+ (when (= (length (string-trim text)) 0)
+ (user-error "Input should not be null"))
+ (unless gt-tts-last-engine (setq gt-tts-last-engine 'locally))
+ (gt-log 'tts (format "Speak with %s to %s" gt-tts-last-engine lang))
+ (if (equal gt-tts-last-engine 'locally)
+ (gt-speak 'local text lang)
+ (gt-speak (make-instance gt-tts-last-engine) text lang))))
+ (:method :around ((engine gt-engine) text &optional lang)
+ (cl-call-next-method engine text (intern-soft lang)))
+ (:method ((engine gt-engine) &rest _)
+ (user-error "No TTS service found on engine `%s'" (oref engine tag))))
+
+;;;###autoload
+(defun gt-do-speak ()
+ "Speak content around point.
+
+If the text under point or with selection has `gt-task' or `gt-tts-url'
+property, try to speak it with current translation engine.
+
+Otherwise try to TTS with local program or using selected engine.
+
+When TTS with specific engine, you can specify the language with `lang.' prefix."
+ (interactive)
+ (if-let (url (get-char-property (point) 'gt-tts-url))
+ ;; 1. play the url
+ (gt-play-audio url)
+ (let (items engine)
+ (if-let (task (get-char-property (point) 'gt-task))
+ (with-slots (src tgt res err translator) task
+ (with-slots (text target) translator
+ ;; 2. play current task
+ (setq engine (oref task engine))
+ (unless (cl-find-method #'gt-speak '() `(,(eieio-object-class engine) t t))
+ (user-error "No TTS service found on current engine `%s'" (oref engine tag)))
+ (let ((part (or (get-char-property (point) 'gt-part) 0))
+ (col (lambda (l c) (push (format "%s. %s" l (substring-no-properties c)) items))))
+ (if (use-region-p)
+ (cl-loop with text = (buffer-substring (region-beginning) (region-end))
+ for l in (gt-langs-maybe text (list src tgt)) do (funcall col l text))
+ (when-let (r (nth part text))
+ (funcall col (car target) r))
+ (when-let (r (and (not err) (or (get-pos-property (point) 'gt-brief) (nth part (ensure-list res)))))
+ (funcall col tgt r)))
+ (when items
+ (let* ((cand (completing-read
+ (format "Text to Speech (with %s): " (oref engine tag))
+ (gt-make-completion-table items)))
+ (lang (if (string-match (format "^ *\\(%s\\)\\." (mapconcat #'symbol-name (mapcar #'car gt-lang-codes) "\\|")) cand)
+ (prog1 (intern-soft (match-string 1 cand))
+ (setq cand (substring cand (match-end 0))))
+ (car (gt-langs-maybe cand (list src tgt))))))
+ (unless lang (user-error "Guess language of text failed"))
+ (gt-log 'tts (format "Speak with %s to %s" engine lang))
+ (gt-speak engine cand lang))))))
+ ;; 3. play with local program or using selected engine
+ (gt-speak 'interact (gt-text (gt-taker :text 'word) nil))))))
+
+\f
+;;; Render
+
+(cl-defmethod gt-init :around ((render gt-render) translator)
+ (gt-log-funcall "init (%s %s)" render translator)
+ (message "Processing...")
+ (condition-case err
+ (progn (cl-call-next-method render translator)
+ (gt-update-state translator))
+ (error (gt-log 'render (format "%s initialize failed, abort" (gt-desc render)))
+ (user-error (format "[output init error] %s" err)))))
+
+(cl-defmethod gt-init ((_render gt-render) _translator)
+ "Initialize the RENDER. Only invoke once before output."
+ nil)
+
+(cl-defgeneric gt-extract (render translator)
+ "Extract TRANSLATOR's responses that to be consumed by RENDER."
+ (:method ((render gt-render) translator)
+ (with-slots (text tasks) translator
+ (cl-loop with tgts = (cl-delete-duplicates (mapcar (lambda (item) (oref item tgt)) tasks))
+ with engines = (cl-delete-duplicates (mapcar (lambda (task) (oref task engine)) tasks))
+ for task in tasks
+ for (tgt res err engine) = (gt-orefs task tgt res err engine)
+ for state = (if err 1 (if res 2 0)) ; 0 loading 1 error 2 result
+ for prefix = (with-slots (prefix) render
+ (if (and (slot-boundp render 'prefix) (not (eq prefix t)))
+ (when prefix
+ ;; custom prefix with :prefix slot
+ (if (gt-functionp prefix)
+ (funcall prefix task)
+ (format "%s" prefix)))
+ (when (or (cdr tgts) (cdr engines))
+ ;; style as: en.Google.Detail
+ (let ((lst (list (if (cdr tgts) tgt)
+ (if (cdr engines) (oref engine tag))
+ (if (cdr engines) (ignore-errors (oref (oref engine parse) tag))))))
+ (concat
+ (mapconcat (lambda (item) (format "%s" item)) (remove nil lst) ".")
+ (if (and (cdr engines) (gt-stream-p engine)) " (stream)"))))))
+ for result = (pcase state (0 "Loading...") (1 err) (2 res))
+ collect (list :result result :prefix prefix :state state :task task :tgt tgt :stream (gt-stream-p engine)) into lst
+ finally (return ;; sort by target, then by engine
+ (if (cdr tgts)
+ (cl-loop for tgt in tgts append
+ (cl-remove-if-not (lambda (tr) (equal tgt (plist-get tr :tgt))) lst))
+ lst))))))
+
+(cl-defgeneric gt-output (render translator)
+ "Output result of TRANSLATOR with RENDER, invoked after every task parsed.
+Output to minibuffer by default."
+ (:method :around ((render gt-render) translator)
+ (with-slots (state) translator
+ (gt-log-funcall "output (%s %s) %s" render translator state)
+ (when (<= state 4)
+ (with-slots (output then) render
+ ;; error handler & functionp case
+ (condition-case err
+ (if (gt-functionp output)
+ (funcall output render translator)
+ (cl-call-next-method render translator)
+ ;; chain next render if possible
+ (when (and (= state 3) then)
+ (cond ((gt-functionp then)
+ (funcall then translator))
+ ((and (eieio-object-p then) (object-of-class-p then 'gt-render))
+ (gt-init then translator)
+ (gt-output then translator))
+ (t (error "Bad then value specified in %s" (gt-desc render))))))
+ (error (setf state 4)
+ (message "[output error] %s" (cadr err))))))))
+ (:method ((render gt-render) translator)
+ (when (= 3 (oref translator state))
+ (cl-loop with ret = (gt-extract render translator)
+ with mpp = (cdr (oref translator text))
+ for tr in ret
+ for (prefix result) = (gt-plist-let tr (list (concat "[" .prefix "]" (if mpp "\n" " ")) .result))
+ collect (concat (if (cdr ret) (propertize prefix 'face 'gt-render-prefix-face))
+ (if (consp result) (string-join result "\n") result))
+ into lst
+ finally (message "%s" (string-join lst "\n"))))))
+
+\f
+;;; Translator
+
+(defun gt-add-task (task)
+ "Add new TASK for translation."
+ (with-slots (id engine render version translator) task
+ (with-slots (tasks state) translator
+ (when (= state 0)
+ (setf tasks (append tasks (list task)))
+ (gt-log (format "%d" (length tasks))
+ (format "add task %s: (%s/%s)" id (gt-desc engine) (gt-desc render)))))))
+
+(defun gt-update-state (translator)
+ "Update state for TRANSLATOR."
+ (with-slots (state total tasks render) translator
+ (pcase state
+ (0
+ (when (= (length tasks) total)
+ (gt-log 'translator "<1> all tasks added")
+ (setf state 1)))
+ (1
+ (gt-log 'translator
+ (format "<2> %s prepared" (gt-desc render)))
+ (setf state 2))
+ (2
+ (when (= total (length (cl-remove-if-not (lambda (task) (or (oref task err) (oref task res))) tasks)))
+ (gt-log 'translator "<3> all result parsed")
+ (setf state 3))))))
+
+(defun gt-fail (task error)
+ "Render ERROR message and ternimate the TASK."
+ (declare (indent 1))
+ (gt-log-funcall "fail (%s)" (oref task id))
+ (with-slots (translator render err version id) task
+ (when (equal version (oref translator version))
+ (setf err (if (consp error)
+ (mapconcat (lambda (r)
+ (format (if (string-suffix-p "error" (format "%s" r)) "[%s]" "%s") r))
+ (cl-remove-if (lambda (r) (memq r '(error user-error))) error)
+ " ")
+ (or error "")))
+ (gt-update-state translator)
+ (gt-output render translator))
+ (gt-log 'next (format "%s: [----- error -----] %s" id error))
+ (gt-log nil 1 (with-temp-buffer
+ (let ((standard-output (current-buffer)))
+ (backtrace)
+ (buffer-string))))))
+
+(cl-defgeneric gt-reset (translator)
+ "Reset status and other variables before translation for TRANSLATOR."
+ (:method ((translator gt-translator))
+ (gt-log-funcall "reset (%s)" translator)
+ (unless gt-default-cacher
+ (setq gt-default-cacher (gt-memory-cacher)))
+ (unless gt-default-http-client
+ (setq gt-default-http-client (gt-url-http-client)))
+ (with-slots (version state tasks bag total taker engines render _taker _engines _render) translator
+ (unless (slot-boundp translator '_taker)
+ (unless taker (setf taker (gt-taker)))
+ (unless render (setf render (gt-render)))
+ (setf _taker taker _engines engines _render render))
+ (setf version (time-to-seconds) state 0 tasks nil total 0 taker nil engines nil render nil bag nil))))
+
+(cl-defmethod gt-init ((translator gt-translator) &rest _)
+ "Initialize the components, text and target for TRANSLATOR."
+ (gt-log-funcall "init (%s)" translator)
+ (with-slots (keep text bounds target version taker engines render _taker _engines _render) translator
+ ;; reset
+ (gt-reset translator)
+ ;; take
+ (unless keep (setf text nil bounds nil target nil))
+ (setf taker (or (cl-find-if (lambda (tk) (gt-valid tk translator))
+ (ensure-list (gt-ensure-plain _taker)))
+ (user-error "No taker found in this translator")))
+ (gt-take taker translator)
+ (setf keep nil)
+ (let ((history-delete-duplicates t))
+ (add-to-history 'gt-target-history target 8))
+ ;; prepare engines and render
+ (setf engines (ensure-list (gt-ensure-plain _engines)))
+ (setf render (cl-find-if (lambda (rd) (gt-valid rd translator))
+ (ensure-list (gt-ensure-plain _render))))
+ ;; log
+ (gt-log 'translator (format "version: %s\ntarget: %s\nbounds: %s\ntext: %s\ntaker: %s, engines: %s, render: %s"
+ version target bounds text
+ (gt-desc taker)
+ (mapcar (lambda (en) (oref en tag)) engines)
+ (gt-desc render)))))
+
+(cl-defgeneric gt-start (translator)
+ "Start a new translation with TRANSLATOR."
+ (gt-log "\n\n")
+ (gt-log-funcall "start (%s)" translator)
+ (setq gt-current-command this-command)
+ (setq gt-current-translator translator)
+ ;; init
+ (gt-init translator nil)
+ (with-slots (text target version total engines render) translator
+ ;; tasks
+ (cl-loop for engine in engines
+ do (cl-loop for tgt in (cdr target)
+ for task = (gt-task
+ :text text
+ :src (car target)
+ :tgt tgt
+ :engine engine
+ :render render
+ :translator translator
+ :version version)
+ if (gt-valid engine task)
+ do (cl-incf total) and do (gt-add-task task))
+ finally (gt-update-state translator))
+ (when (zerop total)
+ (user-error "No task created, please check engines and langs setup"))
+ ;; translate
+ (if render (gt-init render translator))
+ (cl-loop for task in (oref translator tasks)
+ do (condition-case err
+ (gt-translate (oref task engine) task)
+ (error (gt-fail task err))))))
+
+(provide 'gt-core)
+
+;;; gt-core.el ends here
--- /dev/null
+;;; gt-engine-bing.el --- Microsoft Translate -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; https://bing.com/translator
+
+;;; Code:
+
+(require 'gt-extension)
+
+(defgroup go-translate-bing nil
+ "Configs for Bing engine."
+ :group 'go-translate)
+
+\f
+
+(defclass gt-bing-parser (gt-parser) ())
+
+(defclass gt-bing-engine (gt-engine)
+ ((tag :initform 'Bing)
+ (host :initform "https://www.bing.com")
+ (host-tld :initform nil)
+ (ig :initform nil)
+ (key :initform nil)
+ (token :initform nil)
+ (last-time :initform nil)
+ (expired-time :initform (* 30 60))
+ (parse :initform (gt-bing-parser))))
+
+\f
+;;; Translate
+
+(defvar gt-bing-extra-langs-mapping '((zh . "zh-Hans")))
+
+(defvar gt-bing-token-maybe-invalid nil)
+
+(defun gt-bing-get-lang (lang)
+ (or (cdr-safe (assoc lang gt-bing-extra-langs-mapping)) lang))
+
+(defun gt-bing-with-token (engine done)
+ (declare (indent 1))
+ (with-slots (ig key token host host-tld last-time expired-time) engine
+ (if (and token key ig last-time (not gt-bing-token-maybe-invalid)
+ (< (- (time-to-seconds) last-time) expired-time))
+ (funcall done)
+ (gt-request :url (concat host "/translator")
+ :done (lambda (raw)
+ (with-temp-buffer
+ (insert raw)
+ (goto-char (point-min))
+ (re-search-forward "IG:\"\\([A-Za-z0-9]+\\)\"")
+ (setf ig (match-string 1))
+ (re-search-forward "curUrl=\"\\(http[a-z]*\\).*?\\([a-zA-Z]+\\.bing.com\\)")
+ (setf host-tld (concat (match-string 1) "://" (match-string 2)))
+ (re-search-forward "var params_AbusePreventionHelper = \\[\\([0-9]+\\), *\"\\([^\"]+\\)")
+ (setf key (match-string 1) token (match-string 2))
+ (setf last-time (time-to-seconds))
+ (setq gt-bing-token-maybe-invalid nil)
+ (gt-log 'bing (format "url: %s\nkey: %s\ntoken: %s\nig: %s" host-tld key token ig))
+ (funcall done)))
+ :fail (lambda (err) (user-error "[BING] Get Token failed. %s" err))))))
+
+(cl-defmethod gt-translate ((engine gt-bing-engine) task next)
+ (gt-bing-with-token engine
+ (lambda ()
+ (with-slots (text src tgt res) task
+ (with-slots (host-tld ig key token) engine
+ (gt-request :url (format "%s/ttranslatev3?isVertical=1&IID=translator.5022.1&IG=%s" host-tld ig)
+ :headers `(("Content-Type" . "application/x-www-form-urlencoded;charset=UTF-8"))
+ :data `(("fromLang" . ,(gt-bing-get-lang src))
+ ("to" . ,(gt-bing-get-lang tgt))
+ ("text" . ,text)
+ ("key" . ,key)
+ ("token" . ,token))
+ :done (lambda (raw)
+ (setf res raw)
+ (funcall next task))
+ :fail (lambda (err)
+ (gt-fail task
+ (pcase (car-safe (cdr-safe err))
+ (429 "[429] Too many requests! Please try later")
+ (_ err))))))))))
+
+(cl-defmethod gt-parse ((_ gt-bing-parser) task)
+ (with-slots (res err) task
+ (if-let* ((json (json-read-from-string (decode-coding-string res 'utf-8)))
+ (result (ignore-errors (cdr (assoc 'text (aref (cdr (assoc 'translations (aref json 0))) 0))))))
+ (setf res result)
+ (setq gt-bing-token-maybe-invalid t) ; refresh token when error occurred
+ (setf err res)
+ (error "error %s" res))))
+
+\f
+;;; Text to Speech
+
+(defcustom gt-bing-tts-speed 1.0
+ "Playing speed of TTS audio, 1.0 is normal speed."
+ :type 'number
+ :group 'go-translate-bing)
+
+(defvar gt-bing-tts-mapping '((zh . ("zh-CN" "Female" "zh-CN-XiaoxiaoNeural"))
+ (en . ("en-US" "Female" "en-US-AriaNeural"))
+ (af . ("af-ZA" "Female" "af-ZA-AdriNeural"))
+ (am . ("am-ET" "Female" "am-ET-MekdesNeural"))
+ (ar . ("ar-SA" "Male" "ar-SA-HamedNeural"))
+ (bn . ("bn-IN" "Female" "bn-IN-TanishaaNeural"))
+ (bg . ("bg-BG" "Male" "bg-BG-BorislavNeural"))
+ (ca . ("ca-ES" "Female" "ca-ES-JoanaNeural"))
+ (cs . ("cs-CZ" "Male" "cs-CZ-AntoninNeural"))
+ (cy . ("cy-GB" "Female" "cy-GB-NiaNeural"))
+ (da . ("da-DK" "Female" "da-DK-ChristelNeural"))
+ (de . ("de-DE" "Female" "de-DE-KatjaNeural"))
+ (el . ("el-GR" "Male" "el-GR-NestorasNeural"))
+ (es . ("es-ES" "Female" "es-ES-ElviraNeural"))
+ (et . ("et-EE" "Female" "et-EE-AnuNeural"))
+ (fa . ("fa-IR" "Female" "fa-IR-DilaraNeural"))
+ (fi . ("fi-FI" "Female" "fi-FI-NooraNeural"))
+ (fr . ("fr-FR" "Female" "fr-FR-DeniseNeural"))
+ (ga . ("ga-IE" "Female" "ga-IE-OrlaNeural"))
+ (gu . ("gu-IN" "Female" "gu-IN-DhwaniNeural"))
+ (he . ("he-IL" "Male" "he-IL-AvriNeural"))
+ (hi . ("hi-IN" "Female" "hi-IN-SwaraNeural"))
+ (hr . ("hr-HR" "Male" "hr-HR-SreckoNeural"))
+ (hu . ("hu-HU" "Male" "hu-HU-TamasNeural"))
+ (id . ("id-ID" "Male" "id-ID-ArdiNeural"))
+ (is . ("is-IS" "Female" "is-IS-GudrunNeural"))
+ (it . ("it-IT" "Male" "it-IT-DiegoNeural"))
+ (ja . ("ja-JP" "Female" "ja-JP-NanamiNeural"))
+ (kk . ("kk-KZ" "Female" "kk-KZ-AigulNeural"))
+ (km . ("km-KH" "Female" "km-KH-SreymomNeural"))
+ (kn . ("kn-IN" "Female" "kn-IN-SapnaNeural"))
+ (ko . ("ko-KR" "Female" "ko-KR-SunHiNeural"))
+ (lo . ("lo-LA" "Female" "lo-LA-KeomanyNeural"))
+ (lv . ("lv-LV" "Female" "lv-LV-EveritaNeural"))
+ (lt . ("lt-LT" "Female" "lt-LT-OnaNeural"))
+ (mk . ("mk-MK" "Female" "mk-MK-MarijaNeural"))
+ (ml . ("ml-IN" "Female" "ml-IN-SobhanaNeural"))
+ (mr . ("mr-IN" "Female" "mr-IN-AarohiNeural"))
+ (ms . ("ms-MY" "Male" "ms-MY-OsmanNeural"))
+ (mt . ("mt-MT" "Female" "mt-MT-GraceNeural"))
+ (my . ("my-MM" "Female" "my-MM-NilarNeural"))
+ (nl . ("nl-NL" "Female" "nl-NL-ColetteNeural"))
+ (nb . ("nb-NO" "Female" "nb-NO-PernilleNeural"))
+ (pl . ("pl-PL" "Female" "pl-PL-ZofiaNeural"))
+ (ps . ("ps-AF" "Female" "ps-AF-LatifaNeural"))
+ (pt . ("pt-BR" "Female" "pt-BR-FranciscaNeural"))
+ (ro . ("ro-RO" "Male" "ro-RO-EmilNeural"))
+ (ru . ("ru-RU" "Female" "ru-RU-DariyaNeural"))
+ (sk . ("sk-SK" "Male" "sk-SK-LukasNeural"))
+ (sl . ("sl-SI" "Male" "sl-SI-RokNeural"))
+ (sv . ("sv-SE" "Female" "sv-SE-SofieNeural"))
+ (ta . ("ta-IN" "Female" "ta-IN-PallaviNeural"))
+ (te . ("te-IN" "Male" "te-IN-ShrutiNeural"))
+ (th . ("th-TH" "Male" "th-TH-NiwatNeural"))
+ (tr . ("tr-TR" "Female" "tr-TR-EmelNeural"))
+ (uk . ("uk-UA" "Female" "uk-UA-PolinaNeural"))
+ (ur . ("ur-IN" "Female" "ur-IN-GulNeural"))
+ (uz . ("uz-UZ" "Female" "uz-UZ-MadinaNeural"))
+ (vi . ("vi-VN" "Male" "vi-VN-NamMinhNeural"))
+ (yue . ("zh-HK" "Female" "zh-HK-HiuGaaiNeural"))))
+
+(cl-defmethod gt-bing-tts-payload (lang text)
+ (let ((lm (assoc lang gt-bing-tts-mapping)))
+ (unless lm (user-error "Add the mapping of your language into `gt-bing-tts-langs-mapping' :)"))
+ (format "<speak version='1.0' xml:lang='%s'><voice xml:lang='%s' xml:gender='%s' name='%s'><prosody rate='%s'>%s</prosody></voice></speak>"
+ (cadr lm) (caddr lm) (cadr lm) (cadddr lm)
+ gt-bing-tts-speed (encode-coding-string text 'utf-8))))
+
+(cl-defmethod gt-speak ((engine gt-bing-engine) text lang)
+ (with-slots (host host-tld ig key token) engine
+ (message "Requesting from %s for %s..." (or host-tld host) lang)
+ (gt-bing-with-token engine
+ (lambda ()
+ (gt-request :url (format "%s/tfettts?isVertical=1&IID=translator.5022.2&IG=%s" host-tld ig)
+ :headers '(("content-type" . "application/x-www-form-urlencoded"))
+ :data `(("token" . ,token) ("key" . ,key) ("ssml" . ,(gt-bing-tts-payload lang text)))
+ :cache (length text)
+ :done #'gt-play-audio
+ :fail (lambda (err) (message "[BING-TTS] error in request, %s" err)))))))
+
+(provide 'gt-engine-bing)
+
+;;; gt-engine-bing.el ends here
--- /dev/null
+;;; gt-engine-chatgpt.el --- Engine for ChatGPT -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; https://platform.openai.com/docs/api-reference
+
+;;; Code:
+
+(require 'gt-extension)
+
+(defgroup go-translate-chatgpt nil
+ "Configs for ChatGPT engine."
+ :group 'go-translate)
+
+\f
+;;; Components
+
+(defclass gt-chatgpt-engine (gt-engine)
+ ((tag :initform 'ChatGPT)
+ (host :initarg :host :initform nil)
+ (model :initarg :model :initform nil)
+ (temperature :initarg :temperature :initform nil)
+ (key :initarg :key :initform 'apikey
+ :documentation "The apikey of ChatGPT.
+Can also put into .authinfo file as:
+ machine api.openai.com login apikey password ***")))
+
+\f
+;;; Translate
+
+(defcustom gt-chatgpt-host "https://api.openai.com"
+ "API host of ChatGPT."
+ :type 'string
+ :group 'go-translate-chatgpt)
+
+(defcustom gt-chatgpt-key nil
+ "Auth Key of ChatGPT. Recommend to save in .authinfo file instead."
+ :type 'string
+ :group 'go-translate-chatgpt)
+
+(defcustom gt-chatgpt-model "gpt-3.5-turbo"
+ "Model to be used in chat."
+ :type 'string
+ :group 'go-translate-chatgpt)
+
+(defcustom gt-chatgpt-temperature 0.8
+ "Temperature of ChatGPT."
+ :type 'number
+ :group 'go-translate-chatgpt)
+
+(defcustom gt-chatgpt-system-prompt "You are a translation assistant"
+ "System prompt send to server when translation."
+ :type 'string
+ :group 'go-translate-chatgpt)
+
+(defcustom gt-chatgpt-user-prompt-template "Translate the text to %s, text is: \n%s"
+ "Template for user prompt when translation.
+When it is string, %s is placeholders of lang and text.
+When it is function, arguments passed to it should be text and lang."
+ :type '(choice string function)
+ :group 'go-translate-chatgpt)
+
+(declare-function pulse-momentary-highlight-region "pulse")
+
+(defvar gt-chatgpt-streaming-finished-hook #'pulse-momentary-highlight-region
+ "The logic runs after all streams finished.
+With two arguments BEG and END, which are the marker bounds of the result.")
+
+(cl-defmethod gt-ensure-key ((engine gt-chatgpt-engine))
+ (with-slots (host key) engine
+ (unless (stringp key)
+ (if-let (apikey (or (gt-lookup-password
+ :user (if key (format "%s" key) "apikey")
+ :host (url-host (url-generic-parse-url (or host gt-chatgpt-host))))
+ gt-chatgpt-key))
+ (setf key apikey)
+ (user-error "You should provide a apikey for gt-chatgpt-engine")))))
+
+(cl-defmethod gt-translate ((engine gt-chatgpt-engine) task next)
+ (gt-ensure-key engine)
+ (with-slots (text src tgt res translator markers) task
+ (with-slots (host key model temperature stream) engine
+ (when (and stream (cdr (oref translator text)))
+ (user-error "Multiple parts not support streaming"))
+ (gt-request :url (concat (or host gt-chatgpt-host) "/v1/chat/completions")
+ :headers `(("Content-Type" . "application/json")
+ ("Authorization" . ,(concat "Bearer " (encode-coding-string key 'utf-8))))
+ :data (encode-coding-string
+ (json-encode
+ `((model . ,(or model gt-chatgpt-model))
+ (temperature . ,(or temperature gt-chatgpt-temperature))
+ (stream . ,stream)
+ (messages . [((role . system)
+ (content . ,gt-chatgpt-system-prompt))
+ ((role . user)
+ (content . ,(if (functionp gt-chatgpt-user-prompt-template)
+ (funcall gt-chatgpt-user-prompt-template text tgt)
+ (format gt-chatgpt-user-prompt-template (alist-get tgt gt-lang-codes) text))))])))
+ 'utf-8)
+ :filter (when stream
+ (lambda ()
+ (unless gt-tracking-marker
+ (setq gt-tracking-marker (make-marker))
+ (set-marker gt-tracking-marker (point-min)))
+ (goto-char gt-tracking-marker)
+ (condition-case err
+ (while (re-search-forward "^data: +\\({.+}\\)" nil t)
+ (let* ((json (json-read-from-string (decode-coding-string (match-string 1) 'utf-8)))
+ (choice (aref (alist-get 'choices json) 0))
+ (content (alist-get 'content (alist-get 'delta choice)))
+ (finish (alist-get 'finish_reason choice)))
+ (if finish
+ (progn (message "")
+ (when gt-chatgpt-streaming-finished-hook
+ (with-current-buffer (marker-buffer (car markers))
+ (funcall gt-chatgpt-streaming-finished-hook (car markers) (cdr markers)))))
+ (setf res (concat res content))
+ (set-marker gt-tracking-marker (point))
+ (unless (string-blank-p (concat res))
+ (funcall next task)))))
+ (error (unless (string-prefix-p "json" (format "%s" (car err)))
+ (signal (car err) (cdr err)))))))
+ :done (unless stream
+ (lambda (raw)
+ (with-slots (res) task
+ (let* ((json (json-read-from-string raw))
+ (str (alist-get 'content (alist-get 'message (let-alist json (aref .choices 0))))))
+ (setf res str))
+ (funcall next task))))
+ :fail (lambda (err) (gt-fail task err))))))
+
+(cl-defmethod gt-stream-p ((engine gt-chatgpt-engine))
+ (oref engine stream))
+
+\f
+;;; Text to Speech
+
+(defcustom gt-chatgpt-tts-model "tts-1"
+ "Model used by TTS of ChatGPT."
+ :type 'string
+ :group 'go-translate-chatgpt)
+
+(defcustom gt-chatgpt-tts-speed 1.0
+ "Speech speed of return audio from ChatGPT."
+ :type 'number
+ :group 'go-translate-chatgpt)
+
+(defcustom gt-chatgpt-tts-voice "alloy"
+ "Which voice to use by ChatGPT Speech.
+alloy, echo, fable, onyx, nova, or shimmer."
+ :type 'string
+ :group 'go-translate-chatgpt)
+
+(cl-defmethod gt-speak ((engine gt-chatgpt-engine) text _lang)
+ (gt-ensure-key engine)
+ (with-slots (host key) engine
+ (gt-request :url (concat (or host gt-chatgpt-host) "/v1/audio/speech")
+ :headers `(("Content-Type" . "application/json")
+ ("Authorization" . ,(concat "Bearer " key)))
+ :data (json-encode
+ `((input . ,text)
+ (model . ,gt-chatgpt-tts-model)
+ (speed . ,gt-chatgpt-tts-speed)
+ (voice . ,gt-chatgpt-tts-voice)))
+ :done #'gt-play-audio
+ :cache (length text))))
+
+(provide 'gt-engine-chatgpt)
+
+;;; gt-engine-chatgpt.el ends here
--- /dev/null
+;;; gt-engine-deepl.el --- Translate Engine for DeepL -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; https://www.deepl.com
+
+;;; Code:
+
+(require 'gt-extension)
+
+(defgroup go-translate-deepl nil
+ "Configs for DeepL engine."
+ :group 'go-translate)
+
+\f
+;;; Components
+
+(defclass gt-deepl-parser (gt-parser) ())
+
+(defclass gt-deepl-engine (gt-engine)
+ ((tag :initform 'DeepL)
+ (host :initform "https://api.deepl.com")
+ (host-free :initform "https://api-free.deepl.com")
+ (path :initform "/v2/translate")
+ (parse :initform (gt-deepl-parser))
+
+ (pro :initform nil
+ :initarg :pro
+ :documentation "Set t when use PRO version.")
+
+ (key :initform 'auth-key
+ :initarg :key
+ :documentation "The auth-key of DeepL.
+You can also put it into .authinfo file as:
+ machine api.deepl.com login auth-key password ***")))
+
+\f
+;;; Utils
+
+(defcustom gt-deepl-fill-enable t
+ "Controller whether try to improve the input and output.
+Default behavior is removing excess linebreaks in input for better
+translation effect, and filling the output for better reading experience.
+You can override the behaviors by :around the method `gt-deepl-fill-input'
+or `gt-deepl-fill-output'."
+ :type 'boolean
+ :group 'go-translate-deepl)
+
+(cl-defmethod gt-deepl-fill-input (text)
+ "Improve the input TEXT for better translation effect.
+Mainly remove excess linebreaks. I want to skip unfill on comments and codes,
+but don't know how to implement easily. To make it better later, maybe."
+ (if gt-deepl-fill-enable
+ (with-temp-buffer
+ (insert text)
+ (let ((fill-column (* 2 (point-max))))
+ (fill-region (point-min) (point-max)))
+ (buffer-string))
+ text))
+
+(cl-defmethod gt-deepl-fill-output (text)
+ "Improve the output TEXT for better reading experience.
+Mainly fill the text to suitable length."
+ (if gt-deepl-fill-enable
+ (with-temp-buffer
+ (insert text)
+ (fill-region (point-min) (point-max))
+ (buffer-string))
+ text))
+
+\f
+;;; Engine
+
+(defcustom gt-deepl-extra-params '(("split_sentences" . "1")
+ ("preserve_formatting" . "1"))
+ "Extra translation params send to DeepL server."
+ :type '(alist :key-type (string :tag "Key")
+ :value-type (string :tag "Value"))
+ :group 'go-translate-deepl)
+
+(defvar gt-deepl-langs-mapping '((en . "EN")
+ (zh . "ZH")
+ (de . "DE") ; German
+ (fr . "FR") ; French
+ (it . "IT") ; Italian
+ (ja . "JA") ; Japanese
+ (es . "ES") ; Spanish
+ (nl . "NL") ; Dutch
+ (pl . "PL") ; Polish
+ (pt . "PT") ; Portuguese (all Portuguese varieties mixed)
+ (ru . "RU") ; Russian
+ ))
+
+(defun gt-deepl-get-lang (lang)
+ (if-let (mapping (assoc lang gt-deepl-langs-mapping))
+ (cdr mapping)
+ (user-error "Language %s is not supported by DeepL.
+Supported list: %s" lang (mapconcat #'car gt-deepl-langs-mapping ", "))))
+
+(cl-defmethod gt-ensure-key ((engine gt-deepl-engine))
+ (with-slots (key) engine
+ (unless (stringp key)
+ (if-let (auth-key (gt-lookup-password
+ :user (if key (format "%s" key) "auth-key")
+ :host "api.deepl.com"))
+ (setf key auth-key)
+ (user-error "You should provide a auth-key for gt-deepl-engine")))))
+
+(cl-defmethod gt-translate ((engine gt-deepl-engine) task next)
+ (gt-ensure-key engine)
+ (with-slots (text src tgt res) task
+ (with-slots (host host-free path pro key) engine
+ (gt-request :url (concat (if pro host host-free) path)
+ :headers `(("Content-Type" . "application/x-www-form-urlencoded;charset=UTF-8")
+ ("Authorization" . ,(concat "DeepL-Auth-Key " key)))
+ :data `(("text" . ,(gt-deepl-fill-input text))
+ ("target_lang" . ,(gt-deepl-get-lang tgt))
+ ,(if-let (src (gt-deepl-get-lang src)) `("source_lang" . ,src))
+ ,@gt-deepl-extra-params)
+ :done (lambda (raw)
+ (setf res raw)
+ (funcall next task))
+ :fail (lambda (err)
+ (gt-fail task (pcase (car-safe (cdr-safe err))
+ (403 "[403] Authorization failed. Please supply a valid auth_key parameter")
+ (413 "[413] The request size exceeds the limit")
+ (414 "[414] Request-URI Too Long")
+ (429 "[429] Too many requests. Please wait and resend your request")
+ (456 "[456] Quota exceeded. The character limit has been reached")
+ (_ err))))))))
+
+\f
+;;; Parser
+
+(cl-defmethod gt-parse ((_ gt-deepl-parser) task)
+ (with-slots (res meta) task
+ (let* ((json (json-read-from-string res))
+ (str (decode-coding-string (mapconcat #'cdadr (cdar json) "\n") 'utf-8))
+ (hook (lambda (rs) (mapcar #'gt-deepl-fill-output rs))))
+ (setf res str meta (plist-put meta :res-hook hook)))))
+
+(provide 'gt-engine-deepl)
+
+;;; gt-engine-deepl.el ends here
--- /dev/null
+;;; gt-engine-echo.el --- Echo Translate -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; For simple transform, and for test.
+
+;;; Code:
+
+(require 'gt-extension)
+
+(defclass gt-echo-engine (gt-engine)
+ ((tag :initform 'Echo)
+ (do :initform nil :initarg :do)))
+
+(cl-defmethod initialize-instance :after ((engine gt-echo-engine) &rest _)
+ (with-slots (cache delimiter) engine
+ (setf cache nil delimiter nil)))
+
+(cl-defmethod gt-translate ((engine gt-echo-engine) task next)
+ (with-slots (text res) task
+ (with-slots (do) engine
+ (setf res text)
+ (cl-labels ((process (sym)
+ (cond ((eq sym 'clean)
+ (setf res (mapcar #'substring-no-properties res)))
+ ((eq sym 'br)
+ (setf res (mapcar #'gt-prop-for-bionic-reading res)))
+ ((functionp sym)
+ (setf res (funcall sym res)))
+ ((consp sym)
+ (cl-loop for o in sym do (process o))))))
+ (process do)
+ (funcall next task)))))
+
+\f
+
+(defun gt-prop-for-bionic-reading (text)
+ (with-temp-buffer
+ (insert text)
+ (goto-char (point-min))
+ (skip-chars-forward " \t\n\r\f")
+ (while (forward-word)
+ (cl-destructuring-bind (beg . end) (bounds-of-thing-at-point 'word)
+ (setq end (+ beg (/ (- end beg) 2)))
+ (put-text-property beg end 'font-lock-face 'gt-bionic-reading-face)))
+ (buffer-string)))
+
+(provide 'gt-engine-echo)
+
+;;; gt-engine-echo.el ends here
--- /dev/null
+;;; gt-engine-google-rpc.el --- Google translation with RPC API -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; http://translate.google.com, new RPC API
+
+;;; Code:
+
+(require 'gt-engine-google)
+
+(defgroup go-translate-google-rpc nil
+ "Configs for GoogleRPC engine."
+ :group 'go-translate)
+
+(defcustom gt-google-rpc-host "https://translate.google.com"
+ "The base url of Google translate used by google-rpc engine.
+you can customize it according to your country region."
+ :type 'string
+ :group 'go-translate-google-rpc)
+
+\f
+;;; Components
+
+(defclass gt-google-rpc-parser (gt-google-parser)
+ ((tag :initform "Detail")))
+
+(defclass gt-google-rpc-summary-parser (gt-google-summary-parser gt-google-rpc-parser)
+ ((tag :initform "Summary")))
+
+(defclass gt-google-rpc-engine (gt-engine)
+ ((tag :initform 'GoogleRPC)
+ (host :initform nil)
+ (path :initform "/_/TranslateWebserverUi/data/batchexecute")
+ (parse :initform (gt-google-rpc-parser))
+
+ (rpc-translate :initform "MkEWBc")
+ (rpc-tts :initform "jQ1olc")
+ (rpc-sid :initform "FdrFJe")
+ (rpc-bl :initform "cfb2h")))
+
+\f
+;;; Engine
+
+(defcustom gt-google-rpc-request-headers
+ '(("Connection" . "Keep-Alive")
+ ("Content-Type" . "application/x-www-form-urlencoded;charset=UTF-8"))
+ "Extra request headers send to google-rpc server."
+ :type '(alist :key-type (string :tag "Key") :value-type (string :tag "Value"))
+ :group 'go-translate-google-rpc)
+
+(defun gt-google-rpc-with-token (engine done fail)
+ (declare (indent 1))
+ (with-slots (host path rpc-sid rpc-bl) engine
+ (gt-request :url (or host gt-google-rpc-host)
+ :done (lambda (raw)
+ (with-temp-buffer
+ (insert raw)
+ (goto-char (point-min))
+ (let* ((f-sid (progn
+ (re-search-forward (format "\"%s\":\"\\([^\"]*\\)\"" rpc-sid))
+ (match-string 1)))
+ (bl (progn (re-search-forward (format "\"%s\":\"\\([^\"]*\\)\"" rpc-bl))
+ (match-string 1)))
+ (url-tpl (lambda (rpcid lang)
+ (format "%s%s?%s" (or host gt-google-rpc-host) path
+ (gt-format-params
+ `(("rpcids" . ,rpcid)
+ ("f.sid" . ,f-sid)
+ ("bl" . ,bl)
+ ("hl" . ,lang)
+ ("soc-app" . 1)
+ ("soc-platform" . 1)
+ ("soc-device" . 1)
+ ("_reqid" . ,(+ 1000 (random 9000)))
+ ("rt" . "c")))))))
+ (funcall done url-tpl))))
+ :fail fail)))
+
+(cl-defmethod gt-translate ((engine gt-google-rpc-engine) task next)
+ (gt-google-rpc-with-token engine
+ (lambda (url-tpl)
+ (with-slots (text src tgt res) task
+ (with-slots (rpc-translate) engine
+ (gt-request :url (funcall url-tpl rpc-translate tgt)
+ :headers gt-google-rpc-request-headers
+ :data (format
+ "f.req=%s&"
+ (url-hexify-string
+ (json-encode `[[[,rpc-translate ,(json-encode `[[,text ,src ,tgt 1][]]) nil "generic"]]])))
+ :done (lambda (raw) (setf res raw) (funcall next task))
+ :fail (lambda (err) (gt-fail task err))))))
+ (lambda (err)
+ (gt-fail task (format "Take token failed, %s" err)))))
+
+(cl-defmethod gt-speak ((engine gt-google-rpc-engine) text lang)
+ (with-slots (host rpc-tts) engine
+ (message "Requesting %s for %s..." (or host gt-google-rpc-host) lang)
+ (gt-google-rpc-with-token engine
+ (lambda (url-tpl)
+ (gt-request :url (funcall url-tpl rpc-tts "en-US")
+ :headers gt-google-rpc-request-headers
+ :data (format
+ "f.req=%s&"
+ (url-hexify-string
+ (json-encode `[[[,rpc-tts ,(json-encode `[,text ,lang nil "undefined" [0]]) nil "generic"]]])))
+ :done (lambda (raw)
+ (with-temp-buffer
+ (insert raw)
+ (goto-char (point-min))
+ (let (beg end json code)
+ (re-search-forward "^[0-9]+$")
+ (setq beg (point))
+ (re-search-forward "^\\([0-9]+\\)$")
+ (setq end (- (point) (length (match-string 1))))
+ (setq json (json-read-from-string (string-trim (buffer-substring-no-properties beg end))))
+ (if-let (data (and (string= (gt-aref json 0 0) "wrb.fr") (gt-aref json 0 2)))
+ (progn (setq code (aref (json-read-from-string data) 0))
+ (erase-buffer)
+ (insert code)
+ (base64-decode-region (point-min) (point-max))
+ (gt-play-audio (current-buffer)))
+ (message "[GoogleRPC-TTS] No tts data responsed")))))
+ :fail (lambda (err) (message "[GoogleRPC-TTS] Error, %s" err))))
+ (lambda (err) (message "[GoogleRPC-TTS] Take token failed, %s" err)))))
+
+\f
+;;; Parser
+
+(cl-defmethod gt-resp-to-json ((_ gt-google-rpc-parser) resp)
+ "Convert the buffer RESP into JSON format."
+ (condition-case err
+ (with-temp-buffer
+ (let (beg end str json)
+ (insert resp)
+ (goto-char (point-min))
+ (re-search-forward "^[0-9]+$")
+ (setq beg (point))
+ (re-search-forward "^\\([0-9]+\\)$")
+ (setq end (- (point) (length (match-string 1))))
+ (setq str
+ (decode-coding-string
+ (string-trim (buffer-substring-no-properties beg end))
+ 'utf-8))
+ (setq json (json-read-from-string str))
+ (if (string= (aref (aref json 0) 0) "wrb.fr")
+ (let ((json-str (aref (aref json 0) 2)))
+ (json-read-from-string json-str))
+ (error "No results found"))))
+ (error (user-error "Result conversion error (%s)" err))))
+
+(cl-defmethod gt-result--brief ((_ gt-google-rpc-parser) json)
+ "Get the translation text from JSON."
+ (mapconcat
+ (lambda (item)
+ (if (ignore-errors (aref item 2))
+ (format " %s" (aref item 0))
+ (aref item 0)))
+ (gt-aref json 1 0 0 5)
+ ""))
+
+(cl-defmethod gt-result--sphonetic ((_ gt-google-rpc-parser) json)
+ "Get the text phonetic from JSON."
+ (gt-aref json 0 0))
+
+(cl-defmethod gt-result--tphonetic ((_ gt-google-rpc-parser) json)
+ "Get the translation phonetic from JSON."
+ (gt-aref json 1 0 0 1))
+
+(cl-defmethod gt-result--details ((_ gt-google-rpc-parser) json)
+ "Get the details from JSON.
+Result style: ((noun (a (x y z))) (verb (b (m n o))))."
+ (cl-loop with dts = (ignore-errors (gt-aref json 3 5 0))
+ for i across dts
+ collect
+ (cons
+ (aref i 0)
+ (cl-loop for j across (aref i 1)
+ collect
+ (cons
+ (aref j 0)
+ (cl-loop for k across (aref j 2) collect k))))))
+
+(cl-defmethod gt-result--definitions ((_ gt-google-rpc-parser) json)
+ "Get the definitions from JSON.
+Result style: ((noun (a b)) (verb (c d)))."
+ (cl-loop with defs = (ignore-errors (gt-aref json 3 1 0))
+ for i across defs
+ collect
+ (cons
+ (aref i 0)
+ (cl-loop for j across (aref i 1)
+ collect
+ (cons (aref j 0)
+ (ignore-errors (aref j 1)))))))
+
+(cl-defmethod gt-result--suggestion ((_ gt-google-rpc-parser) json)
+ "Get the suggestion from JSON."
+ (ignore-errors
+ (replace-regexp-in-string "<b>\\|</b>\\|<i>\\|</i>" "" (gt-aref json 0 1 0 0 1))))
+
+(provide 'gt-engine-google-rpc)
+
+;;; gt-engine-google-rpc.el ends here
--- /dev/null
+;;; gt-engine-google.el --- Google translate -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; http://translate.google.com
+
+;;; Code:
+
+(require 'gt-extension)
+
+(defgroup go-translate-google nil
+ "Configs for Google engine."
+ :group 'go-translate)
+
+(defcustom gt-google-host "http://translate.googleapis.com"
+ "The base url of Google translate used by google engine.
+you can customize it according to your country region."
+ :type 'string
+ :group 'go-translate-google)
+
+\f
+;;; Components
+
+(defclass gt-google-parser (gt-parser)
+ ((tag :initform "Detail")))
+
+(defclass gt-google-summary-parser (gt-google-parser)
+ ((tag :initform "Summary")))
+
+(defclass gt-google-engine (gt-engine)
+ ((tag :initform 'Google)
+ (host :initform nil)
+ (path :initform "/translate_a/single")
+ (token :initform (cons 430675 2721866130) :initarg token) ; hard code
+ (token-time :initform t)
+ (token-expired-time :initform (* 30 60))
+ (parse :initform (gt-google-parser))))
+
+\f
+;;; Engine
+
+(defcustom gt-google-request-headers '(("Connection" . "Keep-Alive"))
+ "Extra request headers send to google server."
+ :type '(alist :key-type (string :tag "Key") :value-type (string :tag "Value"))
+ :group 'go-translate-google)
+
+(defun gt-google-gen-url (engine text src tgt)
+ "Generate url for google ENGINE with TEXT, SRC and TGT."
+ (with-slots (host path token) engine
+ (format "%s%s?%s"
+ (or host gt-google-host) path
+ (mapconcat (lambda (p)
+ (format "%s=%s"
+ (url-hexify-string (car p))
+ (url-hexify-string (format "%s" (cdr p)))))
+ `(("client" . "gtx")
+ ("ie" . "UTF-8")
+ ("oe" . "UTF-8")
+ ("dt" . "bd")
+ ("dt" . "ex")
+ ("dt" . "ld")
+ ("dt" . "md")
+ ("dt" . "qc")
+ ("dt" . "rw")
+ ("dt" . "rm")
+ ("dt" . "ss")
+ ("dt" . "t")
+ ("dt" . "at")
+ ("pc" . "1")
+ ("otf" . "1")
+ ("srcrom" . "1")
+ ("ssel" . "0")
+ ("tsel" . "0")
+ ("q" . ,text)
+ ("sl" . ,src)
+ ("tl" . ,tgt)
+ ("hl" . ,tgt)
+ ("tk" . ,(gt-google-tkk token text)))
+ "&"))))
+
+(defun gt-google-token-available-p (engine)
+ (with-slots (token token-time token-expired-time) engine
+ (and token
+ (or (eq token-time t)
+ (and token-time
+ (<= (float-time (time-subtract (current-time) token-time))
+ token-expired-time))))))
+
+(defun gt-google-with-token (engine done fail)
+ (declare (indent 1))
+ (with-slots (host token token-time) engine
+ (if (gt-google-token-available-p engine)
+ (funcall done)
+ (gt-request :url (or host gt-google-host)
+ :headers gt-google-request-headers
+ :done (lambda (raw)
+ (with-temp-buffer
+ (insert raw)
+ (goto-char (point-min))
+ (let ((tk (progn
+ (re-search-forward ",tkk:'\\([0-9]+\\)\\.\\([0-9]+\\)")
+ (cons (string-to-number (match-string 1))
+ (string-to-number (match-string 2))))))
+ (setf token tk)
+ (setf token-time (current-time))
+ (funcall done))))
+ :fail fail))))
+
+(cl-defmethod gt-translate ((engine gt-google-engine) task next)
+ (gt-google-with-token engine
+ (lambda ()
+ (with-slots (text src tgt res) task
+ (gt-request :url (gt-google-gen-url engine text src tgt)
+ :headers gt-google-request-headers
+ :done (lambda (raw) (setf res raw) (funcall next task))
+ :fail (lambda (err) (gt-fail task err)))))
+ (lambda (err)
+ (gt-fail task (format "Take token failed, %s" err)))))
+
+;; tts
+
+(defun gt-google-tts-split-text (text)
+ "Split TEXT by maxlen at applicable point for translating.
+Code from `google-translate', maybe improve it someday."
+ (let (result (maxlen 200))
+ (if (or (null maxlen) (<= maxlen 0))
+ (push text result)
+ ;; split long text?
+ (with-temp-buffer
+ (save-excursion (insert text))
+ ;; strategy to split at applicable point
+ ;; 1) fill-region remaining text by maxlen
+ ;; 2) find end of sentence, end of punctuation, word boundary
+ ;; 3) consume from remaining text between start and (2)
+ ;; 4) repeat
+ (let ((fill-column (* maxlen 3))
+ (sentence-end-double-space nil)
+ (pos (point-min)))
+ (while (< pos (point-max))
+ (save-restriction
+ (narrow-to-region pos (point-max))
+ (fill-region pos (point-max))
+ (let ((limit (+ pos maxlen)))
+ (if (>= limit (point-max))
+ (setq limit (point-max))
+ (goto-char limit)
+ ;; try to split at end of sentence
+ (if (> (backward-sentence) pos)
+ (setq limit (point))
+ ;; try to split at end of punctuation
+ (goto-char limit)
+ (if (re-search-backward "[,、]" pos t)
+ (setq limit (1+ (point))) ; include punctuation
+ (goto-char limit)
+ ;; try to split at word boundary
+ (forward-word-strictly -1)
+ (when (> (point) pos)
+ (setq limit (point))))))
+ (push (buffer-substring-no-properties pos limit) result)
+ (goto-char limit)
+ (setq pos limit)))))))
+ (reverse result)))
+
+(cl-defmethod gt-speak ((engine gt-google-engine) text lang)
+ (message "Requesting from %s for %s..." (or (oref engine host) gt-google-host) lang)
+ (cl-loop with texts = (gt-google-tts-split-text text)
+ with total = (length texts)
+ for c in texts
+ for i from 0
+ for ps = `(("ie" . "UTF-8")
+ ("client" . "gtx")
+ ("prev" . "input")
+ ("tl" . ,lang)
+ ("q" . ,(string-trim c))
+ ("total" . ,total)
+ ("idx" . ,i)
+ ("textlen" . ,(length c))
+ ("tk" . ,(gt-google-tkk (oref engine token) c)))
+ for url = (format "%s/translate_tts?%s"
+ (or (oref engine host) gt-google-host)
+ (mapconcat (lambda (p)
+ (format "%s=%s" (url-hexify-string (car p)) (url-hexify-string (format "%s" (cdr p)))))
+ ps "&"))
+ do (gt-play-audio url 'wait)))
+
+\f
+;;; Parser
+
+;; detail-mode, use as default
+
+(cl-defmethod gt-parse ((parser gt-google-parser) task)
+ (with-slots (res translator) task
+ (let* ((json (gt-resp-to-json parser res))
+ (brief-result (gt-result--brief parser json)))
+ (if (cdr (oref translator text)) ; multi-parts
+ (setf res (string-trim (gt-result--brief parser json) "\n+"))
+ (let* ((sphonetic (gt-result--sphonetic parser json))
+ (tphonetic (gt-result--tphonetic parser json))
+ (details (gt-result--details parser json))
+ (definitions (gt-result--definitions parser json))
+ (suggestion (gt-result--suggestion parser json))
+ (suggestionp (> (length suggestion) 0)) pt)
+ (cl-flet ((phonetic (ph)
+ (if (and (or definitions definitions) (> (length ph) 0))
+ (propertize (format " [%s]" ph) 'face 'gt-google-buffer-phonetic-face)
+ ""))
+ (headline (line)
+ (propertize (format "[%s]\n" line) 'face 'gt-google-buffer-headline-face)))
+ (with-temp-buffer
+ ;; suggestion
+ (when suggestionp
+ (insert (propertize "Do you mean:" 'face 'gt-google-buffer-suggestion-desc-face) " "
+ (propertize suggestion 'face 'gt-google-buffer-suggestion-text-face) "?\n\n"))
+ ;; phonetic & translate
+ (if (or details definitions)
+ (progn
+ (insert (if suggestionp suggestion
+ (setq pt (point))
+ (substring-no-properties (oref task text))))
+ (insert (phonetic sphonetic) " ")
+ (insert (propertize brief-result 'face 'gt-google-buffer-brief-result-face))
+ (insert (phonetic tphonetic) "\n\n"))
+ (insert brief-result))
+ ;; details
+ (when details
+ (insert (headline "Details"))
+ (cl-loop for (label . items) in details
+ unless (= 0 (length label))
+ do (insert (format "\n%s:\n" label))
+ do (cl-loop with index = 0
+ for trans in items
+ do (insert
+ (format "%2d. " (cl-incf index))
+ (car trans)
+ " (" (mapconcat #'identity (cdr trans) ", ") ")"
+ "\n")))
+ (insert "\n"))
+ ;; definitions
+ (when definitions
+ (insert (headline "Definitions"))
+ (cl-loop for (label . items) in definitions
+ unless (= 0 (length label))
+ do (insert (format "\n%s:\n" label))
+ do (cl-loop with index = 0
+ for (exp . eg) in items
+ do (insert (format "%2d. " (cl-incf index)) exp)
+ when (> (length eg) 0)
+ do (insert
+ "\n > "
+ (propertize (or eg "") 'face 'gt-google-buffer-detail-demo-face))
+ do (insert "\n"))))
+ ;; at last, return
+ (add-text-properties (point-min) (point-max) (list 'gt-mark pt 'gt-brief brief-result))
+ (setf res (buffer-string)))))))))
+
+;; summary-mode
+
+(cl-defmethod gt-parse ((parser gt-google-summary-parser) task)
+ (let* ((json (gt-resp-to-json parser (oref task res)))
+ (result (string-trim (gt-result--brief parser json) "\n+")))
+ (oset task res result)))
+
+;; Extract results from response
+
+(cl-defmethod gt-resp-to-json ((_ gt-google-parser) resp)
+ "Convert the buffer RESP into JSON."
+ (condition-case err
+ (json-read-from-string (decode-coding-string resp 'utf-8))
+ (error (user-error "Result conversion error: %s" err))))
+
+(cl-defmethod gt-result--brief ((_ gt-google-parser) json)
+ "Get the translation text from JSON."
+ (mapconcat (lambda (item) (aref item 0)) (aref json 0) ""))
+
+(cl-defmethod gt-result--sphonetic ((_ gt-google-parser) json)
+ "Get the text phonetic from JSON."
+ (mapconcat (lambda (item) (if (> (length item) 3) (aref item 3) "")) (aref json 0) ""))
+
+(cl-defmethod gt-result--tphonetic ((_ gt-google-parser) json)
+ "Get the translation phonetic from JSON."
+ (mapconcat (lambda (item) (if (> (length item) 2) (aref item 2) "")) (aref json 0) ""))
+
+(cl-defmethod gt-result--details ((_ gt-google-parser) json)
+ "Get the details from JSON.
+Result style: ((noun (a (x y z))) (verb (b (m n o))))."
+ (cl-loop for i across (aref json 1)
+ collect
+ (cons
+ (aref i 0)
+ (cl-loop for j across (aref i 2)
+ collect
+ (cons
+ (aref j 0)
+ (cl-loop for k across (aref j 1) collect k))))))
+
+(cl-defmethod gt-result--definitions ((_ gt-google-parser) json)
+ "Get the definitions from JSON.
+Result style: ((noun (a b)) (verb (c d)))."
+ (cl-loop with defs = (ignore-errors (aref json 12))
+ for i across defs
+ collect
+ (cons
+ (aref i 0)
+ (cl-loop for j across (aref i 1)
+ collect
+ (cons
+ (aref j 0)
+ (ignore-errors (aref j 2)))))))
+
+(cl-defmethod gt-result--suggestion ((_ gt-google-parser) json)
+ "Get the suggestion from JSON."
+ (let ((info (aref json 7))) (unless (seq-empty-p info) (aref info 1))))
+
+\f
+;;; Token Key algorithm (deprecated)
+
+;; This algorithm is from `google-translate' project.
+;; https://github.com/atykhonov/google-translate/blob/master/google-translate-tk.el
+
+(defvar gt-google-token--bit-v-len 32)
+
+(defun gt-google-token--bit-v-2comp (v)
+ "Return the two's complement of V."
+ (let* ((vc (vconcat v))
+ (len (length vc)))
+ ;; Complement of v
+ (cl-loop for i from 0 below len do
+ (aset vc i (logxor (aref vc i) 1)))
+ ;; vc = complement of v + 1
+ (cl-loop for i downfrom (1- len) to 0
+ do (aset vc i (logxor (aref vc i) 1))
+ when (> (aref vc i) 0) return nil)
+ vc))
+
+(defun gt-google-token--number-to-bit-v (n)
+ "Return a bit vector from N."
+ (if (< n 0) (gt-google-token--bit-v-2comp
+ (gt-google-token--number-to-bit-v (abs n)))
+ (let ((v (make-vector gt-google-token--bit-v-len 0)))
+ (cl-loop for i downfrom (1- gt-google-token--bit-v-len) to 0
+ with q
+ when (< n 1) return nil do
+ (setq q (ffloor (* n 0.5)))
+ (aset v i (floor (- n (* 2.0 q))))
+ (setq n q))
+ v)))
+
+(defun gt-google-token--bit-v-to-number (v)
+ "Return a floating-point number from V."
+ (if (and (> (aref v 0) 0)
+ ;; Exclude [1 0 ... 0]
+ (cl-loop for i from 1 below gt-google-token--bit-v-len
+ thereis (> (aref v i) 0)))
+ (- (gt-google-token--bit-v-to-number (gt-google-token--bit-v-2comp v)))
+ (funcall (if (> (aref v 0) 0) #'- #'+)
+ (cl-reduce (lambda (acc e) (+ (* acc 2.0) e))
+ v :initial-value 0.0))))
+
+(defun gt-google-token--logfn (fn n1 n2)
+ "Helper function for logical FN with N1 and N2."
+ (let ((v1 (gt-google-token--number-to-bit-v n1))
+ (v2 (gt-google-token--number-to-bit-v n2))
+ (v (make-vector gt-google-token--bit-v-len 0)))
+ (cl-loop for i from 0 below gt-google-token--bit-v-len do
+ (aset v i (funcall fn (aref v1 i) (aref v2 i))))
+ (gt-google-token--bit-v-to-number v)))
+
+(defun gt-google-token--logand (n1 n2)
+ "Return a floating-point number from N1 and N2."
+ (gt-google-token--logfn #'logand n1 n2))
+
+(defun gt-google-token--logxor (n1 n2)
+ "Return a floating-point number from N1 and N2."
+ (gt-google-token--logfn #'logxor n1 n2))
+
+(defun gt-google-token--lsh (n d)
+ "Return a floating-point number.
+Shift the bits in N to the left or rihgt D places.
+D is an integer."
+ (let ((v (gt-google-token--number-to-bit-v n))
+ (v-result (make-vector gt-google-token--bit-v-len 0)))
+ (if (< d 0)
+ ;; Shift Right Logical
+ (cl-loop for i from (abs d) below gt-google-token--bit-v-len
+ for j from 0 do
+ (aset v-result i (aref v j)))
+ ;; Shift Left Logical
+ (cl-loop for i from d below gt-google-token--bit-v-len
+ for j from 0 do
+ (aset v-result j (aref v i))))
+ (gt-google-token--bit-v-to-number v-result)))
+
+(defun gt-google-token--gen-rl (a b)
+ "Gen rl from A and B."
+ (cl-loop for c from 0 below (- (length b) 2) by 3
+ for d = (aref b (+ c 2)) do
+ (setq d (if (>= d ?a) (- d 87) (- d ?0)))
+ (setq d (if (= (aref b (1+ c)) ?+)
+ (gt-google-token--lsh a (- d))
+ (gt-google-token--lsh a d)))
+ (setq a (if (= (aref b c) ?+)
+ (gt-google-token--logand (+ a d) 4294967295.0)
+ (gt-google-token--logxor a d))))
+ a)
+
+(defun gt-google-tkk (token text)
+ "Calculate the TOKEN for search TEXT."
+ (let* ((b (car token))
+ (d1 (cdr token))
+ (ub "+-3^+b+-f")
+ (vb "+-a^+6")
+ (a (cl-loop for c across (encode-coding-string text 'utf-8)
+ for rr = (gt-google-token--gen-rl (+ (or rr b) c) vb)
+ finally (return rr))))
+ (setq a (gt-google-token--gen-rl a ub))
+ (setq a (gt-google-token--logxor a d1))
+ (if (< a 0) (setq a (+ (gt-google-token--logand a 2147483647.0) 2147483648.0)))
+ (setq a (ffloor (mod a 1e6)))
+ (format "%s.%s"
+ (car (split-string (number-to-string a) "\\."))
+ (car (split-string (number-to-string
+ (gt-google-token--logxor a b))
+ "\\.")))))
+
+(provide 'gt-engine-google)
+
+;;; gt-engine-google.el ends here
--- /dev/null
+;;; gt-engine-libre.el --- Engine for LibreTranslate -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; https://github.com/LibreTranslate/LibreTranslate
+;; https://libretranslate.com/
+
+;;; Code:
+
+(require 'gt-extension)
+
+(defgroup go-translate-libre nil
+ "Configs for LibreTranslate engine."
+ :group 'go-translate)
+
+(defcustom gt-libre-host "https://translate.disroot.org/"
+ "API host of LibreTranslate.
+
+The official host is: https://libretranslate.com/, you can config this
+to use third-party or your local service."
+ :type 'string
+ :group 'go-translate-libre)
+
+\f
+;;; Components
+
+(defclass gt-libre-parser (gt-parser) ())
+
+(defclass gt-libre-engine (gt-engine)
+ ((tag :initform 'LibreTranslate)
+ (host :initform nil :initarg :host)
+ (path :initform "/translate")
+ (parse :initform (gt-libre-parser))
+ (delimiter :initform "21597"
+ ;; Any way to force specific segment not be changed after translate?
+ ;; I don't know! Just set this a random number, to make it work...sometimes.
+ ;; So this maybe failed in translating multiple parts text.
+ )
+ (cache :initform nil)
+ (key :initform 'api-key
+ :initarg :key
+ :documentation "The api-key of LibreTranslate.
+You can also put it into .authinfo file as:
+ machine [HOST like libretranslate.com] login api-key password [***]")))
+
+\f
+;;; Translate
+
+(cl-defmethod gt-ensure-key ((engine gt-libre-engine))
+ (with-slots (host key) engine
+ (unless (stringp key)
+ (setf key
+ (gt-lookup-password
+ :user (if key (format "%s" key) "api-key")
+ :host (url-host (url-generic-parse-url (or host gt-libre-host))))))))
+
+(cl-defmethod gt-translate ((engine gt-libre-engine) task next)
+ (gt-ensure-key engine)
+ (with-slots (text src tgt res) task
+ (with-slots (host path key) engine
+ (gt-request :url (concat (or host gt-libre-host) path)
+ :data `(("q" . ,text)
+ ("source" . ,src)
+ ("target" . ,tgt)
+ ("format" . "text")
+ ("alternatives" . 1)
+ ,(if key `("api_key" . ,key)))
+ :done (lambda (raw)
+ (setf res raw)
+ (funcall next task))
+ :fail (lambda (err)
+ (gt-fail task err))))))
+
+(cl-defmethod gt-parse ((_ gt-libre-parser) task)
+ (with-slots (res) task
+ (let ((json (json-read-from-string (decode-coding-string res 'utf-8))))
+ (setf res (cdr (assoc 'translatedText json))))))
+
+(provide 'gt-engine-libre)
+
+;;; gt-engine-libre.el ends here
--- /dev/null
+;;; gt-engine-stardict.el --- StarDict -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; Engine for sdcv (StarDict Console Version).
+;;
+;; sdcv is an offline translate software. It can be used when no network.
+;;
+;; Make sure sdcv is installed on your system:
+;;
+;; sudo pacman -S sdcv
+;;
+;; Then download dictionary data to ~/.stardict/dic or /usr/share/stardict/dic:
+;;
+;; # For example from http://download.huzheng.org:
+;;
+;; mkdir -p ~/.stardict/dic
+;; cd ~/.stardict/dic
+;; wget http://download.huzheng.org/zh_CN/stardict-langdao-ce-gb-2.4.2.tar.bz2
+;; wget http://download.huzheng.org/zh_CN/stardict-langdao-ce-gb-2.4.2.tar.bz2
+;; tar xvf stardict-langdao-ec-gb-2.4.2.tar.bz2
+;; tar xvf stardict-langdao-ce-gb-2.4.2.tar.bz2
+;; sdcv -l
+;;
+;; Also, you can specify the dictionary and data-dir in `gt-stardict-engine' definition:
+;;
+;; (gt-stardict-engine :dict "a-dictionary" :dir "~/.stardict/dic" :dir-only t)
+;;
+;;; Code:
+
+(require 'gt-extension)
+
+(defclass gt-stardict-parser (gt-parser) ())
+
+(defclass gt-stardict-engine (gt-engine)
+ ((tag :initform 'StarDict)
+ (dict
+ :initarg :dict
+ :initform nil
+ :type (or string null)
+ :documentation "Search only this dictionary if not nil.")
+ (dir
+ :initarg :dir
+ :initform nil
+ :type (or string null)
+ :documentation "Use this dir as data directory if not nil.")
+ (dir-only
+ :initarg :dir-only
+ :initform nil
+ :type boolean
+ :documentation "Only use dictionaries in `dir'.")
+ (exact
+ :initarg :exact
+ :initform nil
+ :type boolean
+ :documentation "Exact search, that is disable fuzzy-search.")
+ (cache :initform nil)
+ (parse :initform (gt-stardict-parser))))
+
+(defvar gt-stardict-program "sdcv"
+ "Executable command of sdcv (StarDict Console Version).")
+
+(defconst gt-stardict-args '("--non-interactive" "--json-output" "-0" "-1"))
+
+(defvar gt-stardict-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] #'gt-stardict-switch-dict)
+ (define-key map (kbd "C-c C-c") #'gt-stardict-switch-dict)
+ map)
+ "The keymap used by StarDict.")
+
+(defun gt-stardict-build-args (engine)
+ (with-slots (dict dir dir-only exact) engine
+ (let ((args gt-stardict-args))
+ (if dict (setq args `("--use-dict" ,dict ,@args)))
+ (if dir (setq args `("--data-dir" ,dir ,@args)))
+ (if dir-only (setq args `("--only-data-dir" ,@args)))
+ (if exact (setq args `("--exact-search" ,@args)))
+ (gt-log 'gt-stardict (format "[sdcv arguments]: %s" args))
+ args)))
+
+(defun gt-stardict-list-dicts (engine)
+ (with-temp-buffer
+ (apply #'call-process gt-stardict-program nil t nil
+ (cons "--list-dicts" (gt-stardict-build-args engine)))
+ (goto-char (point-min))
+ (cl-loop for d across (json-read)
+ collect (cons (alist-get 'name d) (alist-get 'wordcount d)))))
+
+(defun gt-stardict-switch-dict ()
+ (interactive)
+ (let* ((task (get-char-property (point) 'gt-task))
+ (engine (and task (oref task engine)))
+ (dicts (and engine (gt-stardict-list-dicts engine))))
+ (when (= (length dicts) 0) (user-error "No dict found, nothing can do"))
+ (let ((dict (completing-read "Dictionary to use: "
+ (gt-make-completion-table (cons 'ALL dicts))
+ nil t nil nil (oref engine dict))))
+ (oset engine dict (unless (string= dict "ALL") dict))
+ (oset gt-buffer-render-translator keep t)
+ (gt-start gt-buffer-render-translator))))
+
+(cl-defgeneric gt-stardict-pretty-definition (dictionary definition)
+ "Try to pretty the DEFINITION part of DICTIONARY for output."
+ (:method ((_ (eql '朗道)) definition)
+ (with-temp-buffer
+ (insert definition)
+ ;; phonetic
+ (goto-char (point-min))
+ (while (re-search-forward "^\\*\\(\\[.+\\]\\)" nil t)
+ (replace-match (propertize (match-string 1) 'face 'gt-stardict-phonetic-face)))
+ ;; related
+ (goto-char (point-min))
+ (while (re-search-forward "^相关词组:" nil t)
+ (replace-match (concat "\n" (propertize (match-string 0) 'face 'bold))))
+ ;; word class
+ (goto-char (point-min))
+ (while (re-search-forward
+ (format "^\\(%s\\)\\. " (mapconcat (lambda (v) (format "%s" v)) gt-word-classes "\\|")) nil t)
+ (put-text-property (match-beginning 0) (match-end 0) 'face 'gt-stardict-word-class-face))
+ (buffer-string)))
+ (cond ((string-match-p "^朗道.+字典" (format "%s" dictionary))
+ (gt-stardict-pretty-definition '朗道 definition))
+ (t definition)))
+
+(cl-defmethod gt-translate ((engine gt-stardict-engine) task next)
+ (unless (executable-find gt-stardict-program)
+ (user-error "You should install `sdcv' first before use `gt-stardict-engine'"))
+ (with-slots (text res) task
+ (with-temp-buffer
+ (apply #'call-process gt-stardict-program nil t nil
+ (append (gt-stardict-build-args engine) (list text)))
+ (setf res (buffer-string))
+ (funcall next task))))
+
+(cl-defmethod gt-parse ((_ gt-stardict-parser) task)
+ (with-slots (res) task
+ (let ((json (condition-case _ (json-read-from-string res)
+ (error (user-error res))))
+ (props `(pointer hand help-echo "Click to switch dictionary" keymap ,gt-stardict-map)))
+ (when (= (length json) 0)
+ (user-error (apply #'propertize "No translation result found, sorry :(" props)))
+ (with-temp-buffer
+ (cl-loop for d in (cl-remove-duplicates (mapcar #'cdar json) :test #'string=)
+ do (insert (apply #'propertize d 'display '(height 0.6) 'face 'gt-stardict-dict-face props) "\n\n")
+ collect (cl-loop for r across (cl-remove-if-not
+ (lambda (item) (string= (cdar item) d)) json)
+ for i from 1
+ for word = (propertize (alist-get 'word r)
+ 'face 'gt-stardict-word-face
+ 'display '(raise 0.6))
+ for definition = (propertize (gt-stardict-pretty-definition (intern d) (alist-get 'definition r))
+ 'display '(raise 0.3)
+ 'line-prefix " "
+ 'wrap-prefix " ")
+ collect (concat (if (= i 0) (gt-line-height-separator 10)) word definition) into r1
+ finally (return (string-join r1 "\n")))
+ into rs finally (insert (string-join rs "\n\n")))
+ (setf res (buffer-string))))))
+
+(provide 'gt-engine-stardict)
+
+;;; gt-engine-stardict.el ends here
--- /dev/null
+;;; gt-engine-youdao.el --- YouDao Dict -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; 有道词典 (https://dict.youdao.com), A Chinese translation website.
+;;
+;; This engine is only for Chinese user.
+;;
+;; > 此引擎仅供中文翻译使用
+;;
+;; There are two engine implements here, one is `gt-youdao-dict-engine' and another is `gt-youdao-suggest-engine'.
+;;
+;; > 这里为有道实现了两个引擎：
+;; > 1. `gt-youdao-dict-engine'，基于网页翻译接口，具备基本的翻译能力
+;; > 2. `gt-youdao-suggest-engine', 用于展示输入单词的同义词及相关词汇
+;; >
+;; > 另外，有道还提供 API 接口，罢了，要收费的。
+
+;;; Code:
+
+(require 'gt-extension)
+
+\f
+;;; 有道词典
+
+(defclass gt-youdao-dict-parser (gt-parser) ())
+
+(defclass gt-youdao-dict-engine (gt-engine)
+ ((tag :initform '有道词典)
+ (url :initform "https://dict.youdao.com/result?lang=%s&word=%s")
+ (parse :initform (gt-youdao-dict-parser))))
+
+(cl-defmethod gt-translate ((engine gt-youdao-dict-engine) task next)
+ (with-slots (text src tgt res meta translator) task
+ (let* ((lang (cond ((equal src 'zh) tgt)
+ ((equal tgt 'zh) src)
+ (t (user-error "只支持中文跟其他语言之间的翻译"))))
+ (url (if (cdr (oref translator text))
+ (user-error "不支持分段翻译")
+ (format (oref engine url)
+ (url-hexify-string (format "%s" lang))
+ (url-hexify-string text)))))
+ (gt-request :url url
+ :done (lambda (raw)
+ (setf res (gt-parse-html-dom raw) meta url)
+ (funcall next task))
+ :fail (lambda (err) (gt-fail task err))))))
+
+(defun gt-youdao-dict--extract (dom)
+ "从 DOM 中解析结果。"
+ (let* ((phonetic (cl-loop for p in (dom-by-class dom "per-phone")
+ collect (cons (nth 2 (nth 2 p)) (nth 2 (nth 3 p)))))
+ (node (dom-by-id dom "catalogue_author"))
+ (exp-ce (cl-loop for n in (dom-by-class node "word-exp-ce")
+ for s = (car (dom-by-class n "point"))
+ for r = (car (dom-by-class n "word-exp_tran"))
+ collect (cons (nth 2 s) (nth 2 r))))
+ (exp-nw (unless exp-ce
+ (cl-loop for n in (dom-by-class node "trans-content")
+ collect (nth 2 n))))
+ (exp-ec (unless (or exp-nw exp-ce)
+ (cl-loop for n in (dom-by-class node "word-exp")
+ collect (cons (nth 2 (nth 2 n)) (nth 2 (nth 3 n))))))
+ (exam-type (mapcar #'caddr (dom-by-class node "exam_type-value")))
+ (word-wfs (cl-loop for n in (dom-by-class node "word-wfs-cell-less")
+ collect (cons (nth 2 (nth 2 (nth 2 n))) (nth 2 (nth 3 n))))))
+ (list :exp-nw exp-nw :exp-ce exp-ce :exp-ec exp-ec :phonetic phonetic
+ :exam-type exam-type :word-wfs word-wfs)))
+
+(defun gt-youdao-dict--filter (result)
+ "对 RESULT 进行某些美化。"
+ (string-replace "】" "]" (string-replace "【" "[" result)))
+
+(defun gt-youdao-dict--tts-url (word &optional lang)
+ (format "http://dict.youdao.com/dictvoice?audio=%s&type=%s"
+ (url-hexify-string word)
+ (if (member lang '("英" 1 "1")) 1 0)))
+
+(cl-defmethod gt-parse ((_ gt-youdao-dict-parser) task)
+ (with-slots (res meta) task
+ (gt-plist-let ((gt-youdao-dict--extract res))
+ (with-temp-buffer
+ ;; 音标
+ (when .phonetic
+ (insert (substring-no-properties (oref task text)) " "
+ (propertize (if .exp-ce
+ (propertize (caar .phonetic) 'face 'gt-youdao-dict-phonetic-face)
+ (mapconcat (lambda (p)
+ (concat (propertize (car p) 'face 'gt-youdao-dict-label-face) " "
+ (propertize (cdr p)
+ 'face 'gt-youdao-dict-phonetic-face
+ 'mouse-face 'bold
+ 'gt-tts-url (gt-youdao-dict--tts-url (oref task text) (car p))
+ 'keymap (gt-simple-keymap [mouse-1] #'gt-do-speak))))
+ .phonetic " "))
+ 'display '(height 0.7))
+ "\n\n"))
+ ;; 释义
+ (insert (cond
+ (.exp-nw (mapconcat #'identity .exp-nw "\n"))
+ (.exp-ce (mapconcat (lambda (exp)
+ (concat (propertize (car exp) 'face 'gt-youdao-dict-entry-face) "\n\n " (cdr exp)))
+ .exp-ce "\n\n"))
+ (.exp-ec (mapconcat (lambda (exp)
+ (if (cdr exp)
+ (concat (propertize (car exp) 'face 'gt-youdao-dict-entry-face) " " (cdr exp))
+ (gt-youdao-dict--filter (car exp))))
+ .exp-ec "\n\n"))
+ (t (user-error "也许没有翻译结果?")))
+ "\n\n")
+ ;; 相关
+ (cl-loop for wf in .word-wfs
+ for i from 1
+ do (insert (propertize (car wf) 'face 'gt-youdao-dict-label-face) " " (cdr wf))
+ do (insert (if (= (length .word-wfs) i) "\n\n" (if (> (current-column) fill-column) "\n" "\t"))))
+ ;; 考试
+ (when-let (et (and .exam-type (mapconcat #'identity .exam-type " / ")))
+ (insert (propertize et 'face 'gt-youdao-dict-phonetic-face 'display '(height 0.7))))
+ ;; 返回
+ (setf res (if (or .exp-ce .exp-ec)
+ (propertize (buffer-string) 'gt-url meta)
+ (buffer-string)))))))
+
+\f
+;;; 有道同义词
+
+(defclass gt-youdao-suggest-parser (gt-parser) ())
+
+(defclass gt-youdao-suggest-engine (gt-engine)
+ ((tag :initform '有道同义词)
+ (url :initform "https://dict.youdao.com/suggest?q=%s&num=%s&doctype=json")
+ (limit :initform 9 :initarg :limit)
+ (delimiter :initform nil)
+ (parse :initform (gt-youdao-suggest-parser))))
+
+(cl-defmethod gt-translate ((engine gt-youdao-suggest-engine) task next)
+ (with-slots (text res meta) task
+ (when (cdr text)
+ (user-error "不支持一次翻译多个单词或句子"))
+ (let ((url (format (oref engine url) (url-hexify-string (car text)) (oref engine limit))))
+ (gt-request :url url
+ :done (lambda (raw) (setf res raw meta url) (funcall next task))
+ :fail (lambda (err) (gt-fail task err))))))
+
+(cl-defmethod gt-parse ((_ gt-youdao-suggest-parser) task)
+ (with-slots (res meta) task
+ (let ((json (json-read-from-string res)))
+ (unless (= (alist-get 'code (alist-get 'result json)) 200)
+ (user-error (alist-get 'msg (alist-get 'result json))))
+ (let ((lst (cl-loop
+ for item across (alist-get 'entries (alist-get 'data json))
+ for i from 1
+ for ent = (propertize (alist-get 'entry item) 'face 'gt-youdao-suggest-entry-face)
+ for exp = (if-let (ex (alist-get 'explain item)) (propertize (concat " " ex) 'wrap-prefix " "))
+ collect (concat (if (> i 1) (gt-line-height-separator 18)) ent
+ (if exp (concat "\n" (gt-line-height-separator 8) exp))))))
+ (with-temp-buffer
+ (insert (string-join lst "\n"))
+ (goto-char (point-min))
+ (while (re-search-forward (format "\\(%s\\)\\(\\. \\|．\\)"
+ (mapconcat (lambda (v) (format "%s" v)) gt-word-classes "\\|"))
+ nil t)
+ (put-text-property (match-beginning 0) (match-end 0) 'face 'gt-youdao-suggest-cixing-face))
+ (setf res (propertize (buffer-string) 'gt-url meta)))))))
+
+(provide 'gt-engine-youdao)
+
+;;; gt-engine-youdao.el ends here
--- /dev/null
+;;; gt-extension.el --- Extension components -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+;; Package-Requires: ((emacs "28.1"))
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; Some extension components
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'json)
+(require 'gt-core)
+(require 'gt-faces)
+
+\f
+;;; [Render] buffer render
+
+(defclass gt-buffer-render (gt-render)
+ ((buffer-name :initarg :buffer-name :initform nil)
+ (window-config :initarg :window-config :initform nil)
+ (split-threshold :initarg :split-threshold :initform nil))
+ "Popup a new buffer to display the translation result.")
+
+(defcustom gt-buffer-render-follow-p nil
+ "Pop to the result buffer instead of just displaying."
+ :type 'boolean
+ :group 'go-translate)
+
+(defcustom gt-buffer-render-split-width-threshold 80
+ "Threshold width of window horizontal split for Buffer-Render."
+ :group 'go-translate
+ :type '(choice
+ (const :tag "Disable" nil)
+ (integer :tag "Threshold")))
+
+(defcustom gt-buffer-render-window-config
+ '((display-buffer-reuse-window display-buffer-in-direction)
+ (direction . right))
+ "Window configuration of buffer window of Buffer-Render.
+
+Notice, this can be overrided by `window-config' slot of render instance."
+ :type 'sexp
+ :group 'go-translate)
+
+(defcustom gt-buffer-render-init-hook nil
+ "Hook run after buffer initialization in Buffer-Render."
+ :type 'hook
+ :group 'go-translate)
+
+(defcustom gt-buffer-render-output-hook nil
+ "Hook run after output finished in Buffer-Render."
+ :type 'hook
+ :group 'go-translate)
+
+(defvar gt-buffer-render-buffer-name "*gt-result*")
+
+(defvar gt-buffer-render-evil-leading-key "," "Leading key for keybinds in evil mode.")
+
+(defvar-local gt-buffer-render-translator nil)
+(defvar-local gt-buffer-render-keybinding-messages nil)
+(defvar-local gt-buffer-render-local-map nil)
+
+(declare-function evil-define-key* "ext:evil-core.el" t t)
+
+(cl-defmacro gt-buffer-render-key ((key &optional tag test) &rest form)
+ (declare (indent 1))
+ `(when ,(or test `,test t)
+ (let ((fn ,(if (member (car-safe (car form)) '(function lambda))
+ `,(car form)
+ `(lambda () (interactive) ,@form))))
+ (if (bound-and-true-p evil-mode)
+ (evil-define-key* 'normal gt-buffer-render-local-map
+ (kbd (concat gt-buffer-render-evil-leading-key
+ (if gt-buffer-render-evil-leading-key " ") ,key))
+ fn)
+ (define-key gt-buffer-render-local-map (kbd ,key) fn))
+ (setq gt-buffer-render-keybinding-messages
+ (cl-remove ,key gt-buffer-render-keybinding-messages :key #'car :test #'string=))
+ (when ,tag
+ (push (cons ,key ,tag) gt-buffer-render-keybinding-messages)))))
+
+(defun gt-buffer-render--refresh ()
+ (interactive)
+ (oset gt-buffer-render-translator keep t)
+ (gt-start gt-buffer-render-translator))
+
+(defun gt-buffer-render--cycle-next (&optional ignore-rules)
+ (interactive "P")
+ (with-slots (target taker keep) gt-buffer-render-translator
+ (if (and (slot-boundp taker 'langs) (gt-functionp (oref taker langs)))
+ (user-error "Current taker not support cycle next")
+ (let* ((curr gt-last-target)
+ (gt-skip-lang-rules-p ignore-rules)
+ (gt-ignore-target-history-p t)
+ (next (gt-target taker gt-buffer-render-translator 'next)))
+ (unless (equal next curr)
+ (setf target next keep t)
+ (gt-start gt-buffer-render-translator))))))
+
+(defun gt-buffer-render--toggle-polyglot ()
+ (interactive)
+ (setq gt-polyglot-p (not gt-polyglot-p))
+ (with-slots (target keep) gt-buffer-render-translator
+ (setf target nil keep t)
+ (gt-start gt-buffer-render-translator)))
+
+(defun gt-buffer-render--browser ()
+ (interactive)
+ (if-let (url (get-char-property (point) 'gt-url))
+ (progn (browse-url url)
+ (message "Opening %s... Done!" url))
+ (message "No url found on current result.")))
+
+(defun gt-buffer-render--delete-cache ()
+ (interactive)
+ (when-let ((task (get-pos-property (point) 'gt-task))
+ (key (gt-cache-key task (or (get-pos-property (point) 'gt-part) 0))))
+ (gt-cache-set gt-default-cacher key nil)
+ (message "Delete %s from cacher" key)))
+
+(defun gt-buffer-render--keyboard-quit ()
+ (interactive)
+ (unwind-protect
+ (gt-interrupt-speak-process)
+ (keyboard-quit)))
+
+(defun gt-buffer-render--show-tips ()
+ (interactive)
+ (if gt-buffer-render-keybinding-messages
+ (message (mapconcat
+ (lambda (kd) (concat (propertize (car kd) 'face 'font-lock-keyword-face) ": " (cdr kd)))
+ (reverse gt-buffer-render-keybinding-messages) " "))
+ (message "No any help tips found")))
+
+(defun gt-buffer-render--toggle-readonly ()
+ (interactive)
+ (read-only-mode -1)
+ (use-local-map nil)
+ (local-set-key (kbd "C-x C-q")
+ (lambda ()
+ (interactive)
+ (read-only-mode 1)
+ (use-local-map gt-buffer-render-local-map))))
+
+(defun gt-buffer-render--unfold-source-text ()
+ (interactive)
+ (mapc (lambda (ov)
+ (delete-overlay ov))
+ (overlays-at (point))))
+
+(defvar gt-buffer-render-dislike-source-text nil)
+
+(defvar gt-buffer-render-source-text-limit 140
+ "Fold some of the source text if it's too long.
+This can be a number as visible length or a function with source text
+as argument that return a length.")
+
+(defvar gt-buffer-render-source-text-fold-bound-function
+ #'gt-buffer-render-source-text-fold-bound)
+
+(defun gt-buffer-render-source-text-fold-bound ()
+ (when (and (numberp gt-buffer-render-source-text-limit)
+ (> (point-max) gt-buffer-render-source-text-limit))
+ (goto-char (min (point-max) (+ (point-min) gt-buffer-render-source-text-limit)))
+ (move-to-column fill-column)
+ (skip-chars-backward " \t\n")
+ (when-let (bd (bounds-of-thing-at-point 'word))
+ (goto-char (cdr bd)))
+ (when (> (- (point-max) 20) (point))
+ (cons (point) (point-max)))))
+
+(defun gt-buffer-insert-source-text (text &optional fold)
+ "Propertize and insert the source TEXT into render buffer.
+If FOLD non nil, only make part of the text visible."
+ (let* ((text (string-trim text "\n+"))
+ (beg (point))
+ (end (progn (insert (substring-no-properties text)) (point))))
+ (insert "\n\n")
+ (save-excursion
+ (put-text-property beg end 'face 'gt-buffer-render-source-face)
+ (put-text-property beg (+ end 2) 'gt-source-text t)
+ (when fold
+ (when-let* ((bd (save-restriction
+ (narrow-to-region beg end)
+ (funcall gt-buffer-render-source-text-fold-bound-function)))
+ (ov (make-overlay beg end)))
+ (overlay-put ov 'display
+ (concat
+ (propertize (buffer-substring beg (car bd)) 'face 'gt-buffer-render-source-face)
+ " ..."))
+ (overlay-put ov 'keymap (gt-simple-keymap
+ [return] #'gt-buffer-render--unfold-source-text
+ [mouse-1] #'gt-buffer-render--unfold-source-text))
+ (overlay-put ov 'pointer 'hand)
+ (overlay-put ov 'help-echo "Click to unfold the text")))
+ (cons beg end))))
+
+(defun gt-buffer-render-init (buffer render translator)
+ "Init BUFFER for RENDER of TRANSLATOR."
+ (with-current-buffer buffer
+ (with-slots (text tasks engines) translator
+ ;; setup
+ (deactivate-mark)
+ (visual-line-mode -1)
+ (font-lock-mode 1)
+ (setq-local cursor-type 'hbar)
+ (setq-local cursor-in-non-selected-windows nil)
+ (setq-local gt-buffer-render-translator translator)
+ ;; headline
+ (let ((engines (cl-delete-duplicates (mapcar (lambda (task) (oref task engine)) tasks))))
+ (gt-header render translator (unless (cdr engines) (oref (car engines) tag))))
+ ;; content
+ (let ((inhibit-read-only t)
+ (ret (gt-extract render translator)))
+ (erase-buffer)
+ (newline)
+ (save-excursion
+ (unless (or gt-buffer-render-dislike-source-text (cdr text)) ;; single part, single task
+ (pcase-let ((`(,beg . ,end) (gt-buffer-insert-source-text (car text))))
+ (put-text-property beg end 'gt-task (car tasks))))
+ (cl-loop for c in text
+ for i from 0
+ if (cdr text) do (gt-buffer-insert-source-text c) ; multi parts
+ do (cl-loop for tr in ret
+ for stream = (plist-get tr :stream)
+ for res = (propertize "Loading..."
+ 'face 'gt-buffer-render-loading-face
+ 'gt-result (if stream 'stream t))
+ for (prefix task) = (list (plist-get tr :prefix) (plist-get tr :task))
+ for output = (propertize (concat prefix res "\n\n") 'gt-task task 'gt-part i)
+ do (let ((engine (oref task engine)))
+ (if (and (gt-stream-p engine) (= i 0)) ; record result bound for stream
+ (let ((beg (point)) end)
+ (insert output)
+ (setq beg (set-marker (make-marker) (+ beg (length prefix))))
+ (setq end (set-marker (make-marker) (save-excursion (skip-chars-backward " \t\n") (point))))
+ (oset task markers (cons beg end)))
+ (insert output)))))))
+ ;; keybinds
+ (setq gt-buffer-render-local-map (make-sparse-keymap))
+ (use-local-map gt-buffer-render-local-map)
+ (gt-keybinds render translator)
+ ;; state
+ (read-only-mode 1)
+ (if-let (w (get-buffer-window nil t)) (set-window-point w (point)))
+ ;; execute the hook if exists
+ (run-hooks 'gt-buffer-render-init-hook))))
+
+(defun gt-buffer-render-output (buffer render translator)
+ "Output TRANSLATOR's result to BUFFER for RENDER."
+ (with-current-buffer buffer
+ (let ((inhibit-read-only t)
+ (ret (gt-extract render translator)) bds prop)
+ (with-slots (text tasks) translator
+ (save-excursion
+ ;; refresh source text
+ (goto-char (point-min))
+ (unless (cdr text)
+ (when-let (prop (text-property-search-forward 'gt-source-text))
+ (delete-region (prop-match-beginning prop) (prop-match-end prop))
+ (when (or (cdr ret) (not (get-pos-property 1 'gt-mark (car (ensure-list (plist-get (car ret) :result))))))
+ (let ((bd (gt-buffer-insert-source-text (car text) t)))
+ (unless (cdr tasks)
+ (put-text-property (car bd) (cdr bd) 'gt-task (car tasks)))))))
+ ;; collect positions
+ (goto-char (point-min))
+ (while (setq prop (text-property-search-forward 'gt-result))
+ (push (cons (set-marker (make-marker) (prop-match-beginning prop))
+ (set-marker (make-marker) (prop-match-end prop)))
+ bds))
+ (setq bds (nreverse bds))
+ ;; output results in bounds
+ (cl-loop for _ in text
+ for i from 0
+ do (cl-loop for tr in ret
+ for (beg . end) = (pop bds)
+ for (res state task) = (list (plist-get tr :result) (plist-get tr :state) (plist-get tr :task))
+ do (goto-char beg)
+ do (when (and (cl-plusp state) (null (get-char-property beg 'gt-done))
+ (or (not (eq (get-char-property (point) 'gt-result) 'stream)) (= state 1)))
+ (delete-region beg end)
+ (insert (propertize (if (consp res) (nth i res) res)
+ 'gt-result t 'gt-done t 'gt-task task 'gt-part i))))))))
+ ;; update states
+ (set-buffer-modified-p nil)
+ ;; execute the hook if exists
+ (run-hooks 'gt-buffer-render-output-hook)))
+
+(cl-defmethod gt-header ((_ gt-buffer-render) translator &optional tag)
+ "Set head line format for Buffer Render of TRANSLATOR.
+TAG is extra message show in the middle if not nil."
+ (with-slots (target) translator
+ (let ((line (append
+ '(" ")
+ (when-let (src (car target))
+ (list
+ "[" (propertize (format "%s" src) 'face 'gt-buffer-render-header-lang-face) "]"
+ (if tag (concat " ― " (propertize (format "%s" tag) 'face 'gt-buffer-render-header-desc-face)) "")
+ " → "))
+ (list
+ "["
+ (mapconcat (lambda (s) (propertize (format "%s" s) 'face 'gt-buffer-render-header-lang-face)) (cdr target) ", ")
+ "]"
+ (when (and gt-buffer-render-keybinding-messages (not (bound-and-true-p evil-mode)))
+ (concat " (" (propertize "?" 'face 'font-lock-type-face) " for tips)"))))))
+ (setq header-line-format line))))
+
+(cl-defmethod gt-keybinds ((_ gt-buffer-render) _translator)
+ "Define keybinds for `gt-buffer-render-local-map'."
+ (gt-buffer-render-key ("t" "Cycle Next") #'gt-buffer-render--cycle-next)
+ (gt-buffer-render-key ("T" "Toggle Polyglot") #'gt-buffer-render--toggle-polyglot)
+ (gt-buffer-render-key ("y" "TTS") (lambda () (interactive) (let (gt-tts-last-engine) (gt-do-speak))))
+ (gt-buffer-render-key ("O" "Browser") #'gt-buffer-render--browser)
+ (gt-buffer-render-key ("c" "Del Cache") #'gt-buffer-render--delete-cache)
+ (gt-buffer-render-key ("C") #'gt-purge-cache)
+ (gt-buffer-render-key ("g" "Refresh") #'gt-buffer-render--refresh)
+ (gt-buffer-render-key ("n") #'next-line)
+ (gt-buffer-render-key ("p") #'previous-line)
+ (gt-buffer-render-key ("h") #'backward-char)
+ (gt-buffer-render-key ("j") #'next-line)
+ (gt-buffer-render-key ("k") #'previous-line)
+ (gt-buffer-render-key ("l") #'forward-char)
+ (gt-buffer-render-key ("q" "Quit") #'kill-buffer-and-window)
+ (gt-buffer-render-key ("C-g") #'gt-buffer-render--keyboard-quit)
+ (gt-buffer-render-key ("C-x C-q") #'gt-buffer-render--toggle-readonly)
+ (gt-buffer-render-key ("?") #'gt-buffer-render--show-tips))
+
+(cl-defmethod gt-extract :around ((render gt-buffer-render) translator)
+ "Decorate prefix and result for buffer render."
+ (cl-loop with mpp = (cdr (oref translator text))
+ with ret = (cl-call-next-method render translator)
+ for tr in ret
+ for (prefix result state) = (gt-plist-let tr (list .prefix (format "%s" .result) .state))
+ if (and prefix (or (not (slot-boundp render 'prefix)) (eq (oref render prefix) t)))
+ do (plist-put tr :prefix
+ (concat (propertize (concat prefix (unless mpp "\n"))
+ 'face (if mpp 'gt-buffer-render-inline-prefix-face 'gt-buffer-render-block-prefix-face))
+ "\n"))
+ if (= 1 state) do (plist-put tr :result (propertize result 'face 'gt-buffer-render-error-face))
+ collect tr))
+
+(cl-defmethod gt-init ((render gt-buffer-render) translator)
+ (with-slots (buffer-name split-threshold window-config) render
+ (let ((buf (get-buffer-create (or buffer-name gt-buffer-render-buffer-name)))
+ (split-width-threshold (or split-threshold gt-buffer-render-split-width-threshold split-width-threshold)))
+ (gt-buffer-render-init buf render translator)
+ (display-buffer buf (or window-config gt-buffer-render-window-config)))))
+
+(cl-defmethod gt-output ((render gt-buffer-render) translator)
+ (when-let (buf (get-buffer (or (oref render buffer-name) gt-buffer-render-buffer-name)))
+ (gt-buffer-render-output buf render translator)
+ (when (= (oref translator state) 3)
+ (if gt-buffer-render-follow-p
+ (pop-to-buffer buf)
+ (display-buffer buf)))))
+
+(cl-defmethod gt-output :after ((_ gt-buffer-render) translator)
+ (when (= (oref translator state) 3) (message "")))
+
+\f
+;;; [Render] Child-Frame Render (Popup Mode)
+;; implements via package Posframe, you should install it before use this
+
+(defclass gt-posframe-pop-render (gt-buffer-render)
+ ((width :initarg :width :initform nil)
+ (height :initarg :height :initform nil)
+ (forecolor :initarg :forecolor :initform nil)
+ (backcolor :initarg :backcolor :initform nil)
+ (padding :initarg :padding :initform 12)
+ (frame-params :initarg :frame-params :initform nil :type list
+ :documentation "Other parameters passed to `posframe-show'. Have higher priority."))
+ "Pop up a childframe to show the result.
+The frame will disappear when do do anything but focus in it.
+Manually close the frame with `q'.")
+
+(defvar gt-posframe-pop-render-buffer " *GT-Pop-Posframe*")
+(defvar gt-posframe-pop-render-init-hook nil)
+(defvar gt-posframe-pop-render-output-hook nil)
+(defvar gt-posframe-pop-render-timeout 30)
+(defvar gt-posframe-pop-render-poshandler nil)
+
+(declare-function posframe-show "ext:posframe.el" t t)
+(declare-function posframe-delete "ext:posframe.el" t t)
+(declare-function posframe-hide "ext:posframe.el" t t)
+(declare-function posframe-refresh "ext:posframe.el" t t)
+(declare-function posframe-poshandler-frame-top-right-corner "ext:posframe.el" t t)
+
+(defun gt-posframe-render-auto-close-handler ()
+ "Close the pop-up posframe window."
+ (interactive)
+ (unless (or (and gt-current-command
+ (member this-command (list gt-current-command #'exit-minibuffer)))
+ (and gt-posframe-pop-render-buffer
+ (string= (buffer-name) gt-posframe-pop-render-buffer)))
+ (ignore-errors (posframe-delete gt-posframe-pop-render-buffer))
+ (remove-hook 'post-command-hook #'gt-posframe-render-auto-close-handler)))
+
+(cl-defmethod gt-init :before ((_ gt-posframe-pop-render) _)
+ (unless (require 'posframe nil t)
+ (user-error "To use `gt-posframe-render', you should install and load package `posframe' first")))
+
+(cl-defmethod gt-init ((render gt-posframe-pop-render) translator)
+ (with-slots (width height forecolor backcolor padding frame-params) render
+ (let ((inhibit-read-only t)
+ (gt-buffer-render-dislike-source-text t)
+ (gt-buffer-render-init-hook gt-posframe-pop-render-init-hook)
+ (buf (get-buffer-create gt-posframe-pop-render-buffer))
+ (rweight (cond ((functionp width) (funcall width translator))
+ ((numberp width) width)
+ (t (if fill-column (- fill-column 5) 50))))
+ (rheight (cond ((functionp height) (funcall height translator))
+ ((numberp height) height)
+ (t 0))))
+ ;; height
+ (when (< rheight 1)
+ (let* ((h 1) (factor 1) (ts (ensure-list (oref translator text))))
+ (with-temp-buffer
+ (insert (string-join ts "\n"))
+ (goto-char (point-min))
+ (while (re-search-forward "\n+" nil t) (cl-incf h)))
+ (setq factor (* factor (length ts)))
+ (setq factor (* factor (max 1 (length (ensure-list (oref translator engines))))))
+ (setq factor (* factor (max 1 (length (ensure-list (cdr (oref translator target)))))))
+ (setq rheight (* factor (+ 4 h)))))
+ ;; render
+ (gt-buffer-render-init buf render translator)
+ ;; create
+ (unless (get-buffer-window (get-buffer buf))
+ (apply #'posframe-show buf
+ (append frame-params
+ (list
+ :timeout gt-posframe-pop-render-timeout
+ :width rweight
+ :height rheight
+ :max-height (/ (window-height) 2)
+ :foreground-color (or forecolor gt-pop-posframe-forecolor)
+ :background-color (or backcolor gt-pop-posframe-backcolor)
+ :internal-border-width padding
+ :internal-border-color (or backcolor gt-pop-posframe-backcolor)
+ :accept-focus t
+ :position (point)
+ :poshandler gt-posframe-pop-render-poshandler))))
+ (posframe-refresh buf)
+ ;; setup
+ (with-current-buffer buf
+ (gt-buffer-render-key ("q" "Close") (posframe-delete buf)))
+ (add-hook 'post-command-hook #'gt-posframe-render-auto-close-handler))))
+
+(cl-defmethod gt-output ((render gt-posframe-pop-render) translator)
+ (when-let (buf (get-buffer gt-posframe-pop-render-buffer))
+ (let ((gt-buffer-render-output-hook gt-posframe-pop-render-output-hook))
+ (gt-buffer-render-output buf render translator)
+ (posframe-refresh buf))))
+
+\f
+;;; [Render] Child-Frame Render (Pin Mode)
+
+(defclass gt-posframe-pin-render (gt-posframe-pop-render)
+ ((width :initarg :width :initform 60)
+ (height :initarg :height :initform 20)
+ (padding :initarg :padding :initform 8)
+ (bd-width :initarg :bd-width :initform 1)
+ (bd-color :initarg :bd-color :initform nil)
+ (backcolor :initarg :backcolor :initform nil)
+ (fri-color :initarg :fringe-color :initform nil)
+ (position :initarg :position :initform nil)
+ (frame-params :initarg :frame-params :initform nil :type list
+ :documentation "Other parameters passed to `posframe-show'. Have higher priority."))
+ "Pin the childframe in a fixed position to display the translate result.
+The childframe will not close, until you kill it with `q'.
+Other operations in the childframe buffer, just like in 'gt-buffer-render'.")
+
+(defvar gt-posframe-pin-render-buffer " *GT-Pin-Posframe*")
+(defvar gt-posframe-pin-render-frame nil)
+(defvar gt-posframe-pin-render-init-hook nil)
+(defvar gt-posframe-pin-render-output-hook nil)
+(defvar gt-posframe-pin-render-poshandler #'posframe-poshandler-frame-top-right-corner)
+
+(cl-defmethod gt-init ((render gt-posframe-pin-render) translator)
+ (if (and (get-buffer gt-posframe-pin-render-buffer) gt-posframe-pin-render-frame)
+ (make-frame-visible gt-posframe-pin-render-frame)
+ (with-slots (width height min-width min-height bd-width forecolor backcolor bd-color padding position frame-params) render
+ (setq gt-posframe-pin-render-frame
+ (let ((inhibit-read-only t))
+ (apply #'posframe-show gt-posframe-pin-render-buffer
+ (append frame-params
+ (list
+ :string "\nLoading..."
+ :width width
+ :height height
+ :min-width width
+ :min-height height
+ :foreground-color (or forecolor gt-pin-posframe-forecolor)
+ :background-color (or backcolor gt-pin-posframe-backcolor)
+ :internal-border-width bd-width
+ :border-color (or bd-color gt-pin-posframe-bdcolor)
+ :left-fringe padding
+ :right-fringe padding
+ :refresh nil
+ :accept-focus t
+ :respect-header-line t
+ :position position
+ :poshandler (unless position gt-posframe-pin-render-poshandler)))))))
+ (set-frame-parameter gt-posframe-pin-render-frame 'drag-internal-border t)
+ (set-frame-parameter gt-posframe-pin-render-frame 'drag-with-header-line t)
+ (when-let (color (or (oref render fri-color) gt-pin-posframe-fringe-color))
+ (set-face-background 'fringe color gt-posframe-pin-render-frame)))
+ ;; render
+ (let ((gt-buffer-render-init-hook gt-posframe-pin-render-init-hook))
+ (gt-buffer-render-init gt-posframe-pin-render-buffer render translator))
+ ;; setup
+ (with-current-buffer gt-posframe-pin-render-buffer
+ (gt-buffer-render-key ("q" "Close") (posframe-hide gt-posframe-pin-render-buffer))))
+
+(cl-defmethod gt-output ((render gt-posframe-pin-render) translator)
+ (let ((gt-buffer-render-output-hook gt-posframe-pin-render-output-hook))
+ (gt-buffer-render-output gt-posframe-pin-render-buffer render translator)))
+
+\f
+;;; [Render] kill-ring render
+
+(defclass gt-kill-ring-render (gt-render) ()
+ :documentation "Used to save the translate result into kill ring.")
+
+(cl-defmethod gt-output ((render gt-kill-ring-render) translator)
+ (deactivate-mark)
+ (when (= (oref translator state) 3)
+ (let ((ret (gt-extract render translator)))
+ (when-let (err (cl-find-if (lambda (r) (<= (plist-get r :state) 1)) ret))
+ (kill-new "")
+ (error "%s" (plist-get err :result)))
+ (kill-new (mapconcat (lambda (r) (string-join (plist-get r :result) "\n")) ret "\n\n"))
+ (message "Result already in the kill ring."))))
+
+\f
+;;; [Render] insert render
+
+(defclass gt-insert-render (gt-render)
+ ((type
+ :initarg :type
+ :initform 'after
+ :type (or (member after replace) boolean)
+ :documentation "How to insert the result.")
+ (rfmt
+ :initarg :rfmt
+ :initform nil
+ :documentation "Used to format the result string for insertion.
+See `gt-insert-render-format' for details.")
+ (sface
+ :initarg :sface
+ :initform nil
+ :documentation "The propertize face of the source text after translation.
+If this is nil then do nothing, if this is a face or a function return a face,
+just propertize the source text with the face.")
+ (rface
+ :initarg :rface
+ :initform nil
+ :documentation "Result face.")))
+
+(defcustom gt-insert-render-type 'after
+ "Where to insert the result in Insert-Render.
+
+If this is `replace', insert the result by taking place the source text,
+otherwise, insert after the source text.
+
+The value can be overrided by `type' slot of render."
+ :type '(choice (const :tag "Repace" replace)
+ (other :tag "Insert after" after))
+ :group 'go-translate)
+
+(defcustom gt-insert-render-output-hook nil
+ "Hook run after output finished in Insert-Render.
+With current translator as the only argument."
+ :type 'hook
+ :group 'go-translate)
+
+(defun gt-insert-render-format (render src res)
+ "Format RES for insert RENDER.
+
+SRC is the source text, RES is list extracted from translate task.
+
+Join them to a string, format or pretty it, at last return it as the result that
+used to insert.
+
+If slot `rfmt' is a string contains `%s', format every part of results with
+function `format' and join them.
+
+ (gt-insert-render :rfmt \" <%s>\" :rface `font-lock-warning-face)
+
+If `rfmt' is a function with solo argument, apply the function on every part of
+results and join them. If with two arguments, pass source text as the first
+argument. If four arguments, then chain the formatting task to the function.
+
+ (gt-insert-render :rfmt (lambda (w) (format \" [%s]\"))
+ :rface `font-lock-warning-face)
+
+ (gt-insert-render :rfmt (lambda (s w)
+ (if (length< s 3)
+ (format \"\\n- %s\" w)
+ (propertize w `face `font-lock-warning-face))))
+
+Otherwise, join the results use the default logic."
+ (with-slots (type rfmt rface) render
+ (cond
+ ((stringp rfmt)
+ (mapconcat (lambda (r) (gt-face-lazy (format rfmt r) (gt-ensure-plain rface r))) res "\n"))
+ ((functionp rfmt)
+ (let ((n (cdr (func-arity rfmt))))
+ (if (<= n 2)
+ (mapconcat (lambda (r)
+ (let ((ret (or (if (= n 2) (funcall rfmt src r) (funcall rfmt r)) r)))
+ (gt-face-lazy ret (gt-ensure-plain rface r))))
+ res "\n")
+ (funcall rfmt render src res))))
+ (t (let* ((before (when (eq type 'after)
+ (if (string-blank-p src) ""
+ (if (gt-word-p nil src) " "
+ (if (or (looking-at "\n\n")
+ (save-excursion (skip-chars-forward " \n\t") (eobp)))
+ "\n\n"
+ "\n")))))
+ (facefn (lambda (r) (gt-face-lazy r (gt-ensure-plain rface r))))
+ (separator (if (= (length before) 0) "\n\n" before)))
+ (concat before (mapconcat facefn res separator)))))))
+
+(cl-defmethod gt-init ((render gt-insert-render) translator)
+ (with-slots (text bounds tasks) translator
+ (unless (buffer-live-p (car bounds))
+ (error "Source buffer is unavailable, abort"))
+ (when (with-current-buffer (car bounds) buffer-read-only)
+ (error "Source buffer is readonly, can not insert"))
+ ;; only simple translate (single part, single target) allowing streaming output
+ ;; take bounds as output markers for it
+ (when (and (not (cdr text))
+ (not (cdr tasks))
+ (gt-stream-p (oref (car tasks) engine)))
+ (with-slots (markers engine) (car tasks)
+ (let ((type (oref render type))
+ (beg (if-let (p (caadr bounds))
+ (save-excursion
+ (goto-char p)
+ (skip-chars-forward "\n" (cdadr bounds))
+ (point))
+ (point)))
+ (end (if-let (p (cdadr bounds))
+ (save-excursion
+ (goto-char p)
+ (skip-chars-backward " \t\n" (caadr bounds))
+ (point))
+ (point))))
+ (setf markers (cons (set-marker (make-marker) (if (eq type 'after) end beg))
+ (set-marker (make-marker) end))))))))
+
+(cl-defmethod gt-output ((render gt-insert-render) translator)
+ (with-slots (bounds state) translator
+ (when (= 3 state)
+ (let ((ret (gt-extract render translator)))
+ (when-let (err (cl-find-if (lambda (tr) (<= (plist-get tr :state) 1)) ret))
+ (user-error "Error in translation, %s" (plist-get err :result)))
+ (with-current-buffer (car bounds)
+ (with-slots (rfmt sface) render
+ (cl-loop with start = (point-marker)
+ with bds = (mapcar (lambda (bd)
+ (cons (save-excursion
+ (goto-char (car bd))
+ (skip-chars-forward "\n")
+ (point-marker))
+ (save-excursion
+ (goto-char (cdr bd))
+ (skip-chars-backward " \t\n")
+ (point-marker))))
+ (cdr bounds))
+ with type = (let ((type (or (oref render type) gt-insert-render-type))
+ (types '(after replace)))
+ (if (member type types) type
+ (intern (completing-read "Insert text as: " types nil t))))
+ with hash = (when (and (eq type 'replace) (not (buffer-modified-p)))
+ (buffer-hash))
+ with len = (length (plist-get (car ret) :result))
+ for i from 0 below len
+ for (beg . end) = (if bds (nth i bds)
+ (if (use-region-p)
+ (car (region-bounds))
+ (cons (point) (point))))
+ for src = (if bds (buffer-substring beg end) "")
+ for res = (mapcar (lambda (tr) (nth i (plist-get tr :result))) ret)
+ do (goto-char end)
+ for fres = (gt-insert-render-format render src res)
+ do (let (p)
+ (if (eq type 'replace)
+ (delete-region beg end)
+ (when-let (face (and (eq type 'after) (gt-ensure-plain sface src)))
+ (delete-region beg end)
+ (insert (propertize src 'face face))))
+ (setq p (point))
+ (insert (propertize fres 'type 'gt-insert-result))
+ (save-excursion
+ (goto-char p)
+ (skip-chars-forward " \t\n")
+ (push-mark)))
+ finally (progn
+ (if (> len 1) (goto-char start))
+ (when (and hash (equal hash (buffer-hash)))
+ (set-buffer-modified-p nil))))
+ (deactivate-mark)
+ (run-hook-with-args 'gt-insert-render-output-hook translator)
+ (message "ok.")))))))
+
+(cl-defmethod gt-next-for-stream ((render gt-insert-render) task)
+ (with-slots (markers res) task
+ (let* ((beg (car markers)) (end (cdr markers))
+ (bounds (oref (oref task translator) bounds))
+ (insert-text (with-current-buffer (car bounds)
+ (save-excursion
+ (goto-char end)
+ (gt-insert-render-format
+ render
+ (if (and (eq (oref render type) 'after) (caadr bounds))
+ (buffer-substring (caadr bounds) (cdadr bounds))
+ "")
+ (list (string-join (ensure-list res) "\n")))))))
+ (gt-insert-text-at-marker insert-text beg end))))
+
+(cl-defmethod gt-desc ((render gt-insert-render))
+ (format "gt-insert-render/%s" (oref render type)))
+
+\f
+;;; [Render] Render with Overlay
+
+(defclass gt-overlay-render (gt-render)
+ ((type
+ :initarg :type
+ :initform 'after
+ :type (or (member after replace help-echo before) boolean)
+ :documentation "How to display the result.")
+ (rfmt
+ :initarg :rfmt
+ :initform nil
+ :documentation
+ "Used to format the translation result to fit the overlay display.
+See `gt-overlay-render-format' for details.")
+ (sface
+ :initarg :sface
+ :initform 'gt-overlay-source-face
+ :documentation "The propertize face of the source text after translation.
+If this is nil then do nothing, if this is a face or a function return a face,
+just propertize the source text with the face.")
+ (rface
+ :initarg :rface
+ :initform 'gt-overlay-result-face
+ :documentation "Result face.")
+ (rdisp
+ :initarg :rdisp
+ :initform nil
+ :documentation "Same as rface but used in `display' property.")
+ (pface
+ :initarg :pface
+ :initform 'gt-overlay-prefix-face
+ :documentation "Prefix face.")
+ (pdisp
+ :initarg :pdisp
+ :initform nil
+ :documentation "Same as pface but used in `display' property.")))
+
+(defcustom gt-overlay-render-type 'after
+ "How to display result in Overlay-Render.
+
+If this is `help-echo', display with help echo, if this is `replace', display
+by covering the source text, otherwise, display before or after the source text.
+
+The value can be overrided by `type' slot of render."
+ :type '(choice (const :tag "Repace" replace)
+ (const :tag "Help Echo" help-echo)
+ (const :tag "After" after)
+ (other :tag "Before" before))
+ :group 'go-translate)
+
+(defvar gt-overlay-render-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map (kbd "<mouse-1>") #'gt-delete-render-overlays)
+ (define-key map (kbd "<mouse-3>") #'gt-overlay-render-save-to-kill-ring)
+ map)
+ "Keymap used in overlay render.")
+
+(defun gt-overlay-render-get-overlays (beg &optional end)
+ "Return overlays made by Overlay-Render in the region from BEG to END.
+If END is nil, return the overlays at BEG."
+ (cl-remove-if-not (lambda (ov) (overlay-get ov 'gt))
+ (if end
+ (overlays-in beg end)
+ (overlays-at beg))))
+
+(defun gt-delete-render-overlays (beg &optional end)
+ "Delete overlays made by Overlay-Render in the region from BEG to END.
+If called interactively, delete overlays around point or in region. With
+`current-prefix-arg' non nil, delete all overlays in the buffer."
+ (interactive (cond (current-prefix-arg (list (point-min) (point-max)))
+ ((use-region-p) (list (region-beginning) (region-end)))
+ (t (list
+ (if (and (> (point) 1) ; for overlay before point
+ (not (gt-overlay-render-get-overlays (point)))
+ (gt-overlay-render-get-overlays (1- (point))))
+ (1- (point))
+ (point))
+ nil))))
+ (mapc #'delete-overlay (gt-overlay-render-get-overlays beg end)))
+
+(defun gt-overlay-render-save-to-kill-ring ()
+ "Copy translate content at point to kill ring for Overlay-Render."
+ (interactive)
+ (if-let* ((ov (car (gt-overlay-render-get-overlays (point))))
+ (rs (overlay-get ov 'gt)))
+ (progn (kill-new (string-trim rs))
+ (message "Result already in the kill ring."))
+ (user-error "No translate overlay found at point")))
+
+(defun gt-overlay-render-format (render src res prefix)
+ "Format RES for overlay RENDER.
+
+SRC is the source text, RES and PREFIX are list extracted from translate task.
+
+Join them to a string, format or pretty it, at last return it as the result that
+used to display.
+
+If slot `rfmt' is a string contains `%s', format every part of results with
+function `format' and join them.
+
+ (gt-overlay-render :rfmt \" <%s>\" :rface `font-lock-warning-face)
+
+If `rfmt' is a function with solo argument, apply the function on every part of
+results and join them. If with two arguments, pass source text as the first
+argument. If four arguments, then chain the formatting task to the function.
+
+ (gt-overlay-render :rfmt (lambda (w) (format \" [%s]\"))
+ :rface `font-lock-warning-face)
+
+ (gt-overlay-render :rfmt (lambda (s w)
+ (if (length< s 3)
+ (format \"\\n- %s\")
+ (propertize w `face `font-lock-warning-face))))
+
+Otherwise, join the results use the default logic."
+ (with-slots (type rfmt rface rdisp pface pdisp) render
+ (cond
+ ((stringp rfmt)
+ (mapconcat (lambda (r) (gt-face-lazy (format rfmt r)
+ (gt-ensure-plain rface r)
+ (gt-ensure-plain rdisp r)))
+ res "\n"))
+ ((functionp rfmt)
+ (let ((n (cdr (func-arity rfmt))))
+ (if (<= n 2)
+ (mapconcat (lambda (r)
+ (let ((ret (or (if (= n 2) (funcall rfmt src r) (funcall rfmt r)) r)))
+ (gt-face-lazy ret (gt-ensure-plain rface r) (gt-ensure-plain rdisp r))))
+ res "\n")
+ (funcall rfmt render src res prefix))))
+ (t (cl-loop with before = (when (eq type 'after)
+ (if (gt-word-p nil src) " "
+ (if (or (looking-at "\n\n")
+ (save-excursion (skip-chars-forward " \n\t") (eobp)))
+ "\n\n"
+ "\n")))
+ with after = (when (eq type 'before) (if (gt-word-p nil src) " " "\n"))
+ for r in res for p in prefix
+ for pr = (gt-face-lazy r (gt-ensure-plain rface r) (gt-ensure-plain rdisp r))
+ for pp = (if p (concat " " (gt-face-lazy p (gt-ensure-plain pface p) (gt-ensure-plain pdisp p))))
+ collect (concat pr pp) into ret
+ finally (return (concat before (string-join ret (or before "\n\n")) after)))))))
+
+(cl-defmethod gt-init ((render gt-overlay-render) translator)
+ (with-slots (bounds state) translator
+ (unless (cdr bounds)
+ (error "%s only works for buffer bounds, abort" (gt-desc render)))
+ (unless (buffer-live-p (car bounds))
+ (error "Source buffer is unavailable, abort"))))
+
+(cl-defmethod gt-output ((render gt-overlay-render) translator)
+ (with-slots (bounds state) translator
+ (when (= 3 state)
+ (let ((ret (gt-extract render translator)))
+ (when-let (err (cl-find-if (lambda (tr) (<= (plist-get tr :state) 1)) ret))
+ (user-error "Error in translation, %s" (plist-get err :result)))
+ (with-current-buffer (car bounds)
+ (cl-loop with start = (point-marker)
+ with type = (let ((type (or (oref render type) gt-overlay-render-type))
+ (types '(help-echo replace after before)))
+ (if (memq type types) type
+ (intern (completing-read "Display with overlay as: " types nil t))))
+ with hooks = `((lambda (o &rest _) (delete-overlay o)))
+ for (beg . end) in (cdr bounds) for i from 0
+ do (save-excursion
+ (goto-char beg)
+ (skip-chars-forward "\n")
+ (setq beg (point))
+ (goto-char end)
+ (skip-chars-backward " \t\n")
+ (setq end (point)))
+ do (gt-delete-render-overlays beg end)
+ for src = (buffer-substring beg end)
+ do (save-excursion
+ (goto-char end)
+ (let* ((ov (make-overlay beg (point) nil t t))
+ (fres (gt-overlay-render-format
+ render src
+ (mapcar (lambda (tr) (nth i (plist-get tr :result))) ret)
+ (mapcar (lambda (tr) (plist-get tr :prefix)) ret)))
+ (sface (oref render sface))
+ (sface (unless (eq type 'replace) (gt-ensure-plain sface src))))
+ (pcase type
+ ('help-echo (overlay-put ov 'help-echo fres))
+ ('after (overlay-put ov 'after-string fres))
+ ('before (overlay-put ov 'before-string fres)))
+ (overlay-put ov 'gt fres)
+ (overlay-put ov 'evaporate t)
+ (overlay-put ov 'pointer 'arrow)
+ (overlay-put ov 'insert-in-front-hooks hooks)
+ (overlay-put ov 'insert-behind-hooks hooks)
+ (overlay-put ov 'modification-hooks hooks)
+ (overlay-put ov 'keymap gt-overlay-render-map)
+ (if (eq type 'replace)
+ (progn (overlay-put ov 'display fres)
+ (overlay-put ov 'help-echo src))
+ (if sface (overlay-put ov 'face sface)))))
+ finally (if (cddr bounds) (goto-char start)))
+ (deactivate-mark)
+ (message "ok."))))))
+
+(cl-defmethod gt-desc ((render gt-overlay-render))
+ (format "gt-overlay-render/%s" (oref render type)))
+
+\f
+;;; [Render] Alert Render
+
+(defclass gt-alert-render (gt-render) ()
+ :documentation "Output results as system notification.
+It depends on the `alert' package.")
+
+(defvar gt-alert-render-args '(:timeout 10))
+
+(declare-function alert "ext:alert.el" t t)
+
+(cl-defmethod gt-init ((_ gt-alert-render) _)
+ (unless (require 'alert nil t)
+ (user-error "To use `gt-alert-render', you should install and load package `alert' first")))
+
+(cl-defmethod gt-output ((render gt-alert-render) translator)
+ (when (= (oref translator state) 3)
+ (let ((ret (gt-extract render translator)) lst)
+ ;; format
+ (dolist (tr ret)
+ (let ((prefix (if (cdr ret) (plist-get tr :prefix)))
+ (result (string-join (ensure-list (plist-get tr :result)) "\n")))
+ (push (concat prefix result) lst)))
+ ;; output
+ (message "")
+ (apply #'alert (string-join (nreverse lst) "\n") :title "*Go-Translate*" gt-alert-render-args))))
+
+\f
+;;; [Taker] Prompt with new buffer
+
+(defcustom gt-buffer-prompt-window-config
+ '((display-buffer-reuse-window display-buffer-below-selected))
+ "Window configuration of taker's buffer prompt window."
+ :type 'sexp
+ :group 'go-translate)
+
+(defvar gt-buffer-prompt-name "*gt-taker*")
+
+(defvar gt-buffer-prompt-map (make-sparse-keymap))
+
+(defvar gt-buffer-prompt-after-init-function nil
+ "Function with no argument, executed after prompt buffer init.
+Can do extra setup works for the buffer through this function.")
+
+(declare-function gt-set-render "ext:go-translate")
+(declare-function gt-set-engines "ext:go-translate")
+(declare-function gt-translator-info "ext:go-translate")
+
+(cl-defmethod gt-prompt ((taker gt-taker) translator (_ (eql 'buffer)))
+ "Prompt the TAKER's result using a new buffer for TRANSLATOR.
+
+Only works when taker's prompt slot is config as `buffer:
+
+ :taker (gt-picker :prompt `buffer)
+
+Edit the text in buffer and confirm with `C-c C-c', you can also change
+target, engines and render in the buffer for the following translation."
+ (with-slots (text target render engines _render _engines) translator
+ (when (cdr text)
+ (user-error "Multiple text cannot be prompted"))
+ (cl-labels ((prop (s &optional fn not-key)
+ (let (args)
+ (unless not-key (setq args `(,@args face font-lock-keyword-face)))
+ (if fn (setq args `(,@args local-map (keymap (mode-line keymap (mouse-1 . ,fn)))
+ mouse-face font-lock-warning-face)))
+ (apply #'propertize (format "%s" s) args)))
+ (set-head-line ()
+ (setq header-line-format
+ (concat " " (cl-loop for (key . value) in `(("C-c C-c" . "to apply")
+ ("C-c C-k" . "to cancel"))
+ concat (format "%s %s " (prop key) value))
+ " " (propertize "Translate taking..." 'face 'font-lock-warning-face))))
+ (set-mode-line ()
+ (setq mode-line-format
+ (let ((ms (concat "C-c C-n: Next Target\nC-c C-p: Prev Target\n\n"
+ "C-c C-e: Set Engines\nC-c C-r: Set Render")))
+ (mapcar (lambda (item) (when item (propertize item 'help-echo ms)))
+ (cl-destructuring-bind (_ eg rd)
+ (ignore-errors (gt-translator-info translator))
+ (list (prop (concat
+ (if-let (src (car target)) (concat "[" (prop src) "] → "))
+ "[" (mapconcat (lambda (s) (prop s)) (cdr target) ", ") "]")
+ #'cycle-next-target t)
+ (if eg (concat " Engines: " (prop eg #'set-engines)))
+ (if rd (concat " Render: " (prop rd #'set-render)))))))))
+ (cycle-next-target (&optional backwardp)
+ (interactive)
+ (setf target
+ (gt-target taker (make-instance
+ (eieio-object-class translator)
+ :text (list (buffer-string)))
+ (if backwardp 'prev 'next)))
+ (set-mode-line))
+ (cycle-prev-target ()
+ (interactive)
+ (cycle-next-target t))
+ (set-engines ()
+ (interactive)
+ (gt-set-engines translator)
+ (set-mode-line))
+ (set-render ()
+ (interactive)
+ (gt-set-render translator)
+ (set-mode-line))
+ (set-local-keys ()
+ (local-set-key (kbd "C-c C-n") #'cycle-next-target)
+ (local-set-key (kbd "C-c C-p") #'cycle-prev-target)
+ (local-set-key (kbd "C-c C-e") #'set-engines)
+ (local-set-key (kbd "C-c C-r") #'set-render)))
+ (let* ((newtext (gt-read-from-buffer
+ :buffer gt-buffer-prompt-name
+ :initial-contents (or (car text) "")
+ :catch 'gt-buffer-prompt
+ :window-config gt-buffer-prompt-window-config
+ :keymap gt-buffer-prompt-map
+ (set-head-line)
+ (set-mode-line)
+ (set-local-keys)
+ (when gt-buffer-prompt-after-init-function
+ (funcall gt-buffer-prompt-after-init-function)))))
+ (when (null newtext)
+ (user-error ""))
+ (when (string-blank-p newtext)
+ (user-error "Text should not be null, abort"))
+ (setf text (ensure-list newtext))))))
+
+\f
+;;; [Taker] Pick only fresh words
+
+(defvar gt-fresh-word-class 'gt-fresh-word-with-file)
+
+(defvar gt-ripe-words-file (locate-user-emacs-file "gt-known-words.txt"))
+
+(defmacro gt-with-ripe-words-file (&rest form)
+ `(let* ((case-fold-search t)
+ (bufname " gt-known-words")
+ (buf (or (get-buffer bufname)
+ (progn
+ (unless (file-exists-p gt-ripe-words-file)
+ (write-region (point-min) (point-min) gt-ripe-words-file))
+ (find-file-noselect gt-ripe-words-file)))))
+ (with-current-buffer buf
+ (unless (equal (buffer-name) bufname)
+ (rename-buffer bufname))
+ (goto-char (point-min))
+ (prog1 (progn ,@form) (basic-save-buffer)))))
+
+(cl-defgeneric gt-word-fresh-p (word)
+ (:method ((_ (eql 'gt-fresh-word-with-file)) word)
+ (gt-with-ripe-words-file
+ (not (re-search-forward (concat "^" word "$") nil t))))
+ (gt-word-fresh-p gt-fresh-word-class word))
+
+(cl-defgeneric gt-fresh-word (&rest words)
+ (:method ((_ (eql 'gt-fresh-word-with-file)) &rest words)
+ (gt-with-ripe-words-file
+ (if (equal words (list t)) ; clear ripes
+ (erase-buffer)
+ (dolist (word words) ; remove from ripes
+ (goto-char (point-min))
+ (while (re-search-forward (concat "^" word "$") nil t)
+ (delete-region (match-beginning 0) (match-end 0))
+ (if (looking-at "\n") (delete-char 1)))))))
+ (apply #'gt-fresh-word gt-fresh-word-class words))
+
+(cl-defgeneric gt-ripen-word (&rest words)
+ (:method ((_ (eql 'gt-fresh-word-with-file)) &rest words)
+ (gt-with-ripe-words-file ; add to ripes
+ (dolist (word words)
+ (goto-char (point-min))
+ (unless (re-search-forward (concat "^" word "$") nil t)
+ (insert (downcase word) "\n")))))
+ (apply #'gt-ripen-word gt-fresh-word-class words))
+
+(defvar gt-fresh-words-last nil)
+
+(defun gt-record-words-as-known ()
+ "Record the words as known."
+ (interactive)
+ (let* ((si (string-join
+ (sort (delete-dups
+ (mapcar #'downcase
+ (or gt-fresh-words-last
+ (ensure-list (thing-at-point 'word))))))
+ " "))
+ (ss (read-string "Words to record as known: " si))
+ (ws (split-string ss)))
+ (apply #'gt-ripen-word ws)))
+
+(defun gt-record-words-as-unknown ()
+ "Record the words as unknown."
+ (interactive)
+ (let* ((ss (read-string "Words to record as unknown: " (thing-at-point 'word)))
+ (ws (split-string ss)))
+ (apply #'gt-fresh-word ws)))
+
+;; (gt-taker :pick 'fresh-word)
+
+(cl-defmethod gt-pick ((_ (eql 'fresh-word)) translator)
+ (with-slots (text bounds taker) translator
+ (setq gt-fresh-words-last nil)
+ (let* ((car (if (cdr bounds) (cl-subseq bounds 0 2) (car text)))
+ (pred (lambda (word)
+ (and (if-let (p (oref taker pick-pred)) (funcall p word) t)
+ (> (string-bytes word) 2)
+ (not (string-match-p "^[0-9]+$" word))
+ (gt-word-fresh-p word)
+ (push word gt-fresh-words-last)))))
+ (gt-pick-items-by-thing car 'word pred))))
+
+\f
+;;; [Taker] pdf-view-mode
+
+(declare-function pdf-view-active-region-p "ext:pdf-view.el" t t)
+(declare-function pdf-view-active-region-text "ext:pdf-view.el" t t)
+
+(cl-defmethod gt-text-at-point (_thing (_ (eql 'pdf-view-mode)))
+ (if (pdf-view-active-region-p)
+ (pdf-view-active-region-text)
+ (user-error "You should make a selection before translate")))
+
+(provide 'gt-extension)
+
+;;; gt-extension.el ends here
--- /dev/null
+;;; gt-faces.el --- Face definitions -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; The faces and colors.
+
+;;; Code:
+
+(require 'gt-core)
+
+(defgroup go-translate-faces nil
+ "The faces for this framework."
+ :group 'go-translate)
+
+\f
+;;; Common
+
+(defface gt-logger-buffer-tag-face '((t :inherit font-lock-comment-face))
+ "Used in the logger buffer tag keyword."
+ :group 'go-translate-faces)
+
+(defface gt-logger-buffer-timestamp-face '((t :foreground "grey"))
+ "Used in the logger buffer timestamp keyword."
+ :group 'go-translate-faces)
+
+(defface gt-render-prefix-face '((t :foreground "grey"))
+ "Used in the buffer's block prefix."
+ :group 'go-translate-faces)
+
+\f
+;;; Buffer Render
+
+(defface gt-buffer-render-header-lang-face '((t :inherit font-lock-keyword-face))
+ "Used in the buffer's `header-line-format' for langs."
+ :group 'go-translate-faces)
+
+(defface gt-buffer-render-header-desc-face '((t :inherit font-lock-variable-name-face))
+ "Used in the buffer's `header-line-format' for description."
+ :group 'go-translate-faces)
+
+(defface gt-buffer-render-source-face
+ '((((background light)) :background "ivory")
+ (((background dark)) :background "gray20" :foreground "gray" :weight light))
+ "Used in the buffer's source text."
+ :group 'go-translate-faces)
+
+(defface gt-buffer-render-inline-prefix-face
+ '((((background light)) :height 0.8 :foreground "grey")
+ (((background dark)) :height 0.8 :foreground "grey30"))
+ "Used in the buffer's inline prefix."
+ :group 'go-translate-faces)
+
+(defface gt-buffer-render-block-prefix-face '((t :background "slategray" :foreground "white" :extend t))
+ "Used in the buffer's block prefix."
+ :group 'go-translate-faces)
+
+(defface gt-buffer-render-error-face '((t :weight bold :inherit font-lock-comment-face))
+ "Used in the buffer's error text."
+ :group 'go-translate-faces)
+
+(defface gt-buffer-render-loading-face '((t :inherit font-lock-comment-face))
+ "Used in the buffer's loading messaget."
+ :group 'go-translate-faces)
+
+\f
+;;; Google Buffer Render
+
+(defface gt-google-buffer-headline-face '((t :inherit font-lock-function-name-face :weight bold))
+ "Propertize the headline in buffer rendering."
+ :group 'go-translate-faces)
+
+(defface gt-google-buffer-phonetic-face '((t :inherit font-lock-string-face :slant normal))
+ "Propertize the phonetic in buffer rendering."
+ :group 'go-translate-faces)
+
+(defface gt-google-buffer-suggestion-desc-face '((t :inherit font-lock-warning-face))
+ "Propertize the suggestion description in buffer rendering."
+ :group 'go-translate-faces)
+
+(defface gt-google-buffer-suggestion-text-face '((t :slant italic :underline t))
+ "Propertize the phonetic text in buffer rendering."
+ :group 'go-translate-faces)
+
+(defface gt-google-buffer-brief-result-face '((t :weight bold))
+ "Propertize the brief result in buffer rendering."
+ :group 'go-translate-faces)
+
+(defface gt-google-buffer-source-face '((t :inherit font-lock-string-face))
+ "Propertize the source in buffer rendering."
+ :group 'go-translate-faces)
+
+(defface gt-google-buffer-detail-demo-face '((t :inherit font-lock-doc-face))
+ "Propertize the detail demo in buffer rendering."
+ :group 'go-translate-faces)
+
+\f
+;;; Posframe Render
+
+(defcustom gt-pop-posframe-forecolor "white"
+ "Default foreground color of pop posframe."
+ :type 'string
+ :group 'go-translate-faces)
+
+(defcustom gt-pop-posframe-backcolor "black"
+ "Default background color of pop posframe."
+ :type 'string
+ :group 'go-translate-faces)
+
+(defcustom gt-pin-posframe-forecolor nil
+ "Default foreground color of pin posframe."
+ :type 'string
+ :group 'go-translate-faces)
+
+(defcustom gt-pin-posframe-backcolor nil
+ "Default background color of pin posframe."
+ :type 'string
+ :group 'go-translate-faces)
+
+(defcustom gt-pin-posframe-bdcolor "#000000"
+ "Default border color of pin posframe."
+ :type 'string
+ :group 'go-translate-faces)
+
+(defcustom gt-pin-posframe-fringe-color nil
+ "Used in the posframe pip buffer fringe color."
+ :type 'string
+ :group 'go-translate-faces)
+
+\f
+;;; Overlay Render
+
+(defface gt-overlay-source-face '((t :underline (:color "grey" :style wave)))
+ "Used in the overlay's source."
+ :group 'go-translate-faces)
+
+(defface gt-overlay-result-face '((t :inherit font-lock-string-face))
+ "Used in the overlay's result."
+ :group 'go-translate-faces)
+
+(defface gt-overlay-prefix-face '((t :inherit font-lock-comment-face))
+ "Used in the overlay's prefix."
+ :group 'go-translate-faces)
+
+\f
+;; Youdao
+
+(defface gt-youdao-dict-label-face '((((background light)) :foreground "lightblue")
+ (((background dark)) :foreground "darkcyan"))
+ "Face for label of youdao-dict."
+ :group 'go-translate-faces)
+
+(defface gt-youdao-dict-phonetic-face '((((background light)) :foreground "grey")
+ (((background dark)) :foreground "darkgray"))
+ "Face for phonetic of youdao-dict."
+ :group 'go-translate-faces)
+
+(defface gt-youdao-dict-entry-face '((t :bold t))
+ "Face for entry of youdao-dict."
+ :group 'go-translate-faces)
+
+(defface gt-youdao-suggest-entry-face '((t :bold t))
+ "Face for entry of youdao-suggest."
+ :group 'go-translate-faces)
+
+(defface gt-youdao-suggest-cixing-face '((((background light)) :foreground "grey")
+ (((background dark)) :foreground "grey"))
+ "Face for cixing of youdao-suggest."
+ :group 'go-translate-faces)
+
+\f
+;;; StarDict
+
+(defface gt-stardict-dict-face '((((background light)) :foreground "grey")
+ (((background dark)) :foreground "darkcyan"))
+ "Face for dict of StarDict."
+ :group 'go-translate-faces)
+
+(defface gt-stardict-word-face '((((background light)) :bold t :foreground "darkblue")
+ (((background dark)) :bold t))
+ "Face for word of StarDict."
+ :group 'go-translate-faces)
+
+(defface gt-stardict-phonetic-face '((((background light)) :foreground "lightblue")
+ (((background dark)) :foreground "darkcyan"))
+ "Face for phonetic of StarDict."
+ :group 'go-translate-faces)
+
+(defface gt-stardict-word-class-face '((t :bold t))
+ "Face for cixing of StarDict."
+ :group 'go-translate-faces)
+
+\f
+;;; Misc
+
+(defface gt-bionic-reading-face '((t :weight bold))
+ "Face for bionic reading word."
+ :group 'go-translate-faces)
+
+(provide 'gt-faces)
+
+;;; gt-faces.el ends here
--- /dev/null
+;;; gt-httpx.el --- Http Client -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+;; Package-Requires: ((emacs "28.1"))
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; Http client components used by the framework. With unified interface to
+;; compact different http backends.
+;;
+;; - Support both sync/async request
+;; - Support streaming request
+;; - Support retry for timeout
+;; - Support config proxies for backends
+;; - Support file upload/download
+;;
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'eieio)
+(require 'url)
+
+(if (fboundp 'gt-log)
+ (declare-function gt-log "ext:gt-core")
+ (defalias 'gt-log 'ignore))
+
+(if (fboundp 'gt-single)
+ (declare-function gt-single--eieio-childp "ext:gt-core")
+ (defclass gt-single () () :abstract t))
+
+(defun gt-http-binary-p (content-type)
+ "Check if current CONTENT-TYPE is binary."
+ (if (null content-type) nil
+ (cl-destructuring-bind (mime sub) (string-split content-type "/" nil "[ \n\r\t]")
+ (not (or (equal mime "text")
+ (and (equal mime "application")
+ (string-match-p "json\\|xml\\|php" sub)))))))
+
+(defun gt-format-params (alist)
+ "Format ALIST to k=v style query string."
+ (mapconcat (lambda (arg)
+ (format "%s=%s"
+ (url-hexify-string (format "%s" (car arg)))
+ (url-hexify-string (format "%s" (or (cdr arg) 1)))))
+ (delq nil alist) "&"))
+
+(defvar gt-multipart-boundary "gt-boundary-O0o0O69Oo")
+
+(defun gt-format-formdata (alist)
+ "Generate multipart/formdata string from ALIST."
+ (with-temp-buffer
+ (set-buffer-multibyte nil)
+ (cl-loop for (key . value) in alist for i from 1
+ for filep = nil for contentype = nil
+ do (setq key (format "%s" key))
+ do (if (consp value) ; ((afile "~/aaa.jpg" "image/jpeg"))
+ (setq contentype (or (cadr value) "application/octet-stream")
+ value (format "%s" (car value)) filep t)
+ (setq value (format "%s" value)))
+ for newline = "\r\n"
+ do (insert "--" gt-multipart-boundary newline)
+ if filep do (let ((fn (url-encode-url (url-file-nondirectory value))))
+ (insert "Content-Disposition: form-data; name=\"" key "\" filename=\"" fn "\"" newline)
+ (insert "Content-Type: " contentype newline newline)
+ (insert-file-contents-literally value)
+ (goto-char (point-max)))
+ else do (insert "Content-Disposition: form-data; name=\"" key "\"" newline newline value)
+ if (< i (length alist)) do (insert newline)
+ else do (insert newline "--" gt-multipart-boundary "--"))
+ (buffer-substring-no-properties (point-min) (point-max))))
+
+\f
+;;; Http Client
+
+(defclass gt-http-client (gt-single)
+ ((user-agent :initarg :user-agent :initform nil :type (or string null)))
+ "Used to send http request."
+ :abstract t)
+
+(defvar gt-http-client-max-retry 3)
+
+(defvar gt-user-agent "Mozilla/5.0 (X11; Linux x86_64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/86.0.4240.75 Safari/537.36")
+
+(defvar-local gt-http-client-stream-abort-flag nil
+ "Non-nil means to ignore following stream progress in callback of http filter.")
+
+(cl-defgeneric gt-request (http-client &rest _args &key url method headers data filter done fail sync retry &allow-other-keys)
+ "Send HTTP request using the given HTTP-CLIENT.
+
+Keyword arguments:
+ - URL: The URL to send the request to.
+ - METHOD: Request method, symbol like \\='post. If nil guess by data.
+ - HEADERS: Additional headers to include in the request. Alist.
+ - DATA: The data to include in the request. If this is a string, it will be
+ sent directly as request body. If this is a list and every element
+ is (key . value) then this will be joined to a string like a=1&b=2 and
+ then be sent. If this is a list and some element is (key filename)
+ format, then the list will be normalized as multipart formdata string
+ and be sent.
+ - FILTER: A function to be called every time when some data returned.
+ - DONE: A function to be called when the request succeeds.
+ - FAIL: A function to be called when the request fails.
+ - RETRY: How many times it can retry for timeout. Number.
+ - SYNC: Non-nil means request synchronized. Boolean.
+
+If request async, return the process behind the request."
+ (:method :around ((client gt-http-client) &rest args &key url method _headers data filter done fail sync retry)
+ ;; normalize and validate
+ (if (and (null filter) (null done)) (setq sync t args `(:sync t ,@args)))
+ (cl-assert (and url (or (and sync (not filter)) (and (not sync) (or filter done)))))
+ (if (null method) (setq args `(:method ,(if data 'post 'get) ,@args)))
+ ;; sync
+ (if sync (apply #'cl-call-next-method client args)
+ ;; async
+ (let* ((tag (eieio-object-class client))
+ (failfn (lambda (status)
+ ;; retry for timeout
+ (unless retry (setq retry gt-http-client-max-retry))
+ (if (and (string-match-p "Operation timeout" (format "%s" status)) (cl-plusp retry))
+ (progn (gt-log tag (format "request timeout, retrying (remains %d times)..." retry))
+ (apply #'gt-request client `(:retry ,(1- retry) ,@args)))
+ ;; failed finally
+ (gt-log tag (format "Request FAIL: (%s) %s" url status))
+ (if fail (funcall fail status)
+ (signal (car status) (cdr status))))))
+ (filterfn (when filter
+ (lambda ()
+ ;; abort action and error case
+ (unless gt-http-client-stream-abort-flag
+ (condition-case err
+ (funcall filter)
+ (error
+ (setq gt-http-client-stream-abort-flag t)
+ (gt-log tag (format "Error in filter: (%s) %s" url err))
+ (funcall failfn err)))))))
+ (donefn (lambda (raw)
+ (gt-log tag (format "✓ %s" url))
+ (when done (funcall done raw)))))
+ (apply #'cl-call-next-method client `(:fail ,failfn :filter ,filterfn :done ,donefn ,@args))))))
+
+\f
+;; http client implemented using `url.el'
+
+(defclass gt-url-http-client (gt-http-client)
+ ((proxy-services
+ :initarg :proxies
+ :initform nil
+ :type (or list null)
+ :documentation "Proxy services passed to `url.el', see `url-proxy-services' for details."))
+ :documentation "Http Client implemented using `url.el'.")
+
+(defvar url-http-content-type)
+(defvar url-http-end-of-headers)
+(defvar url-http-transfer-encoding)
+
+(defvar gt-url-extra-filter nil)
+
+(defun gt-url-http-extra-filter (beg end len)
+ (when (and gt-url-extra-filter (bound-and-true-p url-http-end-of-headers)
+ (if (equal url-http-transfer-encoding "chunked") (= beg end) ; when delete
+ (= len 0))) ; when insert
+ (save-excursion
+ (save-restriction
+ (narrow-to-region url-http-end-of-headers (point-max))
+ (funcall gt-url-extra-filter)))))
+
+(cl-defmethod gt-request ((client gt-url-http-client) &key url method headers data filter done fail sync retry)
+ (ignore retry)
+ (let* ((inhibit-message t)
+ (message-log-max nil)
+ (url-user-agent (or (oref client user-agent) gt-user-agent))
+ (url-proxy-services (or (oref client proxy-services) url-proxy-services))
+ (formdatap (and (consp data)
+ (or (string-match-p "multipart/formdata"
+ (or (alist-get "Content-Type" headers nil nil #'string-equal-ignore-case) ""))
+ (cl-some (lambda (x) (consp (cdr x))) data))))
+ (url-request-data (funcall (if (atom data) #'identity ; string
+ (if formdatap #'gt-format-formdata #'gt-format-params)) ; alist
+ data))
+ (url-request-extra-headers (progn
+ (when formdatap
+ (setf (alist-get "Content-Type" headers nil nil #'string-equal-ignore-case)
+ (concat "multipart/form-data; boundary=" gt-multipart-boundary)))
+ headers))
+ (url-request-method (string-to-unibyte (upcase (format "%s" method))))
+ (url-mime-encoding-string "identity")
+ (get-resp-content (lambda ()
+ (set-buffer-multibyte (not (gt-http-binary-p url-http-content-type)))
+ (buffer-substring-no-properties (min (1+ url-http-end-of-headers) (point-max)) (point-max)))))
+ ;; log
+ (gt-log (eieio-object-class client)
+ (format "> %s\n> %s" client url)
+ (if url-request-extra-headers (format "> HEADER: %S" url-request-extra-headers))
+ (if url-request-data (format "> DATA: %s" url-request-data)))
+ ;; sync
+ (if sync
+ (condition-case err
+ (let ((buf (url-retrieve-synchronously url nil t)))
+ (unwind-protect
+ (with-current-buffer buf
+ (let ((s (funcall get-resp-content))) (if done (funcall done s) s)))
+ (ignore-errors (kill-buffer buf))))
+ (error (if fail (funcall fail err) (signal 'user-error (cdr err)))))
+ ;; async
+ (let ((buf (url-retrieve url
+ (lambda (status)
+ (let ((cb (current-buffer)))
+ (remove-hook 'after-change-functions #'gt-url-http-extra-filter t)
+ (unwind-protect
+ (if-let (err (or (cdr-safe (plist-get status :error))
+ (when (or (null url-http-end-of-headers) (= 1 (point-max)))
+ (list 'empty-response "Nothing responsed from server"))))
+ (if fail (funcall fail err) (signal 'user-error err))
+ (if done (funcall done (funcall get-resp-content))))
+ (kill-buffer cb))))
+ nil t)))
+ (when (and filter (buffer-live-p buf))
+ (with-current-buffer buf
+ (setq-local gt-url-extra-filter filter)
+ (add-hook 'after-change-functions #'gt-url-http-extra-filter nil t)))
+ (get-buffer-process buf)))))
+
+\f
+;;; request with `curl' by package `plz.el'
+
+;; you should install `plz.el' first before use this
+
+(defclass gt-plz-http-client (gt-http-client)
+ ((extra-args
+ :initarg :args
+ :type list
+ :documentation "Extra arguments passed to curl programe."))
+ :documentation "Http Client implemented using `plz.el'.")
+
+(defvar plz-curl-program)
+(defvar plz-curl-default-args)
+(defvar plz-http-end-of-headers-regexp)
+
+(declare-function plz "ext:plz.el" t t)
+(declare-function plz-error-message "ext:plz.el" t t)
+(declare-function plz-error-curl-error "ext:plz.el" t t)
+(declare-function plz-error-response "ext:plz.el" t t)
+(declare-function plz-response-status "ext:plz.el" t t)
+(declare-function plz-response-body "ext:plz.el" t t)
+(declare-function plz--narrow-to-body "ext:plz.el" t t)
+
+(defvar gt-plz-initialize-error-message
+ "\n\nTry to install curl and specify the program like this to solve the problem:\n
+ (setq plz-curl-program \"c:/msys64/usr/bin/curl.exe\")\n
+Or switch http client to `gt-url-http-client' instead:\n
+ (setq gt-default-http-client (gt-url-http-client))")
+
+(cl-defmethod gt-request :before ((_ gt-plz-http-client) &rest _)
+ (unless (and (require 'plz nil t) (executable-find plz-curl-program))
+ (error "You should have `plz.el' and `curl' installed before using `gt-plz-http-client'")))
+
+(cl-defmethod gt-request ((client gt-plz-http-client) &key url method headers data filter done fail sync retry)
+ (ignore retry)
+ (let* ((plz-curl-default-args (if (slot-boundp client 'extra-args)
+ (append (oref client extra-args) plz-curl-default-args)
+ plz-curl-default-args))
+ (formdatap (and (consp data)
+ (or (string-match-p "multipart/formdata"
+ (or (alist-get "Content-Type" headers nil nil #'string-equal-ignore-case) ""))
+ (cl-some (lambda (x) (consp (cdr x))) data))))
+ (data (funcall (if (atom data) #'identity ; string
+ (if formdatap #'gt-format-formdata #'gt-format-params)) ; alist
+ data))
+ (string-or-binary (lambda () ; decode according content-type. there is no builtin way to do this in plz
+ (widen)
+ (let* ((content-type (mail-fetch-field "content-type"))
+ (binaryp (gt-http-binary-p content-type)))
+ (set-buffer-multibyte (not binaryp))
+ (goto-char (point-min))
+ (plz--narrow-to-body)
+ (unless binaryp (decode-coding-region (point-min) (point-max) 'utf-8))
+ (buffer-string)))))
+ ;; headers
+ (when formdatap
+ (setf (alist-get "Content-Type" headers nil nil #'string-equal-ignore-case)
+ (concat "multipart/form-data; boundary=" gt-multipart-boundary)))
+ (unless (alist-get "User-Agent" headers nil nil #'string-equal-ignore-case)
+ (push `("User-Agent" . ,(or (oref client user-agent) gt-user-agent)) headers))
+ ;; log
+ (gt-log (eieio-object-class client)
+ (format "> %s\n> %s" client url)
+ (if headers (format "> HEADER: %s" headers))
+ (if data (format "> DATA: %s" data))
+ (if plz-curl-default-args (format "> EXTRA: %s" plz-curl-default-args)))
+ ;; sync
+ (if sync
+ (condition-case err
+ (let ((r (plz method url
+ :headers headers
+ :body data
+ :body-type (if formdatap 'binary 'text)
+ :decode nil
+ :as string-or-binary
+ :then 'sync)))
+ (if done (funcall done r) r))
+ (error (if fail (funcall fail err)
+ (signal 'user-error (cdr err)))))
+ ;; async
+ (plz method url
+ :headers headers
+ :body data
+ :body-type (if formdatap 'binary 'text)
+ :decode nil
+ :as string-or-binary
+ :filter (when filter
+ (lambda (proc string)
+ (with-current-buffer (process-buffer proc)
+ (save-excursion
+ (goto-char (point-max))
+ (insert string)
+ (goto-char (point-min))
+ (when (re-search-forward plz-http-end-of-headers-regexp nil t)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (funcall filter)))))))
+ :then (lambda (raw)
+ (when done (funcall done raw)))
+ :else (lambda (err)
+ (let ((ret ;; try to compat with error object of url.el, see `url-retrieve' for details
+ (or (plz-error-message err)
+ (when-let (r (plz-error-curl-error err))
+ (list 'curl-error
+ (concat (format "%s" (or (cdr r) (car r)))
+ (pcase (car r)
+ (2 (when (memq system-type '(cygwin windows-nt ms-dos))
+ gt-plz-initialize-error-message))))))
+ (when-let (r (plz-error-response err))
+ (list 'http (plz-response-status r) (plz-response-body r))))))
+ (if fail (funcall fail ret)
+ (signal 'user-error ret))))))))
+
+(provide 'gt-httpx)
+
+;;; gt-httpx.el ends here
--- /dev/null
+;;; gt-text-utility.el --- Text utilities base on the translator -*- lexical-binding: t -*-
+
+;; Copyright (C) 2024 lorniu <lorniuNOSPAMgmail.com>
+;; Author: lorniu <lorniuNOSPAMgmail.com>
+
+;; SPDX-License-Identifier: GPL-3.0-or-later
+
+;; 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 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;; This file is NOT part of GNU Emacs.
+
+;;; Commentary:
+
+;; Integrate md5, sha1, base64, qrcode and others into this translation framework.
+;;
+;; Shows that this framework is more than just translation purposes.
+;;
+;; Use like this:
+;;
+;; \\=(gt-start (gt-text-utility :render (gt-buffer-render)))
+;;
+;; To avoid be prompted, specify the targets like this:
+;;
+;; \\=(gt-start (gt-text-utility :taker (gt-taker :langs '(md5 sha1)) :render (gt-insert-render)))
+
+;;; Code:
+
+(require 'gt-extension)
+
+(defvar gt-text-utilities `(base64 rot13 qrcode speak ,@(secure-hash-algorithms))
+ "List of available targets for `gt-text-utility-engine'.")
+
+(defclass gt-text-utility (gt-translator) ())
+
+(defclass gt-text-utility-engine (gt-engine)
+ ((tag :initform 'Text-Utility)
+ (cache :initform nil)
+ (delimiter :initform nil)))
+
+(cl-defmethod gt-reset :after ((translator gt-text-utility) &rest _)
+ (with-slots (_engines) translator
+ (unless _engines (setf _engines (gt-text-utility-engine)))
+ (setf _engines (ensure-list _engines))
+ (unless (and (not (cdr _engines)) (cl-typep (car _engines) 'gt-text-utility-engine))
+ (user-error "%s should use only one gt-text-utility-engine as engine" (gt-desc translator)))))
+
+(cl-defmethod gt-target ((taker gt-taker) (_ gt-text-utility) &rest _)
+ (let ((tgts (if (slot-boundp taker 'langs)
+ (ensure-list (oref taker langs))
+ (mapcar #'intern
+ (completing-read-multiple
+ "Utilities (can choose multiple): " gt-text-utilities
+ nil t nil 'gt-text-utility-hist)))))
+ (unless tgts (user-error "No targets found"))
+ (cons nil (cl-delete-duplicates tgts))))
+
+(cl-defmethod gt-translate ((_ gt-text-utility-engine) task _)
+ "Translate and render the result directly, skip parse and other steps."
+ (with-slots (text tgt res translator) task
+ (setf res (mapcar (lambda (c) (gt-text-util tgt (encode-coding-string c 'utf-8))) text))
+ (gt-update-state translator)
+ (gt-output (oref translator render) translator)))
+
+(cl-defmethod gt-keybinds ((_buffer gt-buffer-render) (_ gt-text-utility))
+ (gt-buffer-render-key ("t" "Cycle Next") #'gt-buffer-render--cycle-next)
+ (gt-buffer-render-key ("g" "Refresh") #'gt-buffer-render--refresh)
+ (gt-buffer-render-key ("q" "Quit") #'kill-buffer-and-window)
+ (gt-buffer-render-key ("C-x C-q") #'gt-buffer-render--toggle-readonly)
+ (gt-buffer-render-key ("?") #'gt-buffer-render--show-tips))
+
+\f
+
+(cl-defgeneric gt-text-util (target text)
+ "Dispatch to different TEXT utility methods for different TARGET."
+ (:method ((_ (eql 'base64)) text) (base64-encode-string text t))
+ (:method ((_ (eql 'rot13)) text) (rot13 text))
+ (:method ((_ (eql 'qrcode)) text) (gt-qrcode text))
+ (:method ((_ (eql 'speak)) text) (gt-text-speak-button text))
+ (if (member target (secure-hash-algorithms))
+ (secure-hash target text)
+ (user-error "Unimplemented")))
+
+(defun gt-text-speak-button (str)
+ (propertize str
+ 'display " click to speak... "
+ 'pointer 'hand
+ 'keymap (gt-simple-keymap [mouse-1] (lambda () (interactive) (gt-speak 'interact str t)))
+ 'face '(:box t)
+ 'mouse-face '(:reverse-video t :inherit font-lock-warning-face)))
+
+(declare-function qrencode "ext:qrencode.el" t t)
+
+;;;###autoload
+(defun gt-qrcode (str)
+ "Genrate QR Code for STR."
+ (interactive (list (read-string "String to generate QRCode: ")))
+ (let ((code (if (executable-find "qrencode")
+ (with-temp-buffer
+ (let ((coding-system-for-read 'raw-text))
+ (set-buffer-multibyte nil)
+ (insert str)
+ (shell-command-on-region (point-min) (point-max) "qrencode -t PNG -o -" (current-buffer))
+ (if (string-match-p "PNG" (buffer-substring 1 (min (point-max) 8)))
+ (propertize " " 'display `(image :type png :data ,(buffer-string) :width 200))
+ (user-error (buffer-string)))))
+ (if (require 'qrencode nil t)
+ (qrencode str)
+ (user-error "Install program `qrencode' or package `qrencode.el' first to generate QR Code")))))
+ (if (called-interactively-p 'any) (message "%s" code) code)))
+
+(provide 'gt-text-utility)
+
+;;; gt-text-utility.el ends here
+++ /dev/null
-;;; graphql-mode-autoloads.el --- automatically extracted autoloads -*- lexical-binding: t -*-
-;;
-;;; Code:
-
-(add-to-list 'load-path (directory-file-name
- (or (file-name-directory #$) (car load-path))))
-
-\f
-;;;### (autoloads nil "graphql-mode" "graphql-mode.el" (0 0 0 0))
-;;; Generated autoloads from graphql-mode.el
-
-(autoload 'graphql-mode "graphql-mode" "\
-A major mode to edit GraphQL schemas.
-
-\(fn)" t nil)
-
-(add-to-list 'auto-mode-alist '("\\.graphql\\'" . graphql-mode))
-
-(add-to-list 'auto-mode-alist '("\\.gql\\'" . graphql-mode))
-
-(register-definition-prefixes "graphql-mode" '("graphql-"))
-
-;;;***
-\f
-;; Local Variables:
-;; version-control: never
-;; no-byte-compile: t
-;; no-update-autoloads: t
-;; coding: utf-8
-;; End:
-;;; graphql-mode-autoloads.el ends here
projects / emacsconfig.git / commitdiff