Mercurial > hg > Members > kokubo > emacs
view .emacs.d/haskell-mode/haskell-show.el @ 0:2764b4f45f9f
1st commit
author | Shohei KOKUBO <e105744@ie.u-ryukyu.ac.jp> |
---|---|
date | Mon, 21 Apr 2014 04:30:59 +0900 |
parents | |
children |
line wrap: on
line source
;;; 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