+++ /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
+;;; 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-osxdict.el
+
+(register-definition-prefixes "gt-engine-osxdict" '("gt-osxdict-"))
+
+\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" "20250318.907"
+ "Translation framework, configurable and scalable."
+ '((emacs "28.1"))
+ :url "https://github.com/lorniu/go-translate"
+ :commit "a924e0bd6b37d424c222377982e6f71a4ddf4452"
+ :revdesc "a924e0bd6b37"
+ :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: 20250318.907
+;; Package-Revision: a924e0bd6b37
+
+;; 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-osxdict)
+(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)))
+ (OSX-Dictionary . ,(gt-osxdict-engine))
+ (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 (with-temp-buffer
+ (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)
+ (path :initarg :path :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-path "/v1/chat/completions"
+ "API endpoint 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 path 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) (or path gt-chatgpt-path))
+ :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-osxdict.el --- OSX-Dictionary -*- 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 osx-dictionary (macOS only).
+;;
+;; osx-dictionary, a program written by itchyny, is Dictionary.app interface for macOS.
+;; I know it from https://github.com/xuchunyang/osx-dictionary.el. This engine is working
+;; with it, and can be used offline for macOS user.
+;;
+;; Make sure program `osx-dictionary' is on your PATH, or config it with `gt-osxdict-program'.
+;;
+;; Source: https://github.com/itchyny/dictionary.vim/tree/master/autoload/dictionary.m
+;; Build: clang -framework CoreServices -framework Foundation dictionary.m -o osx-dictionary
+;;
+;;; Code:
+
+(require 'gt-extension)
+
+(defclass gt-osxdict-parser (gt-parser) ())
+
+(defclass gt-osxdict-engine (gt-engine)
+ ((tag :initform 'osx-dictionary)
+ (program :initarg :program :initform nil :documentation "Path of osx-dictionary")
+ (delimiter :initform nil)
+ (cache :initform nil)
+ (parse :initform (gt-osxdict-parser))))
+
+(defvar gt-osxdict-program "osx-dictionary"
+ "Executable command or full path of osx-dictionary.")
+
+(cl-defmethod gt-translate ((engine gt-osxdict-engine) task next)
+ (let ((program (or (oref engine program) gt-osxdict-program)))
+ (unless (executable-find program)
+ (user-error (format "[gt-osxdict-engine] Make sure executable `%s' is available'.\n
+ Source: https://github.com/itchyny/dictionary.vim/tree/master/autoload/dictionary.m
+ Build: clang -framework CoreServices -framework Foundation dictionary.m -o %s
+" program program)))
+ (with-slots (text res) task
+ (when (cdr text)
+ (user-error "[gt-osxdict-engine] Multiple parts translation is not supported"))
+ (with-temp-buffer
+ (ignore-errors
+ (apply #'call-process program nil t nil text)
+ (setf res (buffer-string))))
+ (if (string-empty-p res) (setf res nil))
+ (funcall next task))))
+
+(cl-defmethod gt-parse ((_ gt-osxdict-parser) task)
+ (with-slots (res) task
+ (with-temp-buffer
+ (insert res)
+ ;; This is written casually, should be improved.
+ ;; https://github.com/itchyny/dictionary.vim/blob/master/syntax/dictionary.vim
+ (cl-loop for (regexp . face) in
+ '(("|.+|" . font-lock-comment-face)
+ ("^ *▸.*" . font-lock-string-face)
+ ("^ *[A-Z]\\..*" . bold-italic))
+ do (goto-char (point-min))
+ do (while (re-search-forward regexp nil t)
+ (put-text-property (match-beginning 0) (match-end 0) 'face face)))
+ (setf res (buffer-string)))))
+
+(provide 'gt-engine-osxdict)
+
+;;; gt-engine-osxdict.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-thing-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 <lorniu@gmail.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
projects / emacsconfig.git / commitdiff