;;; -*- coding: utf-8 -*-

;; Minor mode for redisplaying parts of the buffer as pretty symbols

;; originally modified from Trent Buck's version at http://paste.lisp.org/display/42335,2/raw

;; Also includes code from `sml-mode'

;; See also http://www.emacswiki.org/cgi-bin/wiki/PrettyLambda

;; written by Arthur Danskin <[email protected]>

;;

;; to install:

;; (require 'pretty-mode)

;; (global-pretty-mode 1)

;; or

;; (add-hook 'my-pretty-language-hook 'turn-on-pretty-mode)

(require 'cl)

;; modified from `sml-mode'

(defun pretty-font-lock-compose-symbol (alist)

  "Compose a sequence of ascii chars into a symbol."

  (let* ((start (match-beginning 0))

         (end (match-end 0))

         (syntax (char-syntax (char-after start))))

    (if (or (if (eq syntax ?w)

                (or (eq (char-syntax (char-before start)) ?w)

                    (eq (char-syntax (char-after end)) ?w))

              (memq (char-syntax (char-before start)) '(?. ?\\)))

            (memq (get-text-property start 'face)

                  '(font-lock-doc-face font-lock-string-face

                                       font-lock-comment-face)))

        (remove-text-properties start end '(composition))

      (compose-region start end (cdr (assoc (match-string 0) alist)))

      ))

  nil)

(defvar pretty-interaction-mode-alist

  '((inferior-scheme-mode . scheme-mode)

    (lisp-interaction-mode . emacs-lisp-mode)

    (inferior-lisp-mode . lisp-mode)

    (inferior-ess-mode . ess-mode)

    (inf-haskell-mode . haskell-mode)

    (inferior-erlang-mode . erlang-mode)

    (tuareg-interactive-mode . tuareg-mode)

    (inferior-python-mode . python-mode)

    (inferior-octave-mode . octave-mode)

    (inferior-ruby-mode . ruby-mode))

  "Alist mapping from inferior process interaction modes to their

  corresponding script editing modes.")

(defun pretty-font-lock-keywords (alist)

  "Return a `font-lock-keywords' style entry for replacing

regular expressions with symbols. ALIST has the form ((STRING .

REPLACE-CHAR) ...)."

  (when alist

    `((,(regexp-opt (mapcar 'car alist))

       (0 (pretty-font-lock-compose-symbol

           ',alist))))))

(defun pretty-keywords (&optional mode)

  "Return the font-lock keywords for MODE, or the current mode if

MODE is nil. Return nil if there are no keywords."

  (let* ((mode (or mode major-mode))

         (kwds (cdr-safe

                (or (assoc mode pretty-patterns)

                    (assoc (cdr-safe

                            (assoc mode pretty-interaction-mode-alist))

                           pretty-patterns)))))

    (pretty-font-lock-keywords kwds)))

(defgroup pretty nil "Minor mode for replacing text with symbols "

  :group 'faces)

(define-minor-mode pretty-mode

  "Toggle Pretty minor mode.

With arg, turn Pretty minor mode on if arg is positive, off otherwise.

Pretty mode builds on `font-lock-mode'. Instead of highlighting

keywords, it replaces them with symbols. For example, lambda is

displayed as λ in lisp modes."

  :group 'pretty

                                        ;  :lighter " λ"

  (if pretty-mode

      (progn

        (font-lock-add-keywords nil (pretty-keywords) t)

        (font-lock-fontify-buffer))

    (font-lock-remove-keywords nil (pretty-keywords))

    (remove-text-properties (point-min) (point-max) '(composition nil))))

(defun turn-on-pretty-if-desired ()

  "Turn on `pretty-mode' if the current major mode supports it."

  (if (pretty-keywords)

      (pretty-mode 1)))

(define-globalized-minor-mode global-pretty-mode

  pretty-mode turn-on-pretty-if-desired

  :init-value t)

(defun turn-off-pretty-mode ()

  (interactive)

  (pretty-mode -1))

(defun turn-on-pretty-mode ()

  (interactive)

  (pretty-mode +1))

(defun pretty-compile-patterns (patterns)

  "Set pretty patterns in a convenient way.

PATTERNS should be of the form ((GLYPH (REGEXP MODE ...) ...)

...). GLYPH should be a character. MODE should be the name of a

major mode without the \"-mode\". Returns patterns in the form

expected by `pretty-patterns'"

  (let ((pretty-patterns))

    (loop for (glyph . pairs) in patterns do

          (loop for (regexp . major-modes) in pairs do

                (loop for mode in major-modes do

                      (let* ((mode (intern (concat (symbol-name mode)

                                                   "-mode")))

                             (assoc-pair (assoc mode pretty-patterns))

                             (entry (cons regexp glyph)))

                        (if assoc-pair

                            (push entry (cdr assoc-pair))

                          (push (cons mode (list entry))

                                pretty-patterns))))))

    pretty-patterns))

;;; (setq-default pretty-patterns pretty-patterns-default)

(defconst pretty-patterns-default

  (let* ((lispy '(scheme emacs-lisp lisp))

         (mley '(tuareg haskell sml erlang))

         (c-like '(c c++ perl sh python java ess ruby))

         (all (append lispy mley c-like (list 'octave))))

    (pretty-compile-patterns

     `(

       (?≠ ("!=" ,@c-like scheme octave)

           ("<>" tuareg octave)

           ("~=" octave)

           ("/=" haskell)

           ("=/=" erlang))

       (?≤ ("<=" ,@all))

       (?≤ ("=<" erlang))

       (?λ ("fun" erlang))

       (?≥ (">=" ,@all))

       (?← ("<-" ,@mley ess)

           ("!" erlang))

       (?→ ("->" ,@mley ess c c++ perl))

       (?↑ ("\\^" tuareg))

       (?⇒ ("=>" sml perl ruby))

       (?≡ ("==" ,@c-like erlang haskell))

       (?∀ ("BOOST_FOREACH" c++))

       (?∷ ("::" ,@all))

       (?√ ("sqrt" ,@all))

       (?∑ ("sum" python))

       (?α ("alpha" ,@all))

       (?Α ("Alpha" ,@all))

       (?β ("beta" ,@all))

       (?Β ("Beta" ,@all))

       (?γ ("gamma" ,@all))

       (?Γ ("Gamma" ,@all))

       (?δ ("delta" ,@all))

       (?Δ ("Delta" ,@all))

       (?ε ("epsilon" ,@all))

       (?Ε ("epsilon" ,@all))

       (?ζ ("zeta" ,@all))

       (?Ζ ("Zeta" ,@all))

       (?η ("eta" ,@all))

       (?Η ("Eta" ,@all))

       (?θ ("theta" ,@all))

       (?Θ ("Theta" ,@all))

       (?ι ("iota" ,@all))

       (?Ι ("Iota" ,@all))

       (?κ ("kappa" ,@all))

       (?K ("Kappa" ,@all))

       (?λ ("lambda" ,@all))

       (?Λ ("Lambda" ,@all))

       (?μ ("mu" ,@all))

       (?Μ ("Mu" ,@all))

       (?ν ("nu" ,@all))

       (?Ν ("Nu" ,@all))

       (?ν ("vega" ,@all))

       (?ν ("Vega" ,@all))

       (?ξ ("xi" ,@all))

       (?Ξ ("Xi" ,@all))

       (?ο ("omicron" ,@all))

       (?Ο ("Omicron" ,@all))

       (?π ("pi" ,@all))

       (?Π ("pi" ,@all))

       (?ρ ("rho" ,@all))

       (?Ρ ("Rho" ,@all))

       (?σ ("sigma" ,@all))

       (?Σ ("Sigma" ,@all))

       (?τ ("tau" ,@all))

       (?Τ ("Tau" ,@all))

       (?υ ("upsilon" ,@all))

       (?Y ("Upsilon" ,@all))

       (?φ ("phi" ,@all))

       (?Φ ("Phi" ,@all))

       (?χ ("chi" ,@all))

       (?Χ ("Chi" ,@all))

       (?ψ ("psi" ,@all))

       (?Ψ ("Psi" ,@all))

       (?ω ("omega" ,@all))

       (?Ω ("Omega" ,@all))

       (?² ("**2" python tuareg octave))

       (?³ ("**3" python tuareg octave))

       (?ⁿ ("**n" python tuareg octave))

       (?ₐ ("[a]" ,@c-like))

       (?ₓ ("[x]" ,@c-like))

       (?₀ ("[0]" ,@c-like)

           ("/0" erlang))

       (?₁ ("[1]" ,@c-like)

           ("/1" erlang))

       (?₂ ("[2]" ,@c-like)

           ("/2" erlang))

       (?₃ ("[3]" ,@c-like)

           ("/3" erlang))

       (?₄ ("[4]" ,@c-like)

           ("/4" erlang))

       (?₅ ("[5]" ,@c-like)

           ("/5" erlang))

       (?₆ ("[6]" ,@c-like)

           ("/6" erlang))

       (?₇ ("[7]" ,@c-like)

           ("/7" erlang))

       (?₈ ("[8]" ,@c-like)

           ("/8" erlang))

       (?₉ ("[9]" ,@c-like)

           ("/9" erlang))

       (?∧ ("\\<And\\>"     emacs-lisp lisp python)

           ("\\<andalso\\>" sml erlang)

           ("&&"            c c++ perl haskell))

       (?∨ ("\\<or\\>"      emacs-lisp lisp)

           ("\\<orelse\\>"  sml erlang)

           ("||"            c c++ perl haskell erlang))

       (?¬ ("!"       c c++))

       )))

  "default value for `pretty-patterns'")

;; TODO fix type

(defcustom pretty-patterns pretty-patterns-default

  "*List of pretty patterns.

Should be a list of the form ((MODE ((REGEXP . GLYPH) ...)) ...)"

  :group 'pretty

  :type '(alist :key-type variable :value-type (alist :key-type (string) :value-type (character))))

(defun pretty-add-keywords (mode keywords)

  "Add pretty character KEYWORDS to MODE

MODE should be a symbol, the major mode command name, such as

`c-mode' or nil. If nil, pretty keywords are added to the current

buffer. KEYWORDS should be a list where each element has the

form (REGEXP . CHAR). REGEXP will be replaced with CHAR in the

relevant buffer(s)."

  (font-lock-add-keywords

   mode (mapcar (lambda (kw) `((,(car kw)

                                (0 (prog1 nil

                                     (compose-region (match-beginning 0)

                                                     (match-end 0)

                                                     ,(cdr kw)))))))

                keywords)))

(defun pretty-regexp (regexp glyph)

  "Replace REGEXP with GLYPH in buffer."

  (interactive "MRegexp to replace:

MCharacter to replace with: ")

  (pretty-add-keywords nil `((,regexp . ,(string-to-char glyph))))

  (font-lock-fontify-buffer))

(provide 'pretty-mode)