;; Emacs PramgataPro 0.828 Ligatures Support
;; Author: lumiknit (aasr4r4@gmail.com)
;; Version: 20200211

;; Usage: Use "M-x 'pragmatapro-lig-mode' RET" to turn on ligature minor mode.
;;        Or, use 'pragmatapro-lig-global-mode to turn it on globally.
;;        I recommend you to compile this file before load it.

(eval-when-compile (defconst pragmatapro-lig-alist
  '( ;;("[ERROR]" #Xe2c0)
    ;; ("[DEBUG]" #Xe2c1)
    ;; ("[INFO]" #Xe2c2)
    ;; ("[WARN]" #Xe2c3)
    ;; ("[WARNING]" #Xe2c4)
    ;; ("[ERR]" #Xe2c5)
    ;; ("[FATAL]" #Xe2c6)
    ;; ("[TRACE]" #Xe2c7)
    ;; ("[FIXME]" #Xe2c8)
    ;; ("[TODO]" #Xe2c9)
    ;; ("[BUG]" #Xe2ca)
    ;; ("[NOTE]" #Xe2cb)
    ;; ("[HACK]" #Xe2cc)
    ;; ("[MARK]" #Xe2cd)
    ;; ("[FAIL]" #Xe2ce)
    ;; ("// ERROR" #Xe2e0)
    ;; ("// DEBUG" #Xe2e1)
    ;; ("// INFO" #Xe2e2)
    ;; ("// WARN" #Xe2e3)
    ;; ("// WARNING" #Xe2e4)
    ;; ("// ERR" #Xe2e5)
    ;; ("// FATAL" #Xe2e6)
    ;; ("// TRACE" #Xe2e7)
    ;; ("// FIXME" #Xe2e8)
    ;; ("// TODO" #Xe2e9)
    ;; ("// BUG" #Xe2ea)
    ;; ("// NOTE" #Xe2eb)
    ;; ("// HACK" #Xe2ec)
    ;; ("// MARK" #Xe2ed)
    ;; ("// FAIL" #Xe2ee)
    ;; ("# ERROR" #Xe2f0)
    ;; ("# DEBUG" #Xe2f1)
    ;; ("# INFO" #Xe2f2)
    ;; ("# WARN" #Xe2f3)
    ;; ("# WARNING" #Xe2f4)
    ;; ("# ERR" #Xe2f5)
    ;; ("# FATAL" #Xe2f6)
    ;; ("# TRACE" #Xe2f7)
    ;; ("# FIXME" #Xe2f8)
    ;; ("# TODO" #Xe2f9)
    ;; ("# BUG" #Xe2fa)
    ;; ("# NOTE" #Xe2fb)
    ;; ("# HACK" #Xe2fc)
    ;; ("# MARK" #Xe2fd)
    ;; ("# FAIL" #Xe2fe)
    ("!!" #Xe900)
    ("!=" #Xe901)
    ("!==" #Xe902)
    ("!!!" #Xe903)
    ;; ("!≡" #Xe904)
    ;; ("!≡≡" #Xe905)
    ("!>" #Xe906)
    ("!=<" #Xe907)
    ("#(" #Xe920)
    ("#_" #Xe921)
    ("#{" #Xe922)
    ("#?" #Xe923)
    ("#>" #Xe924)
    ("##" #Xe925)
    ("#_(" #Xe926)
    ("%=" #Xe930)
    ("%>" #Xe931)
    ("%>%" #Xe932)
    ("%<%" #Xe933)
    ;; ("<~" #Xe93f)
    ("&%" #Xe940)
    ("&&" #Xe941)
    ("&*" #Xe942)
    ("&+" #Xe943)
    ("&-" #Xe944)
    ("&/" #Xe945)
    ("&=" #Xe946)
    ("&&&" #Xe947)
    ("&>" #Xe948)
    ("$>" #Xe955)
    ;; ("~>" #Xe95f)
    ("***" #Xe960)
    ("*=" #Xe961)
    ("*/" #Xe962)
    ("*>" #Xe963)
    ("++" #Xe970)
    ("+++" #Xe971)
    ("+=" #Xe972)
    ("+>" #Xe973)
    ("++=" #Xe974)
    ("--" #Xe980)
    ("-<" #Xe981)
    ("-<<" #Xe982)
    ("-=" #Xe983)
    ("->" #Xe984)
    ("->>" #Xe985)
    ("---" #Xe986)
    ("-->" #Xe987)
    ("-+-" #Xe988)
    ("-\\/" #Xe989)
    ("-|>" #Xe98a)
    ("-<|" #Xe98b)
    ("->-" #Xe98c)
    ("-<-" #Xe98d)
    (".." #Xe990)
    ("..." #Xe991)
    ("..<" #Xe992)
    (".>" #Xe993)
    (".~" #Xe994)
    (".=" #Xe995)
    ("/*" #Xe9a0)
    ("//" #Xe9a1)
    ("/>" #Xe9a2)
    ("/=" #Xe9a3)
    ("/==" #Xe9a4)
    ("///" #Xe9a5)
    ("/**" #Xe9a6)
    (":::" #Xe9af)
    ("::" #Xe9b0)
    (":=" #Xe9b1)
    (":>" #Xe9b3)
    (":=>" #Xe9b4)
    (":(" #Xe9b5)
    (":-(" #Xe9b6)
    (":)" #Xe9b7)
    (":-)" #Xe9b8)
    (":/" #Xe9b9)
    (":\\" #Xe9ba)
    (":3" #Xe9bb)
    (":D" #Xe9bc)
    (":P" #Xe9bd)
    (":>:" #Xe9be)
    (":<:" #Xe9bf)
    ("<$>" #Xe9c0)
    ("<*" #Xe9c1)
    ("<*>" #Xe9c2)
    ("<+>" #Xe9c3)
    ("<-" #Xe9c4)
    ("<<" #Xe9c5)
    ("<<<" #Xe9c6)
    ("<<=" #Xe9c7)
    ("<=" #Xe9c8)
    ("<=>" #Xe9c9)
    ("<>" #Xe9ca)
    ("<|>" #Xe9cb)
    ("<<-" #Xe9cc)
    ("<|" #Xe9cd)
    ("<=<" #Xe9ce)
    ("<~" #Xe9cf)
    ("<~~" #Xe9d0)
    ("<<~" #Xe9d1)
    ("<$" #Xe9d2)
    ("<+" #Xe9d3)
    ("<!>" #Xe9d4)
    ("<@>" #Xe9d5)
    ("<#>" #Xe9d6)
    ("<%>" #Xe9d7)
    ("<^>" #Xe9d8)
    ("<&>" #Xe9d9)
    ("<?>" #Xe9da)
    ("<.>" #Xe9db)
    ("</>" #Xe9dc)
    ("<\\>" #Xe9dd)
    ("<\">" #Xe9de)
    ("<:>" #Xe9df)
    ("<~>" #Xe9e0)
    ("<**>" #Xe9e1)
    ("<<^" #Xe9e2)
    ("<!" #Xe9e3)
    ("<@" #Xe9e4)
    ("<#" #Xe9e5)
    ("<%" #Xe9e6)
    ("<^" #Xe9e7)
    ("<&" #Xe9e8)
    ("<?" #Xe9e9)
    ("<." #Xe9ea)
    ("</" #Xe9eb)
    ("<\\" #Xe9ec)
    ("<\"" #Xe9ed)
    ("<:" #Xe9ee)
    ("<->" #Xe9ef)
    ("<!--" #Xe9f0)
    ("<--" #Xe9f1)
    ("<~<" #Xe9f2)
    ("<==>" #Xe9f3)
    ("<|-" #Xe9f4)
    ("<||" #Xe9f5)
    ("<<|" #Xe9f6)
    ("<-<" #Xe9f7)
    ("<-->" #Xe9f8)
    ("<<==" #Xe9f9)
    ("<==" #Xe9fa)
    ("=<<" #Xea00)
    ("==" #Xea01)
    ("===" #Xea02)
    ("==>" #Xea03)
    ("=>" #Xea04)
    ("=~" #Xea05)
    ("=>>" #Xea06)
    ("=/=" #Xea07)
    ("=~=" #Xea08)
    ("==>>" #Xea09)
    ("=>=" #Xea0a)
    ("=<=" #Xea0b)
    ("=<" #Xea0c)
    ;;("≡≡" #Xea10)
    ;;("≡≡≡" #Xea11)
    ;;("≡:≡" #Xea12)
    (">-" #Xea20)
    (">=" #Xea21)
    (">>" #Xea22)
    (">>-" #Xea23)
    (">>=" #Xea24)
    (">>>" #Xea25)
    (">=>" #Xea26)
    (">>^" #Xea27)
    (">>|" #Xea28)
    (">!=" #Xea29)
    (">->" #Xea2a)
    ("??" #Xea40)
    ("?~" #Xea41)
    ("?=" #Xea42)
    ("?>" #Xea43)
    ("???" #Xea44)
    ("?." #Xea45)
    ("^=" #Xea48)
    ("^." #Xea49)
    ("^?" #Xea4a)
    ("^.." #Xea4b)
    ("^<<" #Xea4c)
    ("^>>" #Xea4d)
    ("^>" #Xea4e)
    ("\\\\" #Xea50)
    ("\\>" #Xea51)
    ("\\/-" #Xea52)
    ("@>" #Xea57)
    ("|=" #Xea60)
    ("||" #Xea61)
    ("|>" #Xea62)
    ("|||" #Xea63)
    ("|+|" #Xea64)
    ("|->" #Xea65)
    ("|-->" #Xea66)
    ("|=>" #Xea67)
    ("|==>" #Xea68)
    ("|>-" #Xea69)
    ("|<<" #Xea6a)
    ("||>" #Xea6b)
    ("|>>" #Xea6c)
    ("|-" #Xea6d)
    ("||-" #Xea6e)
    ("~=" #Xea70)
    ("~>" #Xea71)
    ("~~>" #Xea72)
    ("~>>" #Xea73)
    ("[[" #Xea80)
    ("]]" #Xea81)
    ("\">" #Xea90)
    ("_|_" #Xea97)
    )))

(defconst pragmatapro-lig-table
  (eval-when-compile
    (let ((v (make-vector 128 nil)))
      (dolist (i pragmatapro-lig-alist)
        (let ((s (car i))
              (f (min 127 (aref (car i) 0)))
              (c (cadr i)))
          (let ((a (aref v f))
                (r (substring s 1))
                (lr (1- (length s))))
            (aset
             v f
             (cons
              (max (if a (car a) 0) lr)
              (cons (list r lr
                          (vconcat (mapcar
                                    'string
                                    (concat (make-string lr ?\s)
                                            (string c)))))
                    (and a (cdr a))))))))
      (vconcat (mapcar (lambda (l)
                         (if l
                             (cons (car l)
                                   (sort (cdr l) (lambda (x y)
                                                   (> (cadr x) (cadr y)))))
                           nil))
                       v)))))

(defconst pragmatapro-lig-use-table
  (eval-when-compile
    (let ((v (make-vector 128 nil)))
      (dolist (i pragmatapro-lig-alist)
        (let ((s (car i)))
          (dotimes (j (length s))
            (aset v (aref s j) t))))
      v)))

(defun pragmatapro-guess-range (start end)
  (save-excursion
    (let ((s start) (e end)
          (ss (progn (goto-char start) (line-beginning-position)))
          (ee (progn (goto-char end) (line-end-position))))
      (while (and (> s ss)
                  (aref pragmatapro-lig-use-table
                        (min 127 (or (char-before s) 127))))
        (setq s (1- s)))
      (while (and (< e ee)
                  (aref pragmatapro-lig-use-table
                        (min 127 (or (char-after e) 127))))
        (setq e (1+ e)))
      (cons s e))))

(defun pragmatapro-remove-ligatures (start end)
  "Remove ligatures in start-end in the current buffer"
  (let ((p (text-property-any start end 'ligature t))
        (e nil))
    (while p
      (setq e (or (next-single-property-change p 'ligature) end))
      (remove-list-of-text-properties p e '(ligature display))
      (setq p (text-property-any e end 'ligature t)))))

(defun pragmatapro-update-ligatures (start end &optional l)
  "Update ligatures in start-end in the current buffer"
  (let ((modified (buffer-modified-p))
        (inhibit-read-only t)
        (case-fold-search nil))
    (save-excursion
      (let ((z (pragmatapro-guess-range (or start (point))
                                        (or end (point)))))
        (goto-char (car z))
        (setq end (cdr z)))
      (when (<= (point) end)
        (pragmatapro-remove-ligatures (point) end))
      (while (< (point) end)
        (let* ((c (char-after))
               (l (and c (aref pragmatapro-lig-table (min 127 c)))))
          (forward-char 1)
          (when l
            (catch 'break
              (let ((pt (point)))
                (dolist (p (cdr l))
                  (when (string-prefix-p
                         (car p)
                         (buffer-substring-no-properties
                          pt (min (+ pt (car l)) (1+ (buffer-size)))))
                    (forward-char (cadr p))
                    (let ((s (1- pt)) (th (caddr p)))
                      (put-text-property s (point) 'ligature t)
                      (dotimes (i (1+ (cadr p)))
                        (put-text-property (+ s i) (+ s i 1) 'display
                                           (aref th i)))
                      (throw 'break nil))))))))))
    (set-buffer-modified-p modified)))

(define-minor-mode pragmatapro-lig-mode
  "Compose pragmatapro's ligatures."
  :lighter " PragLig"
  (let ((inhibit-modification-hooks t)
        (inhibit-read-only t))
    (if pragmatapro-lig-mode
        (progn ; Turn on
          (add-hook 'after-change-functions 'pragmatapro-update-ligatures t t)
          (when (> (buffer-size) 0)
            (pragmatapro-update-ligatures 1 (buffer-size))))
      ;; Turn off
      (remove-hook 'after-change-functions 'pragmatapro-update-ligatures t)
      (when (> (buffer-size) 0)
        (pragmatapro-remove-ligatures 1 (buffer-size)))))
  pragmatapro-lig-mode)

(defun pragmatapro-lig-mode-on ()
  (pragmatapro-lig-mode 1))

(define-globalized-minor-mode pragmatapro-lig-global-mode
  pragmatapro-lig-mode
  pragmatapro-lig-mode-on)

;; ---

(defvar pragmatapro-icons
  (eval-when-compile
    (let ((tt (make-hash-table :size 127 :test 'equal)))
      (puthash "lisp" "()" tt)
      (puthash "lisp interaction" "()\xf41f" tt)
      (puthash "scheme" "(λ)" tt)
      (puthash "inferior scheme" "(λ)\xf41f" tt)
      (puthash "dired" "\xe5fe" tt)
      (puthash "html" "\xe736" tt)
      (puthash "web" "\xe796" tt)
      (puthash "scala" "\xe737" tt)
      (puthash "c" "\xe61e" tt)
      (puthash "c/*l" "\xe61e" tt)
      (puthash "c++" "\xe61d" tt)
      (puthash "c++//l" "\xe61d" tt)
      (puthash "java//l" "\xe738" tt)
      (puthash "java" "\xe738" tt)
      (puthash "ruby" "\xe791" tt)
      (puthash "inf-ruby" "\xe791\xf41f" tt)
      (puthash "rails" "\xe73b" tt)
      (puthash "python" "\xe606" tt)
      (puthash "inferior python" "\xe606\xf41f" tt)
      (puthash "php" "\xe73d" tt)
      (puthash "markdown" "\xe73e" tt)
      (puthash "css" "\xe749" tt)
      (puthash "sass" "\xe74b" tt)
      (puthash "javascript" "\xe60c" tt)
      (puthash "js" "\xe74e" tt)
      (puthash "typescript" "\xe628" tt)
      (puthash "jquery" "\xe750" tt)
      (puthash "coffee" "\xe751" tt)
      (puthash "angularjs" "\xe753" tt)
      (puthash "swift" "\xe755" tt)
      (puthash "less" "\xe758" tt)
      (puthash "clojure" "\xe76a" tt)
      (puthash "cidar" "\xe76a" tt)
      (puthash "haskell" "\xe777" tt)
      (puthash "haskell-cabal" "\xe777 Cabal" tt)
      (puthash "interactive-haskell" "\xe777\xf41f" tt)
      (puthash "hscompilation" "\xe777\x2611" tt)
      (puthash "emacs-lisp" "(\xe779)" tt)
      (puthash "prolog" "\xe7a1" tt)
      (puthash "fsharp" "\xe7a7" tt)
      (puthash "rust" "\xe7a8" tt)
      (puthash "d" "\xe7af" tt)
      (puthash "erlang" "\xe7b1" tt)
      (puthash "lua" "\xe620" tt)
      (puthash "dart" "\xe798" tt)
      (puthash "dart//l" "\xe798" tt)
      (puthash "go" "\xe627" tt)
      (puthash "git" "\xe630" tt)
      (puthash "comint" "\xf41f" tt)
      (puthash "fundamental" "\xf4a5" tt)
      (puthash "shell" "\xe7a2" tt)
      (puthash "elixir" "\xf499" tt)
      (puthash "debugger" "\xf4a0" tt)
      tt)))

(defun pragmatapro-get-mode-icon ()
  (let ((z (gethash (downcase mode-name) pragmatapro-icons)))
    (if z z mode-name)))

(provide 'pragmatapro-lig)