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

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

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

     4 ;; Also includes code from `sml-mode'

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

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

     7 ;;

     8 ;; to install:

     9 ;; (require 'pretty-mode)

    10 ;; (global-pretty-mode 1)

    11 ;; or

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

    13 

    14 

    15 (require 'cl)

    16 

    17 ;; modified from `sml-mode'

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

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

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

    21          (end (match-end 0))

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

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

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

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

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

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

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

    29                                        font-lock-comment-face)))

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

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

    32       ))

    33   nil)

    34 

    35 (defvar pretty-interaction-mode-alist

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

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

    38     (inferior-lisp-mode . lisp-mode)

    39     (inferior-ess-mode . ess-mode)

    40     (inf-haskell-mode . haskell-mode)

    41     (inferior-erlang-mode . erlang-mode)

    42     (tuareg-interactive-mode . tuareg-mode)

    43     (inferior-python-mode . python-mode)

    44     (inferior-octave-mode . octave-mode)

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

    46   "Alist mapping from inferior process interaction modes to their

    47   corresponding script editing modes.")

    48 

    49 

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

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

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

    53 REPLACE-CHAR) ...)."

    54   (when alist

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

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

    57            ',alist))))))

    58 

    59 (defun pretty-keywords (&optional mode)

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

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

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

    63          (kwds (cdr-safe

    64                 (or (assoc mode pretty-patterns)

    65                     (assoc (cdr-safe

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

    67                            pretty-patterns)))))

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

    69 

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

    71   :group 'faces)

    72 

    73 (define-minor-mode pretty-mode

    74   "Toggle Pretty minor mode.

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

    76 

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

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

    79 displayed as λ in lisp modes."

    80   :group 'pretty

    81                                         ;  :lighter " λ"

    82   (if pretty-mode

    83       (progn

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

    85         (font-lock-fontify-buffer))

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

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

    88 

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

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

    91   (if (pretty-keywords)

    92       (pretty-mode 1)))

    93 

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

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

    96   :init-value t)

    97 

    98 (defun turn-off-pretty-mode ()

    99   (interactive)

   100   (pretty-mode -1))

   101 

   102 

   103 (defun turn-on-pretty-mode ()

   104   (interactive)

   105   (pretty-mode +1))

   106 

   107 (defun pretty-compile-patterns (patterns)

   108   "Set pretty patterns in a convenient way.

   109 

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

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

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

   113 expected by `pretty-patterns'"

   114   (let ((pretty-patterns))

   115     (loop for (glyph . pairs) in patterns do

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

   117                 (loop for mode in major-modes do

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

   119                                                    "-mode")))

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

   121 

   122                              (entry (cons regexp glyph)))

   123                         (if assoc-pair

   124                             (push entry (cdr assoc-pair))

   125                           (push (cons mode (list entry))

   126                                 pretty-patterns))))))

   127     pretty-patterns))

   128 

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

   130 (defconst pretty-patterns-default

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

   132          (mley '(tuareg haskell sml erlang))

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

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

   135     (pretty-compile-patterns

   136      `(

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

   138            ("<>" tuareg octave)

   139            ("~=" octave)

   140            ("/=" haskell)

   141            ("=/=" erlang))

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

   143        (?≤ ("=<" erlang))

   144        (?λ ("fun" erlang))

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

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

   147            ("!" erlang))

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

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

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

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

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

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

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

   155        (?∑ ("sum" python))

   156 

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

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

   159 

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

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

   162 

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

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

   165 

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

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

   168 

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

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

   171 

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

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

   174 

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

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

   177 

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

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

   180 

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

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

   183 

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

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

   186 

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

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

   189 

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

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

   192 

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

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

   195 

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

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

   198 

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

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

   201 

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

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

   204 

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

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

   207 

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

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

   210 

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

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

   213 

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

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

   216 

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

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

   219 

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

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

   222 

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

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

   225 

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

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

   228 

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

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

   231 

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

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

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

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

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

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

   238            ("/0" erlang))

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

   240            ("/1" erlang))

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

   242            ("/2" erlang))

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

   244            ("/3" erlang))

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

   246            ("/4" erlang))

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

   248            ("/5" erlang))

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

   250            ("/6" erlang))

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

   252            ("/7" erlang))

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

   254            ("/8" erlang))

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

   256            ("/9" erlang))

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

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

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

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

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

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

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

   264        )))

   265   "default value for `pretty-patterns'")

   266 

   267 ;; TODO fix type

   268 (defcustom pretty-patterns pretty-patterns-default

   269   "*List of pretty patterns.

   270 

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

   272   :group 'pretty

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

   274 

   275 

   276 (defun pretty-add-keywords (mode keywords)

   277   "Add pretty character KEYWORDS to MODE

   278 

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

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

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

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

   283 relevant buffer(s)."

   284   (font-lock-add-keywords

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

   286                                 (0 (prog1 nil

   287                                      (compose-region (match-beginning 0)

   288                                                      (match-end 0)

   289                                                      ,(cdr kw)))))))

   290                 keywords)))

   291 

   292 (defun pretty-regexp (regexp glyph)

   293   "Replace REGEXP with GLYPH in buffer."

   294   (interactive "MRegexp to replace:

   295 MCharacter to replace with: ")

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

   297   (font-lock-fontify-buffer))

   298 

   299 

   300 

   301 

   302 (provide 'pretty-mode)