;;; -*- 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)