ide/emacs/esml-du-mlton.el

   1 ;; Copyright (C) 2007-2008 Vesa Karvonen
   2 ;;
   3 ;; MLton is released under a BSD-style license.
   4 ;; See the file MLton-LICENSE for details.
   5
   6 (require 'def-use-mode)
   7 (require 'bg-job)
   8 (require 'esml-util)
   9
  10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  11 ;; Customization
  12
  13 (defgroup esml-du nil
  14   "MLton def-use info plugin for `def-use-mode'."
  15   :group 'sml)
  16
  17 (defcustom esml-du-notify 'never
  18   "Notify certain events, such as when a def-use -file has been
  19 (re)loaded."
  20   :type '(choice (const :tag "Never" never)
  21                  (const :tag "Always" always))
  22   :group 'esml-du)
  23
  24 (defcustom esml-du-dufs-auto-load nil
  25   "Automatic loading of `esml-du-dufs-recent' at startup."
  26   :type '(choice
  27           (const :tag "Disabled" nil)
  28           (const :tag "Enabled" t))
  29   :group 'esml-du)
  30
  31 (defcustom esml-du-dufs-recent '()
  32   "Automatically updated list of def-use -files currently or previously
  33 loaded.  This customization variable is not usually manipulated directly
  34 by the user."
  35   :type '(repeat
  36           (file :tag "Def-Use file" :must-match t))
  37   :group 'esml-du)
  38
  39 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40 ;; Interface
  41
  42 (defvar esml-du-mlton-history nil)
  43
  44 (defun esml-du-mlton (&optional duf dont-save)
  45   "Gets def-use information from a def-use file produced by MLton."
  46   (interactive)
  47   (cond
  48    ((not duf)
  49     (esml-du-mlton
  50      (compat-read-file-name
  51       "Specify def-use -file: " nil nil t nil 'esml-du-mlton-history)
  52      dont-save))
  53    ((not (and (file-readable-p duf)
  54               (file-regular-p duf)))
  55     (compat-error "Specified file is not a regular readable file"))
  56    ((run-with-idle-timer
  57      0.5 nil
  58      (function
  59       (lambda (duf dont-save)
  60         (let ((duf (def-use-file-truename duf)))
  61           (unless (member duf esml-du-live-dufs)
  62             (let ((ctx (esml-du-ctx duf)))
  63               (esml-du-load ctx)
  64               (esml-du-set-live-dufs (cons duf esml-du-live-dufs) dont-save)
  65               (def-use-add-dus
  66                 (function esml-du-title)
  67                 (function esml-du-sym-at-ref)
  68                 (function esml-du-sym-to-uses)
  69                 (function esml-du-finalize)
  70                 (function esml-du-ctx-attr)
  71                 ctx))))))
  72      duf dont-save))))
  73
  74 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  75 ;; Move to symbol
  76
  77 (defun esml-du-character-class (c)
  78   (cond
  79    ((find c esml-sml-symbolic-chars)
  80     'symbolic)
  81    ((and c (<= ?0 c) (<= c ?9))
  82     'numeric)
  83    ((find c esml-sml-alphanumeric-chars)
  84     'alpha)))
  85
  86 (defun esml-du-extract-following-symbol (chars)
  87   (save-excursion
  88     (let ((start (point)))
  89       (skip-chars-forward chars)
  90       (buffer-substring start (point)))))
  91
  92 (defun esml-du-move-to-symbol-start ()
  93   "Moves to the start of the SML symbol at point.  If the point is between
  94 two symbols, one symbolic and other alphanumeric (e.g. !x) the symbol
  95 following the point is preferred.  This ensures that the symbol does not
  96 change surprisingly after a jump."
  97   (let ((point (point)))
  98     (let ((bef (esml-du-character-class (char-before)))
  99           (aft (esml-du-character-class (char-after))))
 100       (cond
 101        ((and (or (eq bef 'alpha) (eq bef 'numeric)) (eq aft 'symbolic)
 102              (find (esml-du-extract-following-symbol esml-sml-symbolic-chars)
 103                    esml-sml-symbolic-keywords
 104                    :test 'equal))
 105         (skip-chars-backward esml-sml-alphanumeric-chars))
 106        ((and (eq bef 'symbolic)
 107              (or (eq aft 'numeric)
 108                  (and (eq aft 'alpha)
 109                       (find (esml-du-extract-following-symbol
 110                              esml-sml-alphanumeric-chars)
 111                             esml-sml-alphanumeric-keywords
 112                             :test 'equal))))
 113         (skip-chars-backward esml-sml-symbolic-chars))
 114        ((and (eq bef 'symbolic) (not (eq aft 'alpha)))
 115         (skip-chars-backward esml-sml-symbolic-chars))
 116        ((and (or (eq bef 'alpha) (eq bef 'numeric)) (not (eq aft 'symbolic)))
 117         (skip-chars-backward esml-sml-alphanumeric-chars))))
 118     (when (let ((c (char-after))) (and c (<= ?0 c) (<= c ?9)))
 119       (search-forward-regexp esml-sml-numeric-literal-regexp point t))))
 120
 121 (loop for mode in esml-sml-modes do
 122   (add-to-list 'def-use-mode-to-move-to-symbol-start-alist
 123                (cons mode (function esml-du-move-to-symbol-start))))
 124
 125 (defun esml-du-move-to-symbol-end ()
 126   "Moves to the end of the SML symbol at point assuming that we are at the
 127 beginning of the symbol."
 128   (let ((limit (def-use-point-at-next-line)))
 129     (when (zerop (skip-chars-forward esml-sml-alphanumeric-chars limit))
 130       (skip-chars-forward esml-sml-symbolic-chars limit))))
 131
 132 (loop for mode in esml-sml-modes do
 133   (add-to-list 'def-use-mode-to-move-to-symbol-end-alist
 134                (cons mode (function esml-du-move-to-symbol-end))))
 135
 136 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 137 ;; Methods
 138
 139 (defun esml-du-title (ctx)
 140   (concat
 141    (esml-du-ctx-duf ctx)
 142    " [loaded " (int-to-string (esml-du-ctx-load-cnt ctx)) " times]"))
 143
 144 (defun esml-du-sym-at-ref (ref ctx)
 145   (esml-du-reload ctx)
 146   (unless (or (let ((buffer (def-use-find-buffer-visiting-file
 147                               (def-use-ref-src ref))))
 148                 (and buffer (buffer-modified-p buffer)))
 149               (def-use-attr-newer?
 150                 (file-attributes (def-use-ref-src ref))
 151                 (esml-du-ctx-attr ctx)))
 152     (or (gethash ref (esml-du-ctx-ref-to-sym-table ctx))
 153         (and (esml-du-try-to-read-symbol-at-ref ref ctx)
 154              (gethash ref (esml-du-ctx-ref-to-sym-table ctx))))))
 155
 156 (defun esml-du-sym-to-uses (sym ctx)
 157   (esml-du-reload ctx)
 158   (let ((file-to-poss (def-use-make-hash-table)))
 159     ;; Process by buffer/file as it avoids repeated work
 160     (mapc (function
 161            (lambda (ref)
 162              (puthash (def-use-ref-src ref)
 163                       (cons ref
 164                             (gethash (def-use-ref-src ref) file-to-poss))
 165                       file-to-poss)))
 166           (gethash sym (esml-du-ctx-sym-to-uses-table ctx)))
 167     ;; Remove references to modified buffers
 168     (mapc (function
 169            (lambda (buffer)
 170              (when (buffer-modified-p buffer)
 171                (remhash (def-use-buffer-file-truename buffer)
 172                         file-to-poss))))
 173           (buffer-list))
 174     ;; Remove references to modified files
 175     (mapc (function
 176            (lambda (file)
 177              (when (def-use-attr-newer?
 178                      (file-attributes file)
 179                      (esml-du-ctx-attr ctx))
 180                (remhash file file-to-poss))))
 181           (def-use-hash-table-to-key-list file-to-poss))
 182     (apply (function nconc)
 183            (def-use-hash-table-to-value-list file-to-poss))))
 184
 185 (defun esml-du-stop-parsing (ctx)
 186   (let ((buffer (esml-du-ctx-buf ctx)))
 187     (when buffer
 188       (kill-buffer buffer))))
 189
 190 (defvar esml-du-live-dufs nil)
 191
 192 (defun esml-du-set-live-dufs (dufs &optional dont-save)
 193   (setq esml-du-live-dufs dufs)
 194   (when (and (not dont-save)
 195              esml-du-dufs-auto-load)
 196     (customize-save-variable
 197      'esml-du-dufs-recent
 198      (copy-list dufs))))
 199
 200 (defun esml-du-finalize (ctx)
 201   (esml-du-stop-parsing ctx)
 202   (let ((timer (esml-du-ctx-poll-timer ctx)))
 203     (when timer
 204       (compat-delete-timer timer)
 205       (esml-du-ctx-set-poll-timer nil ctx)))
 206   (let ((timer (esml-du-ctx-reload-timer ctx)))
 207     (when timer
 208       (compat-delete-timer timer)
 209       (esml-du-ctx-set-reload-timer nil ctx)))
 210   (esml-du-set-live-dufs
 211    (remove* (esml-du-ctx-duf ctx)
 212             esml-du-live-dufs
 213             :test (function equal))))
 214
 215 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 216 ;; Context
 217
 218 (defun esml-du-ctx (duf)
 219   (vector (def-use-make-hash-table) (def-use-make-hash-table) duf nil nil nil 0
 220           nil nil))
 221
 222 (defun esml-du-ctx-reload-timer      (ctx) (aref ctx 7))
 223 (defun esml-du-ctx-load-cnt          (ctx) (aref ctx 6))
 224 (defun esml-du-ctx-poll-timer        (ctx) (aref ctx 5))
 225 (defun esml-du-ctx-buf               (ctx) (aref ctx 4))
 226 (defun esml-du-ctx-attr              (ctx) (aref ctx 3))
 227 (defun esml-du-ctx-duf               (ctx) (aref ctx 2))
 228 (defun esml-du-ctx-ref-to-sym-table  (ctx) (aref ctx 1))
 229 (defun esml-du-ctx-sym-to-uses-table (ctx) (aref ctx 0))
 230
 231 (defun esml-du-ctx-inc-load-cnt (ctx)
 232   (aset ctx 6 (1+ (aref ctx 6))))
 233
 234 (defun esml-du-ctx-set-reload-timer (timer ctx) (aset ctx 7 timer))
 235 (defun esml-du-ctx-set-poll-timer   (timer ctx) (aset ctx 5 timer))
 236 (defun esml-du-ctx-set-buf          (buf   ctx) (aset ctx 4 buf))
 237 (defun esml-du-ctx-set-attr         (attr  ctx) (aset ctx 3 attr))
 238
 239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 240 ;; Parsing
 241
 242 (defun esml-du-read (taking skipping)
 243   (let ((start (point)))
 244     (skip-chars-forward taking)
 245     (let ((result (buffer-substring start (point))))
 246       (skip-chars-forward skipping)
 247       result)))
 248
 249 (defun esml-du-read-opt-str ()
 250   (when (= (char-after) ?\")
 251     (forward-char 1)
 252     (esml-du-read "^\"" "\"")))
 253
 254 (defconst esml-du-classes ;; XXX Needs customization
 255   `((,(def-use-intern "variable")    . ,font-lock-variable-name-face)
 256     (,(def-use-intern "type")        . ,font-lock-variable-name-face)
 257     (,(def-use-intern "constructor") . ,font-lock-variable-name-face)
 258     (,(def-use-intern "structure")   . ,font-lock-variable-name-face)
 259     (,(def-use-intern "signature")   . ,font-lock-variable-name-face)
 260     (,(def-use-intern "functor")     . ,font-lock-variable-name-face)
 261     (,(def-use-intern "exception")   . ,font-lock-variable-name-face)))
 262
 263 (defun esml-du-reload (ctx)
 264   "Schedules a reload of the def-use file if it has been modified."
 265   (let ((attrs (file-attributes (esml-du-ctx-duf ctx))))
 266     (when (def-use-attr-changed?
 267             attrs
 268             (esml-du-ctx-attr ctx))
 269       (when (esml-du-ctx-reload-timer ctx)
 270         (compat-delete-timer (esml-du-ctx-reload-timer ctx)))
 271       (esml-du-ctx-set-reload-timer
 272        (run-with-idle-timer
 273         0.5
 274         nil
 275         (function
 276          (lambda (ctx attrs)
 277            (if (def-use-attr-changed?
 278                  (file-attributes (esml-du-ctx-duf ctx))
 279                  attrs)
 280                (esml-du-reload ctx)
 281              (esml-du-ctx-set-reload-timer nil ctx)
 282              (esml-du-load ctx))))
 283         ctx attrs)
 284        ctx))))
 285
 286 (defun esml-du-try-to-read-symbol-at-ref-once (ref ctx)
 287   (when (search-forward (esml-du-ref-to-appx-syntax ref) nil t)
 288     (beginning-of-line)
 289     (while (= ?\  (char-after))
 290       (forward-line -1))
 291     (esml-du-read-one-symbol ctx)))
 292
 293 (defun esml-du-try-to-read-all-symbols-at-ref (ref ctx)
 294   (let ((syms nil))
 295     (goto-char 1)
 296     (while (let ((sym (esml-du-try-to-read-symbol-at-ref-once ref ctx)))
 297              (when sym
 298                (push sym syms))))
 299     syms))
 300
 301 (defun esml-du-try-to-read-symbol-at-ref (ref ctx)
 302   "Tries to read the symbol at the specified ref from the duf.  Returns
 303 non-nil if something was actually read."
 304   (let ((buffer (esml-du-ctx-buf ctx)))
 305     (when buffer
 306       (bury-buffer buffer)
 307       (with-current-buffer buffer
 308         (let ((syms (esml-du-try-to-read-all-symbols-at-ref ref ctx)))
 309           (when syms
 310             (while syms
 311               (let* ((sym (pop syms))
 312                      (more-syms
 313                       (esml-du-try-to-read-all-symbols-at-ref
 314                        (def-use-sym-ref sym) ctx)))
 315                 (when more-syms
 316                   (setq syms (nconc more-syms syms)))))
 317             t))))))
 318
 319 (defun esml-du-ref-to-appx-syntax (ref)
 320   (let ((pos (def-use-ref-pos ref)))
 321     (concat
 322      (file-name-nondirectory (def-use-ref-src ref)) " "
 323      (int-to-string (def-use-pos-line pos)) "."
 324      (int-to-string (1+ (def-use-pos-col pos))))))
 325
 326 (defconst esml-du-highlight-type-map ;; XXX Needs customization
 327   `(("\\([a-zA-Z0-9_]+\\)[:]"
 328      . ,font-lock-constant-face)
 329     ("\\([a-zA-Z0-9_]+\\)\\>\\(?:[^:]\\|$\\)"
 330      . ,font-lock-type-face)
 331     ("\\(\\<andalso\\>\\)"
 332      . ,font-lock-keyword-face)
 333     (,(concat "\\<\\("
 334               (regexp-opt
 335                '("array" "bool" "char" "exn" "int" "list" "option" "order"
 336                  "real" "ref" "string" "substring" "unit" "vector" "word"))
 337               "\\)\\>")
 338      . ,font-lock-builtin-face)
 339     ("\\('[a-zA-Z0-9_]+\\)"
 340      . ,font-lock-variable-name-face)))
 341
 342 (defun esml-du-highlight-type (string)
 343   (when string
 344     (loop for pat-face in esml-du-highlight-type-map do
 345           (let ((pat (car pat-face))
 346                 (prop `(face ,(cdr pat-face)))
 347                 (start 0))
 348             (while (string-match pat string start)
 349               (add-text-properties
 350                (match-beginning 1)
 351                (match-end 1)
 352                prop
 353                string)
 354               (setq start (match-end 0))))))
 355   string)
 356
 357 (defun esml-du-read-one-symbol (ctx)
 358   "Reads one symbol from the current buffer starting at the current point.
 359 Returns the symbol read and deletes the read symbol from the buffer."
 360   (let* ((start (point))
 361          (ref-to-sym (esml-du-ctx-ref-to-sym-table ctx))
 362          (sym-to-uses (esml-du-ctx-sym-to-uses-table ctx))
 363          (class (def-use-intern (esml-du-read "^ " " ")))
 364          (name (def-use-intern (esml-du-read "^ " " ")))
 365          (src (def-use-file-truename (esml-du-read "^ " " ")))
 366          (line (string-to-int (esml-du-read "^." ".")))
 367          (col (1- (string-to-int (esml-du-read "^ \n" " "))))
 368          (msg (esml-du-highlight-type
 369                (def-use-intern (esml-du-read-opt-str))))
 370          (pos (def-use-pos line col))
 371          (ref (def-use-ref src pos))
 372          (sym (def-use-sym class msg name ref
 373                 (cdr (assoc class esml-du-classes))))
 374          (uses nil))
 375     (let ((old-sym (gethash ref ref-to-sym)))
 376       (when old-sym
 377         (setq sym old-sym))
 378       (puthash ref sym ref-to-sym))
 379     (skip-chars-forward "\n")
 380     (while (< 0 (skip-chars-forward " "))
 381       (let* ((src (def-use-file-truename (esml-du-read "^ " " ")))
 382              (line (string-to-int (esml-du-read "^." ".")))
 383              (col (1- (string-to-int (esml-du-read "^\n" "\n"))))
 384              (pos (def-use-pos line col))
 385              (ref (def-use-ref src pos)))
 386         (let ((old-sym (gethash ref ref-to-sym)))
 387           (when old-sym
 388             (let ((old-uses (gethash old-sym sym-to-uses)))
 389               (remhash old-sym sym-to-uses)
 390               (mapc
 391                (function
 392                 (lambda (ref)
 393                   (puthash ref sym ref-to-sym)))
 394                old-uses)
 395               (setq uses (nconc uses old-uses)))))
 396         (puthash ref sym ref-to-sym)
 397         (push ref uses)))
 398     (puthash sym uses sym-to-uses)
 399     (setq buffer-read-only nil)
 400     (delete-backward-char (- (point) start))
 401     (setq buffer-read-only t)
 402     sym))
 403
 404 (defun esml-du-load (ctx)
 405   "Loads the def-use file to a buffer for performing queries."
 406   (esml-du-ctx-set-attr (file-attributes (esml-du-ctx-duf ctx)) ctx)
 407   (if (esml-du-ctx-buf ctx)
 408       (with-current-buffer (esml-du-ctx-buf ctx)
 409         (goto-char 1)
 410         (setq buffer-read-only nil)
 411         (delete-char (1- (point-max))))
 412     (esml-du-ctx-set-buf
 413      (generate-new-buffer (concat "** " (esml-du-ctx-duf ctx) " **")) ctx)
 414     (with-current-buffer (esml-du-ctx-buf ctx)
 415       (buffer-disable-undo)
 416       (compat-add-local-hook
 417        'kill-buffer-hook
 418        (lexical-let ((ctx ctx))
 419          (function
 420           (lambda ()
 421             (esml-du-ctx-set-buf nil ctx)))))))
 422   (bury-buffer (esml-du-ctx-buf ctx))
 423   (with-current-buffer (esml-du-ctx-buf ctx)
 424     (insert-file-contents (esml-du-ctx-duf ctx))
 425     (setq buffer-read-only t)
 426     (goto-char 1))
 427   (clrhash (esml-du-ctx-ref-to-sym-table ctx))
 428   (clrhash (esml-du-ctx-sym-to-uses-table ctx))
 429   (garbage-collect)
 430   (when (memq esml-du-notify '(always))
 431     (message "Loaded %s" (esml-du-ctx-duf ctx)))
 432   (esml-du-ctx-inc-load-cnt ctx))
 433
 434 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 435
 436 (run-with-idle-timer
 437  1.0 nil
 438  (function
 439   (lambda ()
 440     (when esml-du-dufs-auto-load
 441       (mapc (function
 442              (lambda (file)
 443                (when (and (file-readable-p file)
 444                           (file-regular-p file))
 445                  (esml-du-mlton file t))))
 446             esml-du-dufs-recent)))))
 447
 448 (provide 'esml-du-mlton)