;;; gloss.el --- major mode for glossaries  -*- lexical-binding: t; -*-

;; Copyright (C) 2021 John Ankarström

;; Author: John Ankarström <john@ankarstrom.se>
;; Created: 1 Dec 2021
;; Version: 0.1

;; Keywords: linguistics
;; URL: http://ankarstrom.se/~john/emacs/gloss.el

;; This file is not part of GNU Emacs.

;; Permission to use, copy, modify and/or
;; distribute this software for any purpose
;; with or without fee is hereby granted.

;;; Commentary:

;; gloss-mode is a major mode for glossaries, i.e. lists of foreign
;; words with notes and translations.

;;; Code:

;;;###autoload
(define-derived-mode gloss-mode
  fundamental-mode "Gloss"
  "Major mode for glossaries."
  (visual-line-mode)
  (when (fboundp 'adaptive-wrap-prefix-mode)
    (adaptive-wrap-prefix-mode))
  (buffer-face-set :family "sans" :height 110)
  (set-syntax-table gloss--syntax-table)
  (setq-local font-lock-defaults '(gloss--font-lock-defaults))
  (setq-local inhibit-field-text-motion t)
  (setq-local require-final-newline t)
  (setq-local font-lock-extra-managed-props (list 'field
						  'help-echo
						  'invisible
						  'keymap
						  'mouse-face)))

(defface gloss-*-line
  '((t :foreground "dark gray"
       :height 0.909090
       :family "mono"))
  "Face for -*- line in `gloss-mode'.")

(defface gloss-url-link
  '((t :foreground "LightYellow4"))
  "Face for URL links in `gloss-mode'.")

(defface gloss-gloss-link
  '((t :foreground "red4"))
  "Face for gloss links in `gloss-mode'.")

(defconst gloss--font-lock-defaults
  '(("\\`[^\n]*?\\(-\\*-[^\n]*-\\*-\\)"
     (1 (list 'face 'gloss-*-line)))
    ("\\(<\\)https?://\\(?:www\\.\\)?\\([^>/\n[:blank:]]+\\)\\(?:/[^>\n[:blank:]]+\\)?\\(>\\)"
     (0 (list 'face nil
	      'field 'url
	      'invisible t))
     (1 (list 'face nil
	      'field nil))
     (2 (list 'face 'gloss-url-link
	      'mouse-face 'highlight
	      'invisible nil
	      'keymap gloss--link-map
	      'help-echo "Open link (mouse-2)")
	append)
     (3 (list 'face nil
	      'field nil)))
    ("\\[\\([^][:blank:]]+\\)\\]"
     (0 (list 'face nil
	      'invisible t))
     (1 (list 'face 'gloss-gloss-link
	      'field 'gloss
	      'mouse-face 'highlight
	      'invisible nil
	      'keymap gloss--link-map
	      'help-echo "Go to gloss (mouse-2)")
	append))))

(defconst gloss--syntax-table
  (let ((table (make-syntax-table)))
    (modify-syntax-entry ?\[ "w" table)
    (modify-syntax-entry ?\] "w" table)
    (modify-syntax-entry ?\" "." table)
    table))

(defvar gloss--include-quotes nil
  "Count quoted glosses. If this is set to nil, quoted words and phrases
are not treated as glosses.

Some commands optionally accept a prefix argument to temporarily
enable this option.")

(defvar gloss--link-map (make-sparse-keymap))

(defvar-local gloss--use-alt-browse-url nil)

(defvar gloss-alt-browse-url #'w3m-goto-url
  "Alternative `browse-url' function.")

(defvar gloss-wiktionary-language nil
  "Default language for Wiktionary.")

(define-key gloss--link-map " " #'gloss-edit-link)
(define-key gloss--link-map [return] #'gloss-follow-link)
(define-key gloss--link-map [mouse-2] #'gloss-follow-link--event)

(define-key gloss--link-map [menu-bar gloss-link] (cons "Gloss-Link" (make-sparse-keymap "Gloss-Link")))
(define-key gloss--link-map [menu-bar gloss-link edit-link] (cons "Edit link" #'gloss-edit-link))
(define-key gloss--link-map [menu-bar gloss-link follow-link] (cons "Follow link" #'gloss-follow-link))

(define-key gloss-mode-map (kbd "C-c C-c C-l") #'gloss-add-link)
(define-key gloss-mode-map (kbd "C-c C-b") #'gloss-toggle-browser)
(define-key gloss-mode-map [remap backward-paragraph] #'gloss-previous)
(define-key gloss-mode-map [remap forward-paragraph] #'gloss-next)

(define-key gloss-mode-map [menu-bar gloss] (cons "Gloss" (make-sparse-keymap "Gloss")))
(define-key gloss-mode-map [menu-bar gloss add-link] (cons "Add custom link to gloss" #'gloss-add-link))
(define-key gloss-mode-map [menu-bar gloss toggle-browser] (cons "Toggle browser" #'gloss-toggle-browser))

(progn
  (defmacro gloss--defextern (name key arglist &rest body)
    (declare (indent 3))
    (let* ((string (symbol-name name))
	   (url-fun (intern (concat "gloss--url-" string)))
	   (lookup-fun (intern (concat "gloss-lookup-" string)))
	   (lookup-menu (intern (concat "lookup-" string)))
	   (lookup-help (format "Look up gloss with %s" (capitalize string)))
	   (add-fun (intern (concat "gloss-add-" string)))
	   (add-menu (intern (concat "add-" string)))
	   (add-help (format "Add %s link to gloss" (capitalize string))))
      `(progn
	 (defun ,url-fun ,arglist ,@body)
	 (defun ,lookup-fun (&optional arg gloss)
	   ,(concat lookup-help ".")
	   (interactive "P")
	   (let ((gloss--include-quotes arg))
	     (gloss--browse-url (,url-fun (or gloss
					      (if (region-active-p)
						  (buffer-substring (region-beginning) (region-end)))
					      (gloss-closest))))))
	 (defun ,add-fun (&optional arg)
	   ,(concat add-help ".")
	   (interactive "P")
	   (let ((gloss--include-quotes arg))
	     (gloss--add-link (,url-fun (gloss-closest)))))
	 (define-key gloss-mode-map (kbd ,(concat "C-c C-" key)) (function ,lookup-fun))
	 (define-key gloss-mode-map [menu-bar gloss ,lookup-menu] (cons ,lookup-help (function ,lookup-fun)))
	 (define-key gloss-mode-map (kbd ,(concat "C-c C-c C-" key)) (function ,add-fun))
	 (define-key gloss-mode-map [menu-bar gloss ,add-menu] (cons ,add-help (function ,add-fun))))))

  (gloss--defextern google "s" (gloss)
    (format "https://www.google.com/search?q=%s&ie=UTF-8&gbv=1"
	    (url-encode-url (concat gloss " definition OR wiktionary"))))

  (gloss--defextern wiktionary "w" (gloss)
    (format "https://en.wiktionary.org/wiki/%s%s"
	    (url-encode-url gloss)
	    (if gloss-wiktionary-language
		(concat "#" (url-encode-url (with-output-to-string (princ gloss-wiktionary-language))))
	      ""))))

(defun gloss--add-link (link)
  "Add a line containing LINK to the beginning of closest gloss."
  (save-excursion
    (gloss-beginning)
    (forward-line)
    (insert "<" link ">" ?\n)))

(defun gloss--browse-url (url)
  (if gloss--use-alt-browse-url
      (funcall gloss-alt-browse-url url)
    (browse-url url)))

(defun gloss-add-link (&optional arg link)
  "Add LINK to closest gloss.

If a prefix argument is given, count quoted glosses too."
  (interactive "P\nsLink: ")
  (let ((gloss--include-quotes arg))
    (gloss--add-link link)))

(defun gloss-beginning (&optional forward)
  "Go to beginning of closest gloss and return point.

If FORWARD is non-nil, look forward instead of backward."
  (interactive)
  (backward-paragraph (if forward -1))
  (forward-line)
  (skip-chars-forward "\n\t ")
  (if (and (not gloss--include-quotes)
	   (memq (char-after) (list ?\" ?\「)))
      (progn
	(when (not forward)
	  (forward-line -1))
	(gloss-beginning forward))
    (point)))

(defun gloss-closest (&optional forward)
  "Return gloss (word or phrase) closest to point.

If FORWARD is non-nil, look forward instead of backward."
  (save-excursion
    (let ((beg (gloss-beginning forward)))
      (when (and (= (skip-syntax-forward "w") 0)
		 gloss--include-quotes)
	(skip-chars-forward "\"「")
	(setq beg (point))
	(end-of-line)
	(skip-chars-backward "\"」"))
      (replace-regexp-in-string "[][]" "" (buffer-substring beg (point))))))

(defun gloss-edit-link ()
  "Edit link at point."
  (interactive)
  (let* ((beg (field-beginning))
	 (end (field-end))
	 (initial (cons (field-string-no-properties) (1+ (- (point) beg))))
	 (string (read-string "Link: " initial nil nil t)))
    (replace-region-contents beg end (lambda () string))))

(defun gloss-find (gloss)
  "Find and go to GLOSS in current buffer."

  ;; Square brackets are allowed in gloss names. They are ignored in
  ;; the regular expression by adding [][]? between every character.
  (let ((regexp (string-join (mapcar #'regexp-quote (split-string gloss "")) "[][]?")))
    (if (save-excursion
	  (goto-char (point-min))
	  (re-search-forward (concat "^" regexp "\\([^[:word:]][^\n]*\\|\\n\\)") nil t))
	(progn
	  (push-mark)
	  (goto-char (match-beginning 0)))
      (message (format "Cannot find gloss %s" gloss)))))

(defun gloss-follow-link (&optional point)
  "Follow link at point."
  (interactive)
  (let* ((point (+ (or point (point))
		   (if (memq (field-at-pos point) (list 'url 'gloss))
		       0
		     1)))
	 (string (field-string-no-properties
		  point)))
    (pcase (field-at-pos point)
      ('gloss (gloss-find string))
      ('url (gloss--browse-url string)))))

(defun gloss-follow-link--event (event)
  "Event-based version of `gloss-follow-link'."
  (interactive "e")
  (with-current-buffer (window-buffer (posn-window (event-end event)))
    (gloss-follow-link (posn-point (event-end event)))))

(defun gloss-next (&optional arg)
  "Go to beginning of next gloss and return point.

If a prefix argument is given, count quoted glosses too."
  (interactive "P")
  (let ((gloss--include-quotes arg))
    (gloss-beginning t)))

(defun gloss-previous (&optional arg)
  "Go to beginning of previous gloss and return point.

If a prefix argument is given, count quoted glosses too."
  (interactive "P")
  (let ((gloss--include-quotes arg))
    (forward-line -1)
    (gloss-beginning)))

(defun gloss-toggle-browser ()
  "Toggle between `browse-url' and the value of `gloss-alt-browse-url'."
  (interactive)
  (if gloss--use-alt-browse-url
      (progn (setq gloss--use-alt-browse-url nil)
	     (setq mode-name "Gloss")
	     (message "Using standard browser"))
    (setq gloss--use-alt-browse-url t)
    (setq mode-name "Gloss*")
    (message "Using alternative browser")))

(provide 'gloss)

;;; gloss.el ends here

;; Local Variables:
;; easy-namespace-local-prefix: gloss
;; easy-namespace-local-alias: g
;; End: