Mercurial > hg > Members > kokubo > emacs

annotate .emacs.d/haskell-mode/haskell-show.el @ 0:2764b4f45f9f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
1st commit
author Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
date Mon, 21 Apr 2014 04:30:59 +0900
parents
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
0
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
1 ;;; haskell-show.el --- A pretty printer for Haskell Show values
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
2
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
3 ;; Copyright (C) 2011 Chris Done
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
4
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
5 ;; Author: Chris Done <chrisdone@gmail.com>
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
6
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
7 ;; This file is not part of GNU Emacs.
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
8
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
9 ;; This program is free software: you can redistribute it and/or
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
10 ;; modify it under the terms of the GNU General Public License as
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
11 ;; published by the Free Software Foundation, either version 3 of the
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
12 ;; License, or (at your option) any later version.
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
13
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
14 ;; This program is distributed in the hope that it will be useful, but
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
17 ;; General Public License for more details.
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
18
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
19 ;; You should have received a copy of the GNU General Public License
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
20 ;; along with this program. If not, see
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
21 ;; <http://www.gnu.org/licenses/>.
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
22
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
23 ;;; Commentary:
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
24
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
25 ;; It doesn't support some number literals (probably). I'm not
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
26 ;; precisely sure what values Show will always produce. There is
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
27 ;; however a test suite available, so patches for extra Show support
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
28 ;; is welcome and should be easy to test.
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
29
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
30 ;;; Code:
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
31
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
32 (defvar sexp-show "sexp-show")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
33 (require 'haskell-string)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
34 (with-no-warnings (require 'cl))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
35
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
36 (defun haskell-show-replace-region ()
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
37 "Replace the given region with a pretty printed version."
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
38 (interactive)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
39 (haskell-show-replace (region-beginning) (region-end)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
40
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
41 ;;;###autoload
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
42 (defun haskell-show-replace (start end)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
43 "Replace the given region containing a Show value with a pretty
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
44 printed collapsible version."
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
45 (let ((text (buffer-substring-no-properties start end)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
46 (goto-char start)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
47 (delete-region start end)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
48 (haskell-show-parse-and-insert text)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
49
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
50 ;;;###autoload
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
51 (defun haskell-show-parse-and-insert (given)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
52 "Parse a `string' containing a Show instance value and insert
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
53 it pretty printed into the current buffer."
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
54 (when (not (string= "" (haskell-trim given)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
55 (let ((current-column (- (point)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
56 (line-beginning-position)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
57 (result (haskell-show-parse given)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
58 (if (string-match "^[\\(]" result)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
59 (let ((v (read result)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
60 (if (equal (car v) 'arbitrary)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
61 (insert given)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
62 (haskell-show-insert-pretty current-column v)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
63 (insert given)))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
64
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
65 ;;;###autoload
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
66 (defun haskell-show-parse (given)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
67 "Parse the given input into a tree."
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
68 (with-temp-buffer
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
69 (insert given)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
70 (shell-command-on-region
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
71 (point-min)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
72 (point-max)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
73 sexp-show
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
74 t)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
75 (buffer-substring-no-properties (point-min) (point-max))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
76
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
77 (defun haskell-show-insert-pretty (column tree &optional parens)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
78 "Insert a Show `tree' into the current buffer with collapsible nodes."
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
79 (case (car tree)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
80 ('list (let ((start (point)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
81 (insert "[")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
82 (haskell-show-mapcar/i (lambda (x i len)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
83 (haskell-show-insert-pretty (+ column 1) x)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
84 (unless (> i (- len 2))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
85 (if (< (+ column (length (haskell-show-pretty tree parens)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
86 80)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
87 (insert ",")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
88 (insert (concat ",\n" (haskell-show-indent (+ 1 column) ""))))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
89 (cdr tree))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
90 (insert "]")))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
91 ('tuple (let ((start (point)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
92 (insert "(")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
93 (haskell-show-mapcar/i (lambda (x i len)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
94 (haskell-show-insert-pretty (+ column 1) x)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
95 (unless (> i (- len 2))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
96 (if (< (+ column (length (haskell-show-pretty tree parens)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
97 80)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
98 (insert ",")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
99 (insert (concat ",\n" (haskell-show-indent (+ 1 column) ""))))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
100 (cdr tree))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
101 (insert ")")))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
102 ('record
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
103 (let ((record (cdr tree)) (overlay (list 'nil)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
104 (insert (if parens "(" ""))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
105 (let ((link-start (point)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
106 (insert (car record))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
107 (let ((button (make-text-button link-start (point) :type 'haskell-show-toggle-button)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
108 (put-text-property link-start (point) 'face 'font-lock-type-face)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
109 (button-put button 'overlay overlay)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
110 (insert " {\n")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
111 (let ((curly-start (1- (point)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
112 (show-len (+ column (length (haskell-show-pretty tree parens)))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
113 (haskell-show-mapcar/i (lambda (field i len)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
114 (insert
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
115 (haskell-show-indent
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
116 (if (and (> i 0) (< show-len 80)) 0 column)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
117 (car field)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
118 (insert " = ")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
119 (put-text-property (- (point) 3) (point) 'face
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
120 'font-lock-constant-face)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
121 (haskell-show-insert-pretty
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
122 (if (< show-len 80)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
123 0
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
124 (+ (length (car field)) column 3))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
125 (cdr field))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
126 (unless (> i (- len 2))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
127 (if (< show-len 80)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
128 (insert ", ")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
129 (insert ",\n"))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
130 (cdr record))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
131 (insert (concat "\n" (haskell-show-indent column "}")))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
132 (progn
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
133 (setf (car overlay) (make-overlay curly-start (- (point) 1) nil t))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
134 (overlay-put (car overlay) 'invisible t))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
135 (insert (if parens ")" "")))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
136 ('num (let ((num-start (point)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
137 (insert (format "%d" (cdr tree)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
138 (put-text-property num-start (point) 'face 'font-lock-constant-face)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
139 ('string (let ((str-start (point)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
140 (insert "\"")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
141 (if (< (+ column (length (cdr tree))) 60)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
142 (progn
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
143 (insert (format "%s" (cdr tree)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
144 (put-text-property (+ 1 str-start) (point) 'face 'font-lock-string-face))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
145 (progn
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
146 (insert "…")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
147 (insert (format "%s" (cdr tree)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
148 (let ((overlay (make-overlay (+ 2 str-start) (point) nil t)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
149 (overlay-put overlay 'invisible t)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
150 (put-text-property (+ 2 str-start) (point) 'face 'font-lock-string-face)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
151 (let ((button (make-text-button (+ 1 str-start) (+ 2 str-start)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
152 :type 'haskell-show-toggle-button)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
153 (put-text-property (+ 1 str-start) (+ 2 str-start)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
154 'face 'font-lock-keyword-face)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
155 (button-put button 'overlay (list overlay))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
156 (button-put button 'hide-on-click t)))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
157 (insert "\"")))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
158 ('data (let ((data (cdr tree)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
159 (insert (if parens "(" ""))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
160 (let ((cons-start (point)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
161 (insert (car data))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
162 (put-text-property cons-start (point) 'face 'font-lock-type-face))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
163 (unless (null (cdr data))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
164 (progn (insert " ")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
165 (haskell-show-mapcar/i
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
166 (lambda (x i len)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
167 (haskell-show-insert-pretty column x t)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
168 (unless (> i (- len 2))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
169 (insert " ")))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
170 (cdr data))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
171 (insert (if parens ")" ""))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
172 ('char (progn (insert "'")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
173 (insert (char-to-string (cdr tree)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
174 (put-text-property (- (point) 1) (point) 'face 'font-lock-string-face)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
175 (insert "'")))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
176 ('arbitrary (let ((start (point)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
177 (insert (cdr tree))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
178 (put-text-property start (point) 'face 'font-lock-comment-face)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
179 (otherwise (error "Unsupported node type: %S" tree))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
180
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
181 (define-button-type 'haskell-show-toggle-button
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
182 'action 'haskell-show-toggle-button-callback
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
183 'follow-link t
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
184 'help-echo "Click to expand…")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
185
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
186 (defun haskell-show-toggle-button-callback (btn)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
187 "The callback to toggle the overlay visibility."
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
188 (let ((overlay (button-get btn 'overlay)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
189 (when overlay
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
190 (overlay-put (car overlay)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
191 'invisible (not (overlay-get (car overlay)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
192 'invisible)))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
193 (let ((hide (button-get btn 'remove-on-click)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
194 (when hide
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
195 (button-put btn 'invisible t))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
196
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
197 (defun haskell-show-pretty (tree &optional parens)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
198 "Show a Show `tree'."
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
199 (case (car tree)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
200 ('list (format "[%s]"
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
201 (mapconcat
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
202 (lambda (x)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
203 (haskell-show-pretty x))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
204 (cdr tree)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
205 ",")))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
206 ('record (let ((record (cdr tree)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
207 (format "%s%s {%s}%s"
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
208 (if parens "(" "")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
209 (car record)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
210 (mapconcat (lambda (field)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
211 (format "%s = %s"
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
212 (car field)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
213 (haskell-show-pretty (cdr field))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
214 (cdr record)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
215 ", ")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
216 (if parens ")" ""))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
217 ('num (format "%s" (cdr tree)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
218 ('string (format "%S" (cdr tree)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
219 ('data (let ((data (cdr tree)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
220 (format "%s%s%s%s"
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
221 (if parens "(" "")
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
222 (car data)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
223 (if (null (cdr data))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
224 ""
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
225 (concat " "
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
226 (mapconcat
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
227 (lambda (x) (haskell-show-pretty x t))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
228 (cdr data)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
229 " ")))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
230 (if parens ")" ""))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
231 ('tuple (format "(%s)"
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
232 (mapconcat
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
233 (lambda (x)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
234 (haskell-show-pretty x))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
235 (cdr tree)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
236 ",")))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
237 ('char (format "'%s'" (if (= (cdr tree) ?')
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
238 "\\'"
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
239 (char-to-string (cdr tree)))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
240 ('arbitrary (cdr tree))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
241 (otherwise (error "Unsupported node type: %S" tree))))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
242
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
243 (defun haskell-show-mapcar/i (f xs)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
244 "Map `f' across `xs' giving the index and length to `f' as extra parameters."
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
245 (let ((len (length xs))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
246 (i 0))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
247 (mapcar (lambda (x)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
248 (funcall f x i len)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
249 (setq i (1+ i)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
250 xs)))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
251
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
252 (defun haskell-show-indent (n s)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
253 "Indent a string `s' at colum `n'."
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
254 (concat (make-string n ? )
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
255 s))
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
256
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
257 (provide 'haskell-show)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
258
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
259 ;; Local Variables:
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
260 ;; byte-compile-warnings: (not cl-functions)
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
261 ;; End:
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
262
2764b4f45f9f 1st commit
Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp>
parents:
diff changeset
263 ;;; haskell-show.el ends here