;;; 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-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-template (&optional headword)

  "Insert new article template after the current place.

If `gadict-espeak-enabled' is `t' pronunciation will be filled

with espeak `gadict-espeak-default-voice'."

  (interactive)

  (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)

  (when (stringp gadict-tr)

    (mapc (lambda (tr)

            (insert-char ?\n)

            (insert tr)

            (insert ": "))

          (split-string gadict-tr ","))

    (insert-char ?\n)

    (backward-char)

    (re-search-backward "^$"))

  (backward-char)

  (when headword

    (insert headword)

    (insert "\n  [")

    (if gadict-espeak-enabled

        (progn

          (insert (gadict-espeak-ipa headword gadict-espeak-default-voice))

          (insert "]")

          (when gadict-tr

            (search-forward ": ")))

      (insert "]")

      (backward-char))))

(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-template-in-order (headword)

  "Insert new article template with respect of headword order."

  (interactive (list (read-string "Headword: ")))

  (unless (gadict-search-floor headword)

    (gadict-insert-template headword))

  (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 with 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)

        ;; (newline)

        ;; (backward-char)

        ))

    (insert-char ?\n)

    (insert pos)

    (insert-char ?\n)

    (save-excursion

      (mapc (lambda (lang)

              (insert lang)

              (insert ": \n"))

            (split-string gadict-tr ",")))

    (end-of-line) ))

(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-template-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