[MLton-commit] r5095
Vesa Karvonen
vesak at mlton.org
Tue Jan 30 15:14:44 PST 2007
Added a bit of glitz.
----------------------------------------------------------------------
U mlton/trunk/ide/emacs/def-use-data.el
U mlton/trunk/ide/emacs/def-use-mode.el
U mlton/trunk/ide/emacs/def-use-util.el
U mlton/trunk/ide/emacs/esml-def-use-mlton.el
----------------------------------------------------------------------
Modified: mlton/trunk/ide/emacs/def-use-data.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-data.el 2007-01-30 20:43:09 UTC (rev 5094)
+++ mlton/trunk/ide/emacs/def-use-data.el 2007-01-30 23:14:34 UTC (rev 5095)
@@ -29,9 +29,7 @@
(and (equal (def-use-pos-line lhs) (def-use-pos-line rhs))
(< (def-use-pos-col lhs) (def-use-pos-col rhs)))))
-(defun def-use-ref (src pos)
- "Reference constructor."
- (cons (def-use-intern src) pos))
+(defalias 'def-use-ref (function cons))
(defalias 'def-use-ref-src (function car))
(defalias 'def-use-ref-pos (function cdr))
(defun def-use-ref< (lhs rhs)
@@ -39,11 +37,12 @@
(and (equal (def-use-ref-src lhs) (def-use-ref-src rhs))
(def-use-pos< (def-use-ref-pos lhs) (def-use-ref-pos rhs)))))
-(defun def-use-sym (kind name ref)
+(defun def-use-sym (kind name ref &optional face)
"Symbol constructor."
- (cons ref (cons (def-use-intern name) (def-use-intern kind))))
-(defun def-use-sym-kind (sym) (cddr sym))
-(defun def-use-sym-name (sym) (cadr sym))
+ (cons ref (cons name (cons kind face))))
+(defalias 'def-use-sym-face (function cdddr))
+(defalias 'def-use-sym-kind (function caddr))
+(defalias 'def-use-sym-name (function cadr))
(defalias 'def-use-sym-ref (function car))
(defun def-use-info ()
Modified: mlton/trunk/ide/emacs/def-use-mode.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-mode.el 2007-01-30 20:43:09 UTC (rev 5094)
+++ mlton/trunk/ide/emacs/def-use-mode.el 2007-01-30 23:14:34 UTC (rev 5095)
@@ -159,6 +159,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; List
+(defconst def-use-ref-regexp "\\([^ ]+\\):\\([0-9]+\\)\\.\\([0-9]+\\)")
+
(defvar def-use-list-mode-map
(let ((result (make-sparse-keymap)))
(mapc (function
@@ -183,12 +185,10 @@
(sym (def-use-sym-at-ref ref)))
(if (not sym)
(message "Sorry, no known symbol at cursor.")
- (let* ((title (def-use-format-sym-title sym))
- (buffer (generate-new-buffer title)))
+ (let* ((buffer (generate-new-buffer
+ (concat "<" (def-use-format-sym-title sym) ">"))))
(set-buffer buffer)
- (insert "References to " title "\n"
- "\n"
- (def-use-format-ref (def-use-sym-ref sym)) "\n"
+ (insert (def-use-format-sym sym) "\n"
"\n")
(let* ((refs (def-use-all-refs-sorted sym))
(refs (if reverse (reverse refs) refs)))
@@ -196,7 +196,7 @@
(lambda (ref)
(insert (def-use-format-ref ref) "\n")))
refs))
- (goto-line 5)
+ (goto-line 3)
(pop-to-buffer buffer)
(setq buffer-read-only t)
(def-use-list-mode)))))
@@ -206,10 +206,7 @@
(interactive)
(beginning-of-line)
(let ((b (current-buffer)))
- (when (re-search-forward
- "^\\(.*\\):\\([0-9]*\\)\\.\\([0-9]*\\)$"
- (def-use-point-at-next-line)
- t)
+ (when (re-search-forward def-use-ref-regexp (def-use-point-at-next-line) t)
(forward-line)
(def-use-goto-ref
(def-use-ref (match-string 1)
@@ -232,21 +229,30 @@
(defun def-use-format-sym (sym)
"Formats a string with some basic info on the symbol."
- (format "%s: %s, %d uses."
- (def-use-format-ref (def-use-sym-ref sym))
- (def-use-format-sym-title sym)
- (length (def-use-sym-to-uses sym))))
+ (concat (def-use-format-sym-title sym)
+ ", "
+ (number-to-string (length (def-use-sym-to-uses sym)))
+ " uses, defined at: "
+ (def-use-format-ref (def-use-sym-ref sym))))
(defun def-use-format-sym-title (sym)
"Formats a title for the symbol"
- (concat (def-use-sym-kind sym) " " (def-use-sym-name sym)))
+ (concat (def-use-add-face 'font-lock-keyword-face
+ (copy-sequence (def-use-sym-kind sym)))
+ " "
+ (def-use-add-face (def-use-sym-face sym)
+ (copy-sequence (def-use-sym-name sym)))))
(defun def-use-format-ref (ref)
"Formats a references."
- (format "%s:%d.%d"
- (def-use-ref-src ref)
- (def-use-pos-line (def-use-ref-pos ref))
- (def-use-pos-col (def-use-ref-pos ref))))
+ (let ((pos (def-use-ref-pos ref)))
+ (concat (def-use-ref-src ref)
+ ":"
+ (def-use-add-face 'font-lock-constant-face
+ (number-to-string (def-use-pos-line pos)))
+ "."
+ (def-use-add-face 'font-lock-constant-face
+ (number-to-string (def-use-pos-col pos))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Highlighting
Modified: mlton/trunk/ide/emacs/def-use-util.el
===================================================================
--- mlton/trunk/ide/emacs/def-use-util.el 2007-01-30 20:43:09 UTC (rev 5094)
+++ mlton/trunk/ide/emacs/def-use-util.el 2007-01-30 23:14:34 UTC (rev 5095)
@@ -15,8 +15,10 @@
(def-use-gethash-or-put file
(function
(lambda ()
- (def-use-intern (file-truename file))))
- def-use-intern-table))
+ (def-use-intern
+ (def-use-add-face 'change-log-file-face
+ (file-truename file)))))
+ def-use-file-truename-table))
(defun def-use-buffer-true-file-name ()
"Returns the true filename of the current buffer."
@@ -84,6 +86,12 @@
(interactive)
(kill-buffer (current-buffer)))
+(defun def-use-add-face (face string)
+ "Adds the face as a property to the entire string and returns the
+string."
+ (add-text-properties 0 (length string) `(face ,face) string)
+ string)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(provide 'def-use-util)
Modified: mlton/trunk/ide/emacs/esml-def-use-mlton.el
===================================================================
--- mlton/trunk/ide/emacs/esml-def-use-mlton.el 2007-01-30 20:43:09 UTC (rev 5094)
+++ mlton/trunk/ide/emacs/esml-def-use-mlton.el 2007-01-30 23:14:34 UTC (rev 5095)
@@ -4,6 +4,7 @@
;; See the file MLton-LICENSE for details.
(require 'def-use-mode)
+(require 'sml-mode)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Parsing of def-use -files produced by MLton.
@@ -37,6 +38,15 @@
(skip-chars-forward skipping)
result)))
+(defconst esml-def-use-kinds
+ `((,(def-use-intern "variable") . ,font-lock-variable-name-face)
+ (,(def-use-intern "type") . ,font-lock-type-def-face)
+ (,(def-use-intern "constructor") . ,font-lock-constant-face)
+ (,(def-use-intern "structure") . ,font-lock-module-def-face)
+ (,(def-use-intern "signature") . ,font-lock-interface-def-face)
+ (,(def-use-intern "functor") . ,font-lock-module-def-face)
+ (,(def-use-intern "exception") . ,font-lock-module-def-face)))
+
(defun esml-def-use-mlton-parse (duf)
"Parses a def-use -file."
(interactive "fSpecify def-use -file: ")
@@ -45,15 +55,16 @@
(insert-file duf)
(goto-char 1)
(while (not (eobp))
- (let* ((kind (esml-def-use-read "^ " " "))
- (name (esml-def-use-read "^ " " "))
+ (let* ((kind (def-use-intern (esml-def-use-read "^ " " ")))
+ (name (def-use-intern (esml-def-use-read "^ " " ")))
(src (esml-def-use-mlton-resolve-src
(esml-def-use-read "^ " " ") duf))
(line (string-to-int (esml-def-use-read "^." ".")))
(col (- (string-to-int (esml-def-use-read "^\n" "\n")) 1))
(pos (def-use-pos line col))
(ref (def-use-ref src pos))
- (sym (def-use-sym kind name ref)))
+ (sym (def-use-sym kind name ref
+ (cdr (assoc kind esml-def-use-kinds)))))
(def-use-add-def duf sym)
(while (< 0 (skip-chars-forward " "))
(let* ((src (esml-def-use-mlton-resolve-src
More information about the MLton-commit
mailing list