ghc-mod/elisp/ghc-func.el

209 lines
6.0 KiB
EmacsLisp
Raw Normal View History

2010-01-06 05:38:06 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ghc-func.el
;;;
;; Author: Kazu Yamamoto <Kazu@Mew.org>
;; Created: Sep 25, 2009
;;; Code:
2010-06-14 03:03:14 +00:00
(defvar ghc-module-command "ghc-mod"
"*The command name of \"ghc-mod\"")
2010-05-04 07:35:40 +00:00
(defvar ghc-ghc-options nil "*GHC options")
2010-05-04 07:35:40 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2010-01-06 05:38:06 +00:00
(defun ghc-replace-character (string from to)
"Replace characters equal to FROM to TO in STRING."
2010-03-10 07:51:42 +00:00
(let ((ret (copy-sequence string)))
(dotimes (cnt (length ret) ret)
(if (char-equal (aref ret cnt) from)
(aset ret cnt to)))))
2010-01-06 05:38:06 +00:00
2012-03-06 08:12:15 +00:00
(defun ghc-replace-character-buffer (from-c to-c)
(let ((from (char-to-string from-c))
(to (char-to-string to-c)))
(save-excursion
(goto-char (point-min))
(while (search-forward from nil t)
(replace-match to)))))
2010-05-04 07:35:40 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro ghc-add (sym val)
`(setq ,sym (cons ,val ,sym)))
(defun ghc-set (vars vals)
(dolist (var vars)
(if var (set var (car vals))) ;; var can be nil to skip
(setq vals (cdr vals))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2010-05-04 08:52:16 +00:00
(defun ghc-filter (pred lst)
(let (ret)
(dolist (x lst (reverse ret))
(if (funcall pred x) (ghc-add ret x)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2010-01-06 05:38:06 +00:00
(defun ghc-uniq-lol (lol)
(let ((hash (make-hash-table :test 'equal))
ret)
(dolist (lst lol)
(dolist (key lst)
(puthash key key hash)))
2010-05-04 07:35:40 +00:00
(maphash (lambda (key val) (ghc-add ret key)) hash)
2010-01-06 05:38:06 +00:00
ret))
2010-05-04 07:35:40 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2010-01-06 05:38:06 +00:00
(defun ghc-read-lisp (func)
(with-temp-buffer
(funcall func)
2014-04-19 07:14:02 +00:00
(ghc-read-lisp-this-buffer)))
2014-04-19 11:07:12 +00:00
;; OK/NG are ignored.
2014-04-19 07:14:02 +00:00
(defun ghc-read-lisp-this-buffer ()
(save-excursion
2010-01-06 05:38:06 +00:00
(goto-char (point-min))
(condition-case nil
(read (current-buffer))
(error ()))))
2010-05-04 03:49:22 +00:00
(defun ghc-read-lisp-list (func n)
(with-temp-buffer
(funcall func)
(goto-char (point-min))
(condition-case nil
(let ((m (set-marker (make-marker) 1 (current-buffer)))
ret)
2010-05-04 08:52:16 +00:00
(dotimes (i n (nreverse ret))
(ghc-add ret (read m))))
2010-05-04 03:49:22 +00:00
(error ()))))
2010-05-06 06:29:55 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ghc-mapconcat (func list)
(apply 'append (mapcar func list)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2012-01-23 06:12:24 +00:00
(defun ghc-things-at-point ()
(thing-at-point 'sexp))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2010-10-28 07:24:45 +00:00
(defun ghc-keyword-number-pair (spec)
(let ((len (length spec)) key ret)
(dotimes (i len (nreverse ret))
(setq key (intern (concat ":" (symbol-name (car spec)))))
(setq ret (cons (cons key i) ret))
(setq spec (cdr spec)))))
(defmacro ghc-defstruct (type &rest spec)
`(progn
(ghc-defstruct-constructor ,type ,@spec)
(ghc-defstruct-s/getter ,type ,@spec)))
(defmacro ghc-defstruct-constructor (type &rest spec)
`(defun ,(intern (concat "ghc-make-" (symbol-name type))) (&rest args)
(let* ((alist (quote ,(ghc-keyword-number-pair spec)))
(struct (make-list (length alist) nil))
key val key-num)
(while args ;; cannot use dolist
(setq key (car args))
(setq args (cdr args))
(setq val (car args))
(setq args (cdr args))
(unless (keywordp key)
(error "'%s' is not a keyword" key))
(setq key-num (assoc key alist))
(if key-num
(setcar (nthcdr (cdr key-num) struct) val)
(error "'%s' is unknown" key)))
struct)))
(defmacro ghc-defstruct-s/getter (type &rest spec)
`(let* ((type-name (symbol-name ',type))
(keys ',spec)
(len (length keys))
member-name setter getter)
(dotimes (i len)
(setq member-name (symbol-name (car keys)))
(setq setter (intern (format "ghc-%s-set-%s" type-name member-name)))
(fset setter (list 'lambda '(struct value) (list 'setcar (list 'nthcdr i 'struct) 'value) 'struct))
(setq getter (intern (format "ghc-%s-get-%s" type-name member-name)))
(fset getter (list 'lambda '(struct) (list 'nth i 'struct)))
(setq keys (cdr keys)))))
(defun ghc-make-ghc-options ()
(ghc-mapconcat (lambda (x) (list "-g" x)) ghc-ghc-options))
2012-03-06 08:12:15 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defconst ghc-error-buffer-name "*GHC Info*")
(defun ghc-display (fontify ins-func)
(let ((buf ghc-error-buffer-name))
(with-output-to-temp-buffer buf
(with-current-buffer buf
(erase-buffer)
(funcall ins-func)
(goto-char (point-min))
(if (not fontify)
(turn-off-haskell-font-lock)
(haskell-font-lock-defaults-create)
(turn-on-haskell-font-lock)))
(display-buffer buf))))
2012-03-06 08:12:15 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ghc-run-ghc-mod (cmds)
2014-03-13 13:21:58 +00:00
(ghc-executable-find ghc-module-command
(let ((cdir default-directory))
(with-temp-buffer
(cd cdir)
2014-03-14 05:01:07 +00:00
(apply 'ghc-call-process ghc-module-command nil t nil
(append (ghc-make-ghc-options) cmds))
2014-03-13 13:21:58 +00:00
(buffer-substring (point-min) (1- (point-max)))))))
(defmacro ghc-executable-find (cmd &rest body)
;; (declare (indent 1))
`(if (not (executable-find ,cmd))
(message "\"%s\" not found" ,cmd)
,@body))
(put 'ghc-executable-find 'lisp-indent-function 1)
2014-03-14 05:01:07 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar ghc-debug nil)
(defvar ghc-debug-buffer "*GHC Debug*")
2014-03-14 12:35:30 +00:00
(defmacro ghc-with-debug-buffer (&rest body)
`(with-current-buffer (set-buffer (get-buffer-create ghc-debug-buffer))
(goto-char (point-max))
,@body))
2014-03-14 05:01:07 +00:00
(defun ghc-call-process (cmd x y z &rest args)
(apply 'call-process cmd x y z args)
(when ghc-debug
(let ((cbuf (current-buffer)))
2014-03-14 12:35:30 +00:00
(ghc-with-debug-buffer
(insert (format "%% %s %s\n" cmd (mapconcat 'identity args " ")))
(insert-buffer-substring cbuf)))))
2014-03-14 05:01:07 +00:00
2014-03-25 05:58:20 +00:00
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ghc-enclose (expr)
2014-03-25 13:05:33 +00:00
(let ((case-fold-search nil))
(if (string-match "^[a-zA-Z0-9_]" expr)
expr
(concat "(" expr ")"))))
2014-03-25 05:58:20 +00:00
2010-01-06 05:38:06 +00:00
(provide 'ghc-func)