;;; tcl-digraphs.el --- Emacs Minor Mode for Tcl

;; Copyright 2020 SIEMENS AG.
;; SPDX-License-Identifier: MIT-0

;; Author: Michael Kaelbling <michael.kaelbling@siemens.com>
;; Keywords: Tcl, Tcl/Tk, digraph, keyboard shortcut
;; Version: 4.1.2

;; This file is not part of GNU Emacs.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Code:

(defgroup tcl-digraphs nil
  "Customizations for tcl-digraphs."
  :group 'tcl)

(defcustom tcl-digraph-prefix ";"
  "*Prefix key"
  :type 'string
  :group 'tcl-digraphs)

(defun tcl--insert (prefix suffix n)
  "Insert text before and after the active-region or point.

PREFIX is the text to precede the active-region or point.
SUFFIX is the text to follow the active-region or point.
N is the number of characters to back-up after inserting SUFFIX."
  (let ((beg (if (region-active-p) (region-beginning) (point)))
        (end (+ (if (region-active-p) (region-end) (point))
                (length prefix))))
    (goto-char beg)
    (if prefix (insert prefix))
    (push-mark)
    (goto-char end)
    (if suffix (insert suffix))
    (when n (backward-char n))))

(defun lambda-key (keymap key def)
  "Workaround `define-key' to provide documentation."
  (set 'sym (make-symbol (documentation def)))
  (fset sym def)
  (define-key keymap key sym))

(defconst tcl-digraph-map
  (let ((map (make-sparse-keymap)))
    (lambda-key map [t] '(lambda () "handle event <t>"
                           (interactive "*")
                           (unless (eq last-input-event 'delete)
                             (insert tcl-digraph-prefix)
                             (unless
                                 (eq last-input-event 'escape)
                               (add-to-list
                                'unread-command-events
                                last-input-event)))))
    (lambda-key map "," '(lambda ()
                           "insert curly cut        } {§"
                           (interactive "*") (insert "} {")))
    (lambda-key map "/" '(lambda (P)
                           "append splice          » \\¬§"
                           (interactive "*P")
                           (move-end-of-line 1)
                           (if (not P) (just-one-space))
                           (insert "\\") (newline)))
    (lambda-key map ";" '(lambda ()
                           "insert data semicolon   \\;§"
                           (interactive "*") (insert "\\;")))
    (lambda-key map "=" '(lambda ()
                           "insert expression       [expr {¶§}]"
                           (interactive "*")
                           (tcl--insert "[expr {" "}]" 2)))
    (lambda-key map "?" '(lambda ()
                           "describe minor mode"
                           (interactive)
                           (describe-minor-mode
                            'tcl-digraph-minor-mode)))
    (lambda-key map "[" '(lambda ()
                           "insert command          [¶§]"
                           (interactive "*")
                           (tcl--insert "[" "]" 1)))
    (lambda-key map "]" '(lambda ()
                           "append command         » [§]"
                           (interactive "*")
                           (move-end-of-line 1) (just-one-space)
                           (insert "[]") (backward-char 1)))
    (lambda-key map "a" '(lambda (P)
                           "insert args             $args§   ¦  {*}$args§"
                           (interactive "*P")
                           (insert (if P "$args" "{*}$args"))))
    (lambda-key map "b" '(lambda ()
                           "append blockquote      » {§}"
                           (interactive "*")
                           (move-end-of-line 1) (just-one-space)
                           (insert "{}") (backward-char 1)))
    (lambda-key map "c" '(lambda ()
                           "insert command          [¶§]"
                           (interactive "*")
                           (tcl--insert "[" "]" 1)))
    (lambda-key map "d" '(lambda (P)
                           "insert dollar-sign      $¶§"
                           (interactive "*P")
                           (if P (tcl--insert "${" "}" 1)
                             (insert "$"))))
    (lambda-key map "e" '(lambda ()
                           "append else            » else {¬§¬}"
                           (interactive "*")
                           (move-end-of-line 1) (just-one-space)
                           (insert "else {}") (backward-char 1)
                           (newline) (tcl-indent-command)
                           (move-beginning-of-line 1)
                           (open-line 1) (tcl-indent-command)))
    (lambda-key map "f" '(lambda ()
                           "append elseif          » elseif {§}"
                           (interactive "*")
                           (move-end-of-line 1) (just-one-space)
                           (insert "elseif {}")
                           (backward-char 1)))
    (lambda-key map "n" '(lambda ()
                           "insert not-parens       !(¶§)"
                           (interactive "*")
                           (tcl--insert "!(" ")" 1)))
    (lambda-key map "o" '(lambda ()
                           "insert and open block   {¬§¬}"
                           (interactive "*")
                           (insert "{}") (backward-char 1)
                           (newline) (tcl-indent-command)
                           (move-beginning-of-line 1)
                           (open-line 1) (tcl-indent-command)))
    (lambda-key map "p" '(lambda ()
                           "insert parentheses      (¶§)"
                           (interactive "*")
                           (tcl--insert "(" ")" 1)))
    (lambda-key map "q" '(lambda ()
                           "insert quotes           \"¶§\""
                           (interactive "*")
                           (tcl--insert "\"" "\"" 1)))
    (lambda-key map "s" '(lambda (P)
                           "insert set              [set ¶§] ¦  $¶§"
                           (interactive "*P")
                           (if P (tcl--insert "$" "" 0)
                             (tcl--insert "[set " "]" 1))))
    (lambda-key map "t" '(lambda (P)
                           "append then            » {¬§¬}   ¦ » then {¬§¬}"
                           (interactive "*P")
                           (move-end-of-line 1) (just-one-space)
                           (when P
                             (insert "then ")
                             ;; lest `tcl-indent-command'
                             ;; (c) 2019 chock ...
                             (set 'current-prefix-arg nil))
                           (indent "{}")			
                           (backward-char 1)
                           (newline) (tcl-indent-command)
                           (move-beginning-of-line 1)
                           (open-line 1) (tcl-indent-command)))
    (lambda-key map "u" '(lambda (P)
                           "insert until clause     ![¶§]    ¦  {![¶§]}"
                           (interactive "*P")
                           (if (and (looking-at-p "}") (not P))
                               (tcl--insert "![" "]" 1)
                             (tcl--insert "{![" "]}" 2))))
    (lambda-key map "v" '(lambda ()
                           "insert verbatim quote   {¶§}"
                           (interactive "*")
                           (tcl--insert "{" "}" 1)))
    (lambda-key map "w" '(lambda (P)
                           "insert while clause     [¶§]     ¦  {[¶§]}"
                           (interactive "*P")
                           (if (and (looking-at-p "}") (not P))
                               (tcl--insert "[" "]" 1)
                             (tcl--insert "{[" "]}" 2))))
    (lambda-key map "x" '(lambda (P)
                           "insert expander         {*}§     ¦  {*}$args§"
                           (interactive "*P")
                           (insert (if P "{*}$args" "{*}"))))
    (lambda-key map "{" '(lambda ()
                           "insert curly quote      {¶§}"
                           (interactive "*")
                           (tcl--insert "{" "}" 1)))
    (lambda-key map "}" '(lambda ()
                           "append curly quote     » {§}"
                           (interactive "*")
                           (move-end-of-line 1) (just-one-space)
                           (insert "{}") (backward-char 1)))
    map)
  "Keymap behind the `tcl-digraph-minor-mode' prefix key.")

(defconst tcl-digraph-minor-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map tcl-digraph-prefix tcl-digraph-map)
    map)
  "Keymap for `tcl-digraph-minor-mode'.")

(put 'tcl-digraph-minor-mode :included t)

(define-minor-mode tcl-digraph-minor-mode
  "The `tcl-digraph-minor-mode' 4.1 bindings.

Undefined digraphs ignore the prefix; ESC will insert just
the prefix; and DEL will cancel the digraph.  Some special
symbols are used in the description: a \\='§' shows where the
cursor will be positioned, while \\='¶' represents the active
region before expansion, a \\='¬' is a newline, and \\='»' shows
that the expansion is put at the end of the line, with \\='¦'
appearing between a simple expansion and an expansion with
a \\[universal-argument] prefix.  The 4.1 digraphs are:
\\{tcl-digraph-minor-mode-map}
"
  :lighter " T;c;l" :global nil :init-value nil
  :keymap tcl-digraph-minor-mode-map)

(provide 'tcl-digraphs)

;;; tcl-digraphs.el ends here
