--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.emacs.d/haskell-mode/haskell-show.el	Mon Apr 21 04:30:59 2014 +0900
@@ -0,0 +1,263 @@
+;;; haskell-show.el --- A pretty printer for Haskell Show values
+
+;; Copyright (C) 2011  Chris Done
+
+;; Author: Chris Done <chrisdone@gmail.com>
+
+;; This file is not part of GNU Emacs.
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; It doesn't support some number literals (probably).  I'm not
+;; precisely sure what values Show will always produce.  There is
+;; however a test suite available, so patches for extra Show support
+;; is welcome and should be easy to test.
+
+;;; Code:
+
+(defvar sexp-show "sexp-show")
+(require 'haskell-string)
+(with-no-warnings (require 'cl))
+
+(defun haskell-show-replace-region ()
+  "Replace the given region with a pretty printed version."
+  (interactive)
+  (haskell-show-replace (region-beginning) (region-end)))
+
+;;;###autoload
+(defun haskell-show-replace (start end)
+  "Replace the given region containing a Show value with a pretty
+  printed collapsible version."
+  (let ((text (buffer-substring-no-properties start end)))
+    (goto-char start)
+    (delete-region start end)
+    (haskell-show-parse-and-insert text)))
+
+;;;###autoload
+(defun haskell-show-parse-and-insert (given)
+  "Parse a `string' containing a Show instance value and insert
+  it pretty printed into the current buffer."
+  (when (not (string= "" (haskell-trim given)))
+    (let ((current-column (- (point)
+                             (line-beginning-position)))
+          (result (haskell-show-parse given)))
+      (if (string-match "^[\\(]" result)
+          (let ((v (read result)))
+            (if (equal (car v) 'arbitrary)
+                (insert given)
+              (haskell-show-insert-pretty current-column v)))
+        (insert given)))))
+
+;;;###autoload
+(defun haskell-show-parse (given)
+  "Parse the given input into a tree."
+  (with-temp-buffer
+    (insert given)
+    (shell-command-on-region
+     (point-min)
+     (point-max)
+     sexp-show
+     t)
+    (buffer-substring-no-properties (point-min) (point-max))))
+
+(defun haskell-show-insert-pretty (column tree &optional parens)
+  "Insert a Show `tree' into the current buffer with collapsible nodes."
+  (case (car tree)
+    ('list (let ((start (point)))
+             (insert "[")
+             (haskell-show-mapcar/i (lambda (x i len)
+                                      (haskell-show-insert-pretty (+ column 1) x)
+                                      (unless (> i (- len 2))
+                                        (if (< (+ column (length (haskell-show-pretty tree parens)))
+                                               80)
+                                            (insert ",")
+                                          (insert (concat ",\n" (haskell-show-indent (+ 1 column) ""))))))
+                                    (cdr tree))
+             (insert "]")))
+    ('tuple (let ((start (point)))
+              (insert "(")
+              (haskell-show-mapcar/i (lambda (x i len)
+                                       (haskell-show-insert-pretty (+ column 1) x)
+                                       (unless (> i (- len 2))
+                                         (if (< (+ column (length (haskell-show-pretty tree parens)))
+                                                80)
+                                             (insert ",")
+                                           (insert (concat ",\n" (haskell-show-indent (+ 1 column) ""))))))
+                                     (cdr tree))
+              (insert ")")))
+    ('record
+     (let ((record (cdr tree)) (overlay (list 'nil)))
+       (insert (if parens "(" ""))
+       (let ((link-start (point)))
+         (insert (car record))
+         (let ((button (make-text-button link-start (point) :type 'haskell-show-toggle-button)))
+           (put-text-property link-start (point) 'face 'font-lock-type-face)
+           (button-put button 'overlay overlay)))
+       (insert " {\n")
+       (let ((curly-start (1- (point)))
+             (show-len (+ column (length (haskell-show-pretty tree parens)))))
+         (haskell-show-mapcar/i (lambda (field i len)
+                                  (insert
+                                   (haskell-show-indent
+                                    (if (and (> i 0) (< show-len 80)) 0 column)
+                                    (car field)))
+                                  (insert " = ")
+                                  (put-text-property (- (point) 3) (point) 'face
+                                                     'font-lock-constant-face)
+                                  (haskell-show-insert-pretty
+                                   (if (< show-len 80)
+                                       0
+                                     (+ (length (car field)) column 3))
+                                   (cdr field))
+                                  (unless (> i (- len 2))
+                                    (if (< show-len 80)
+                                        (insert ", ")
+                                      (insert ",\n"))))
+                                (cdr record))
+         (insert (concat "\n" (haskell-show-indent column "}")))
+         (progn
+           (setf (car overlay) (make-overlay curly-start (- (point) 1) nil t))
+           (overlay-put (car overlay) 'invisible t))
+         (insert (if parens ")" "")))))
+    ('num (let ((num-start (point)))
+            (insert (format "%d" (cdr tree)))
+            (put-text-property num-start (point) 'face 'font-lock-constant-face)))
+    ('string (let ((str-start (point)))
+               (insert "\"")
+               (if (< (+ column (length (cdr tree))) 60)
+                   (progn
+                     (insert (format "%s" (cdr tree)))
+                     (put-text-property (+ 1 str-start) (point) 'face 'font-lock-string-face))
+                 (progn
+                   (insert "…")
+                   (insert (format "%s" (cdr tree)))
+                   (let ((overlay (make-overlay (+ 2 str-start) (point) nil t)))
+                     (overlay-put overlay 'invisible t)
+                     (put-text-property (+ 2 str-start) (point) 'face 'font-lock-string-face)
+                     (let ((button (make-text-button (+ 1 str-start) (+ 2 str-start)
+                                                     :type 'haskell-show-toggle-button)))
+                       (put-text-property (+ 1 str-start) (+ 2 str-start)
+                                          'face 'font-lock-keyword-face)
+                       (button-put button 'overlay (list overlay))
+                       (button-put button 'hide-on-click t)))))
+               (insert "\"")))
+    ('data (let ((data (cdr tree)))
+             (insert (if parens "(" ""))
+             (let ((cons-start (point)))
+               (insert (car data))
+               (put-text-property cons-start (point) 'face 'font-lock-type-face))
+             (unless (null (cdr data))
+               (progn (insert " ")
+                      (haskell-show-mapcar/i
+                       (lambda (x i len)
+                         (haskell-show-insert-pretty column x t)
+                         (unless (> i (- len 2))
+                           (insert " ")))
+                       (cdr data))))
+             (insert (if parens ")" ""))))
+    ('char (progn (insert "'")
+                  (insert (char-to-string (cdr tree)))
+                  (put-text-property (- (point) 1) (point) 'face 'font-lock-string-face)
+                  (insert "'")))
+    ('arbitrary (let ((start (point)))
+                  (insert (cdr tree))
+                  (put-text-property start (point) 'face 'font-lock-comment-face)))
+    (otherwise (error "Unsupported node type: %S" tree))))
+
+(define-button-type 'haskell-show-toggle-button
+  'action 'haskell-show-toggle-button-callback
+  'follow-link t
+  'help-echo "Click to expand…")
+
+(defun haskell-show-toggle-button-callback (btn)
+  "The callback to toggle the overlay visibility."
+  (let ((overlay (button-get btn 'overlay)))
+    (when overlay
+      (overlay-put (car overlay)
+                   'invisible (not (overlay-get (car overlay)
+                                                'invisible)))))
+  (let ((hide (button-get btn 'remove-on-click)))
+    (when hide
+      (button-put btn 'invisible t))))
+
+(defun haskell-show-pretty (tree &optional parens)
+  "Show a Show `tree'."
+  (case (car tree)
+    ('list (format "[%s]"
+                   (mapconcat
+                    (lambda (x)
+                      (haskell-show-pretty x))
+                    (cdr tree)
+                    ",")))
+    ('record (let ((record (cdr tree)))
+               (format "%s%s {%s}%s"
+                       (if parens "(" "")
+                       (car record)
+                       (mapconcat (lambda (field)
+                                    (format "%s = %s"
+                                            (car field)
+                                            (haskell-show-pretty (cdr field))))
+                                  (cdr record)
+                                  ", ")
+                       (if parens ")" ""))))
+    ('num (format "%s" (cdr tree)))
+    ('string (format "%S" (cdr tree)))
+    ('data (let ((data (cdr tree)))
+             (format "%s%s%s%s"
+                     (if parens "(" "")
+                     (car data)
+                     (if (null (cdr data))
+                         ""
+                       (concat " "
+                               (mapconcat
+                                (lambda (x) (haskell-show-pretty x t))
+                                (cdr data)
+                                " ")))
+                     (if parens ")" ""))))
+    ('tuple (format "(%s)"
+                    (mapconcat
+                     (lambda (x)
+                       (haskell-show-pretty x))
+                     (cdr tree)
+                     ",")))
+    ('char (format "'%s'" (if (= (cdr tree) ?')
+                              "\\'"
+                            (char-to-string (cdr tree)))))
+    ('arbitrary (cdr tree))
+    (otherwise (error "Unsupported node type: %S" tree))))
+
+(defun haskell-show-mapcar/i (f xs)
+  "Map `f' across `xs' giving the index and length to `f' as extra parameters."
+  (let ((len (length xs))
+        (i 0))
+    (mapcar (lambda (x)
+              (funcall f x i len)
+              (setq i (1+ i)))
+            xs)))
+
+(defun haskell-show-indent (n s)
+  "Indent a string `s' at colum `n'."
+  (concat (make-string n ? )
+          s))
+
+(provide 'haskell-show)
+
+;; Local Variables:
+;; byte-compile-warnings: (not cl-functions)
+;; End:
+
+;;; haskell-show.el ends here