;;; gadict.el --- major mode for editing gadict dictionary source files -*- lexical-binding: t -*-

;; Copyright (C) 2016 by Oleksandr Gavenko <gavenkoa@gmail.com>

;; You can do anything with this file without any warranty.

;; Author: Oleksandr Gavenko <gavenkoa@gmail.com>
;; Maintainer: Oleksandr Gavenko <gavenkoa@gmail.com>
;; Created: 2016
;; Version: 0.1
;; Keywords: dict, dictionary

;;; Commentary:
;;
;; Mode can be installed by:
;;
;;   (autoload 'gadict-mode "gadict")
;;
;; File association can be registered by:
;;
;;   (add-to-list 'auto-mode-alist (cons "\\.gadict$" 'gadict-mode))

;;; Code:

(defun gadict--trim-left (s)
  "Remove whitespace at the beginning of S."
  (if (string-match "\\`[ \t\n\r]+" s)
      (replace-match "" t t s)
    s))

(defun gadict--trim-right (s)
  "Remove whitespace at the end of S."
  (if (string-match "[ \t\n\r]+\\'" s)
      (replace-match "" t t s)
    s))

(defun gadict--trim (s)
  "Remove whitespace at the beginning and end of S."
  (gadict--trim-left (gadict--trim-right s)))



(defconst gadict--vowels-re "[o$(O+8+:+7+9(Ba$(O+3+0,Af(Be,0#$(O+1(Bi,0!(Bu$(O+5+C+U+S+T(B]+")

(defun gadict--vowel-group-count (s)
  (let ( (cnt 0) (start 0) )
    (while (string-match gadict--vowels-re s start)
      (setq cnt (1+ cnt))
      (setq start (match-end 0)))
    cnt))

(defun gadict--espeak-cleanup-accent (s)
  "Remove accent if only one syllable in word."
  (if (<= (gadict--vowel-group-count s) 1)
      (replace-regexp-in-string "[$,1$h$l(B]" "" s)
    s))

(defun gadict--espeak-cleanup-accent-in-sentence (s)
  "Remove accent if only one syllable in word."
  (mapconcat #'gadict--espeak-cleanup-accent (split-string s " ") " "))

(defun gadict--espeak-cleanup (s)
  "Cleanup espeak IPA output."
  (mapc (lambda (fn) (setq s (funcall fn s)))
        (list
         ;; UTF symbol between t$(O*h(B to make ligature.
         (lambda (str) (replace-regexp-in-string "[\x200D]" "" str))
         (lambda (str) (replace-regexp-in-string "t$(O*h(B" "$,1$G(B" str))
         (lambda (str) (replace-regexp-in-string "$,1k{(B" ",0!(B" str))
         #'gadict--trim
         #'gadict--espeak-cleanup-accent-in-sentence))
  s)

(defvar gadict-espeak-enabled nil
  "Is espeak used.")

(defvar gadict-espeak-program "espeak")
(defvar gadict-espeak-program-ipa-args "-q --ipa=2")
;; "en" "en-gb" "en-us" "en-sc"
(defvar gadict-espeak-voices-list '("en-gb" "en-us")
  "What voices to show. Look to 'espeak --voices' for full list.")
(defvar gadict-espeak-default-voice "en-us"
  "Default voice for espeak. Used in article template.")

(defun gadict-espeak-ipa (str &optional voice)
  (gadict--espeak-cleanup
   (shell-command-to-string
    (format "%s %s %s %s"
            gadict-espeak-program
            gadict-espeak-program-ipa-args
            (if (stringp voice) (concat "-v" (shell-quote-argument voice)) "")
            (shell-quote-argument str)))))

(defun gadict-espeak-headline-line (headword)
  (mapconcat (lambda (voice) (format "%s: %s"
                                (propertize voice 'face '(:foreground "red"))
                                (gadict-espeak-ipa headword voice)))
             (if (listp gadict-espeak-voices-list) gadict-espeak-voices-list '(nil))
             " | "))

;; (defun gadict-espeak-headline-display ()
;;   (interactive)
;;   (message (gadict-espeak-headline-line)))

(defvar gadict-espeak-headline-headword nil)

(defun gadict-espeak-headline-display ()
  (when (eq major-mode 'gadict-mode)
    (let ( (headword (condition-case nil (gadict-nearest-headword) (error nil))) )
      (unless (eq headword gadict-espeak-headline-headword)
        (setq gadict-espeak-headline-headword headword)
        (setq header-line-format (if headword (gadict-espeak-headline-line headword) nil))
        (force-mode-line-update)))))

(defvar gadict-espeak-headline-timer nil)
(defun gadict-espeak-headline-enable ()
  "Enable headline with espeak IPA pronunciation."
  (interactive)
  (unless gadict-espeak-headline-timer
    (setq gadict-espeak-headline-timer (run-with-idle-timer 1 t #'gadict-espeak-headline-display))))
(defun gadict-espeak-headline-disable ()
  "Enable headline with espeak IPA pronunciation."
  (interactive)
  (when gadict-espeak-headline-timer
    (cancel-timer gadict-espeak-headline-timer))
  (setq gadict-espeak-headline-timer nil)
  (setq header-line-format nil))



(defconst gadict--pos '("n" "v" "adj" "adv" "pron" "det" "prep" "num" "conj" "int" "phr" "phr.v" "contr" "abbr" "prefix")
  "Defined parts of speech.")

(defconst gadict--art-lang-regex (regexp-opt '("en" "ru" "uk" "la")))
(defconst gadict--art-rel-regex (regexp-opt '("cnt" "ant" "syn" "rel" "topic" "hyper" "hypo" "col")))
(defconst gadict--art-var-regex (regexp-opt '("rare" "v1" "v2" "v3" "s" "pl" "male" "female" "baby" "abbr" "comp" "super" "Am" "Br" "Au")))
(defconst gadict--art-pos-regex (regexp-opt gadict--pos))

(defgroup gadict nil
  "gadict-mode customization."
  :group 'wp)

(defface gadict-tr-face '((t :foreground "#40a040" :slant italic))
  "Face for marker of translation."
  :group 'gadict)
(defface gadict-ex-face '((t :foreground "#20a0c0" :slant italic))
  "Face for marker of example."
  :group 'gadict)
(defface gadict-glos-face '((t :foreground "#a04040" :slant italic))
  "Face for marker of explanation."
  :group 'gadict)

(defvar gadict-font-lock-keywords
  `( ("^\\(__\\)\n\n\\(\\w.*\\)$" (1 font-lock-function-name-face) (2 font-lock-keyword-face))
     ("^ .*\n\\(\\w.*\\)" (1 font-lock-keyword-face))
     ("^#.*" . font-lock-comment-face)
     ("^ +\\[[^]\n:]+]" . font-lock-type-face)
     ("^ +homo: " . 'gadict-tr-face)
     (,(format "^%s: " gadict--art-lang-regex) . 'gadict-tr-face)
     (,(format "^%s> " gadict--art-lang-regex) . 'gadict-ex-face)
     (,(format "^%s= " gadict--art-lang-regex) . 'gadict-glos-face)
     (,(format "^%s: " gadict--art-rel-regex) . font-lock-doc-face)
     (,(format "^ +%s$" gadict--art-var-regex) . font-lock-doc-face)
     (,(format "^%s$" gadict--art-pos-regex) . font-lock-warning-face) ))

(defun gadict-setup-fontlock ()
  "Setup gadict fontlock."
  (setq font-lock-defaults
        '(gadict-font-lock-keywords
          t nil nil nil
          (font-lock-multiline . t) ))
  (add-hook 'font-lock-extend-region-functions 'gadict-font-lock-extend-region t) )

(defun gadict-setup-syntax ()
  "Setup gadict characters syntax."
  (modify-syntax-entry ?' "w"))

(defun gadict-setup-comment ()
  "Setup gadict comment commands."
  (set (make-local-variable 'comment-start)  "#")
  (set (make-local-variable 'comment-continue)  nil)
  (set (make-local-variable 'comment-end)  "")
  (set (make-local-variable 'comment-end-skip)  nil)
  (set (make-local-variable 'comment-multi-line)  nil)
  (set (make-local-variable 'comment-use-syntax)  nil) )

(defun gadict-setup-paragraph ()
  "Setup gadict sentence/paragraph definition."
  (set (make-local-variable 'paragraph-separate)  "__$")
  (set (make-local-variable 'paragraph-start)  "__$")
  (set (make-local-variable 'sentence-end) "\n"))

(defun gadict-setup-page ()
  "Setup gadict page definition."
  (set (make-local-variable 'page-delimiter)  "__$") )

(defvar gadict-indent-offset 2
  "Indent level.")

(defun gadict-indent-line ()
  "Indent line in gdict mode."
  (if (eq (current-indentation) gadict-indent-offset)
      (indent-line-to 0)
    (indent-line-to gadict-indent-offset)))

(defun gadict-setup-indent ()
  "Setup indenting for gdict mode."
  (set (make-local-variable 'indent-line-function) 'gadict-indent-line))

(defun gadict-mark-article ()
  "Mark current article."
  (end-of-line)
  (re-search-backward "^__$")
  (set-mark (point))
  (forward-line)
  (if (re-search-forward "^__$" nil t)
      (forward-line 0)
    (goto-char (point-max)))
  (exchange-point-and-mark))

(defun gadict-mark-line ()
  "Mark current line."
  (forward-line 0)
  (set-mark (point))
  (forward-line 1)
  (exchange-point-and-mark))

(defvar er/try-expand-list)
(defun gadict-setup-expansions ()
  "Add `gadict-mode' specific expansions."
  (set (make-local-variable 'er/try-expand-list) (list #'er/mark-word #'gadict-mark-line #'gadict-mark-article)))

(defvar font-lock-beg)
(defvar font-lock-end)
(defun gadict-font-lock-extend-region ()
  "Look for '__' expression and extend `font-lock-beg' and `font-lock-end'."
  ;; (message "%d:%d, %d lines" font-lock-beg font-lock-end (count-lines font-lock-beg font-lock-end))
  (cond
   ((and
     (< (count-lines font-lock-beg font-lock-end) 5)
     (not (and (<= (point-max) font-lock-end) (<= font-lock-beg (point-min)) )))
    (save-excursion
      (goto-char font-lock-beg)
      (forward-line -2)
      (setq font-lock-beg (point))
      (goto-char font-lock-end)
      (forward-line 3)
      (setq font-lock-end (point)))
    t)
   (t nil) ))

(defvar-local gadict-tr nil
  "Translation markers as string separated by comma. Define own
  values in .dir-local.el or as -*- gadict-tr: \"...\" -*- file prelude")
(put 'gadict-tr 'safe-local-variable 'string-or-null-p)

(defun gadict-insert-article (headword pos)
  "Insert new article after the current place.

If `gadict-espeak-enabled' is `t' pronunciation will be filled
with espeak `gadict-espeak-default-voice'."
  (if (re-search-forward "^__" nil t)
      (beginning-of-line)
    (goto-char (point-max)))
  (while (eq (char-before) ?\n)
    (delete-char -1))
  (insert-char ?\n)
  (insert-char ?_ 2)
  (insert-char ?\n 3)
  (forward-char -1)
  (insert headword)
  (insert "\n  [")
  (when gadict-espeak-enabled
    (insert (gadict-espeak-ipa headword gadict-espeak-default-voice)))
  (insert "]")
  (insert-char ?\n 2)
  (insert pos)
  (gadict--insert-tr))

(defun gadict-search-floor (headword)
  "Move to HEADWORD definition or place on posiiton for new corresponding
definition. Check for headwords ordering during search.

Return `t' if definition found, `nil' if no such headword."
  (let ( prev curr )
    (catch 'exit
      (goto-char (point-min))
      (unless (re-search-forward "^__$" nil t)
        (throw 'exit nil))
      (forward-line 2)
      (setq prev (buffer-substring-no-properties (point) (line-end-position)))
      (when (string= headword prev)
        (throw 'exit t))
      (when (string< headword prev)
        (goto-char (point-min))
        (throw 'exit nil))
      (while t
        (unless (re-search-forward "^__$" nil t)
          (throw 'exit nil))
        (forward-line 2)
        (setq curr (buffer-substring-no-properties (point) (line-end-position)))
        (when (string> prev curr)
          (error (format "%s < %s" curr prev)))
        (when (string= headword curr)
          (throw 'exit t))
        (when (string< headword curr)
          (forward-line -2)
          (re-search-backward "^__$")
          (forward-line 2)
          (throw 'exit nil))
        (setq prev curr)) )))

(defun gadict-search (headword)
  "Move to HEADWORD definition or place on posiiton for new corresponding
definition. Check for headwords ordering during search."
  (interactive (list (read-string "Headword: ")))
  (gadict-search-floor headword)
  (recenter))

(defun gadict-insert-article-in-order ()
  "Insert new article template with respect of headword order."
  (interactive)
  (let (headword pos)
    (setq headword (read-string "Headword: "))
    (unless (gadict-search-floor headword)
      (setq pos (completing-read "POS: " gadict--pos nil t))
      (gadict-insert-article headword pos)
      (recenter))))

(defun gadict--find-headword-end ()
  (save-excursion
    (end-of-line)
    (re-search-backward "^__$")
    (re-search-forward "^$")
    (forward-char)
    (re-search-forward "^$")
    (point)))

(defun gadict-insert-translation (pos)
  "Insert translation template using value of `gadict-tr'."
  (interactive (list (completing-read "POS: " gadict--pos nil t)))
  (let ( (headword-end (gadict--find-headword-end)) )
    (if (< (point) headword-end)
        (goto-char headword-end)
      (re-search-forward "^\\(?:\\|__\\)$")
      (when (eq (char-before) ?_)
        (beginning-of-line)))
    (insert-char ?\n 2)
    (forward-char -1)
    (insert pos)
    (gadict--insert-tr) ))

(defun gadict--insert-tr ()
  "Insert `gadict-tr' as multiline template on next line. Place point on the end of the first new line."
  (when (stringp gadict-tr)
    (save-excursion
      (end-of-line)
      (mapc (lambda (lang)
              (insert-char ?\n)
              (insert lang)
              (insert ": "))
            (split-string gadict-tr ",")))
    (end-of-line 2)))

(defun gadict-nearest-headword ()
  "Return nearest headword looking upward."
  (save-excursion
    (let ( (orig (point)) limit )
      (re-search-backward "^__$")
      (forward-line 1)
      (unless (and (eq (char-before) ?\n) (eq (char-after) ?\n))
        (error "Syntax error: there is not empty line after '__'..."))
      (forward-line 1)
      (when (< orig (point))
        (setq orig (point)))
      (setq limit (point))
      (re-search-forward "^$")
      (when (< orig (point))
        (goto-char orig)
        (end-of-line))
      (re-search-backward "^\\([^ ].*\\)$" limit)
      (match-string 1)
      )))

(defun gadict-copy-pronunciation (&optional headword)
  "Copy existing pronunciation of selected region or current word to `kill-ring'."
  (interactive
   (list (if (use-region-p)
             (buffer-substring (region-beginning) (region-end))
           (thing-at-point 'word))))
  (save-excursion
    (gadict-search-floor headword)
    (when (search-forward-regexp "\\[\\([^]]+\\)]")
      (kill-new (match-string 1)))))

(defun gadict-copy-espeak-pronunciation (&optional headword)
  "Copy espeak pronunciation of selected region or current word to `kill-ring'."
  (interactive
   (list (if (use-region-p)
             (buffer-substring (region-beginning) (region-end))
           (thing-at-point 'word))))
  (kill-new (gadict-espeak-headline-line headword)))

(defun gadict-setup-keymap ()
  "Setup gadict keymap."
  (define-key (current-local-map) [S-return] 'gadict-insert-translation)
  (define-key (current-local-map) [C-return] 'gadict-insert-article-in-order)
  (define-key (current-local-map) [C-S-return] 'gadict-search)
  (define-key (current-local-map) [M-return] 'gadict-copy-pronunciation)
  (define-key (current-local-map) [M-S-return] 'gadict-copy-espeak-pronunciation))

;;;###autoload
(define-derived-mode gadict-mode fundamental-mode "gadict"
  "Derived mode for editing gadict dictionary source files."
  (gadict-setup-fontlock)
  (gadict-setup-keymap)
  (gadict-setup-syntax)
  (gadict-setup-paragraph)
  (gadict-setup-page)
  (gadict-setup-comment)
  (gadict-setup-indent)
  (gadict-setup-expansions)
  (when (executable-find gadict-espeak-program)
    (setq gadict-espeak-enabled t)
    (gadict-espeak-headline-enable)))

(provide 'gadict)

;;; gadict.el ends here