misc/factor.el

   1 ;;; factor.el --- Interacting with Factor within emacs
   2 ;;
   3 ;; Authors: Eduardo Cavazos <wayo.cavazos@gmail.com>
   4 ;;          Jose A Ortega Ruiz <jao@gnu.org>
   5 ;; Keywords: languages
   6
   7 ;;; Commentary:
   8
   9 ;;; Quick setup:
  10
  11 ;; Add these lines to your .emacs file:
  12 ;;
  13 ;;   (load-file "/scratch/repos/Factor/misc/factor.el")
  14 ;;   (setq factor-binary "/scratch/repos/Factor/factor")
  15 ;;   (setq factor-image "/scratch/repos/Factor/factor.image")
  16 ;;
  17 ;; Of course, you'll have to edit the directory paths for your system
  18 ;; accordingly. Alternatively, put this file in your load-path and use
  19 ;;
  20 ;;   (require 'factor)
  21 ;;
  22 ;; instead of load-file.
  23 ;;
  24 ;; That's all you have to do to "install" factor.el on your
  25 ;; system. Whenever you edit a factor file, Emacs will know to switch
  26 ;; to Factor mode.
  27 ;;
  28 ;; For further customization options,
  29 ;;   M-x customize-group RET factor
  30 ;;
  31 ;; To start a Factor listener inside Emacs,
  32 ;;   M-x run-factor
  33
  34 ;;; Requirements:
  35
  36 (require 'font-lock)
  37 (require 'comint)
  38 (require 'view)
  39 (require 'ring)
  40
  41 ;;; Customization:
  42
  43 (defgroup factor nil
  44   "Factor mode"
  45   :group 'languages)
  46
  47 (defcustom factor-default-indent-width 4
  48   "Default indentantion width for factor-mode.
  49
  50 This value will be used for the local variable
  51 `factor-indent-width' in new factor buffers. For existing code,
  52 we first check if `factor-indent-width' is set explicitly in a
  53 local variable section or line (e.g. '! -*- factor-indent-witdth: 2 -*-').
  54 If that's not the case, `factor-mode' tries to infer its correct
  55 value from the existing code in the buffer."
  56   :type 'integer
  57   :group 'factor)
  58
  59 (defcustom factor-binary "~/factor/factor"
  60   "Full path to the factor executable to use when starting a listener."
  61   :type '(file :must-match t)
  62   :group 'factor)
  63
  64 (defcustom factor-image "~/factor/factor.image"
  65   "Full path to the factor image to use when starting a listener."
  66   :type '(file :must-match t)
  67   :group 'factor)
  68
  69 (defcustom factor-use-doc-window t
  70   "When on, use a separate window to display help information.
  71 Disable to see that information in the factor-listener comint
  72 window."
  73   :type 'boolean
  74   :group 'factor)
  75
  76 (defcustom factor-listener-use-other-window t
  77   "Use a window other than the current buffer's when switching to
  78 the factor-listener buffer."
  79   :type 'boolean
  80   :group 'factor)
  81
  82 (defcustom factor-listener-window-allow-split t
  83   "Allow window splitting when switching to the factor-listener
  84 buffer."
  85   :type 'boolean
  86   :group 'factor)
  87
  88 (defcustom factor-help-always-ask t
  89   "When enabled, always ask for confirmation in help prompts."
  90   :type 'boolean
  91   :group 'factor)
  92
  93 (defcustom factor-help-use-minibuffer t
  94   "When enabled, use the minibuffer for short help messages."
  95   :type 'boolean
  96   :group 'factor)
  97
  98 (defcustom factor-display-compilation-output t
  99   "Display the REPL buffer before compiling files."
 100   :type 'boolean
 101   :group 'factor)
 102
 103 (defcustom factor-mode-hook nil
 104   "Hook run when entering Factor mode."
 105   :type 'hook
 106   :group 'factor)
 107
 108 (defcustom factor-help-mode-hook nil
 109   "Hook run by `factor-help-mode'."
 110   :type 'hook
 111   :group 'factor)
 112
 113 (defgroup factor-faces nil
 114   "Faces used in Factor mode"
 115   :group 'factor
 116   :group 'faces)
 117
 118 (defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face)
 119   "Face for parsing words."
 120   :group 'factor-faces)
 121
 122 (defface factor-font-lock-declaration (face-default-spec font-lock-keyword-face)
 123   "Face for declaration words (inline, parsing ...)."
 124   :group 'factor-faces)
 125
 126 (defface factor-font-lock-comment (face-default-spec font-lock-comment-face)
 127   "Face for comments."
 128   :group 'factor-faces)
 129
 130 (defface factor-font-lock-string (face-default-spec font-lock-string-face)
 131   "Face for strings."
 132   :group 'factor-faces)
 133
 134 (defface factor-font-lock-stack-effect (face-default-spec font-lock-comment-face)
 135   "Face for stack effect specifications."
 136   :group 'factor-faces)
 137
 138 (defface factor-font-lock-word-definition (face-default-spec font-lock-function-name-face)
 139   "Face for word, generic or method being defined."
 140   :group 'factor-faces)
 141
 142 (defface factor-font-lock-symbol-definition (face-default-spec font-lock-variable-name-face)
 143   "Face for name of symbol being defined."
 144   :group 'factor-faces)
 145
 146 (defface factor-font-lock-vocabulary-name (face-default-spec font-lock-constant-face)
 147   "Face for names of vocabularies in USE or USING."
 148   :group 'factor-faces)
 149
 150 (defface factor-font-lock-type-definition (face-default-spec font-lock-type-face)
 151   "Face for type (tuple) names."
 152   :group 'factor-faces)
 153
 154 (defface factor-font-lock-constructor (face-default-spec font-lock-type-face)
 155   "Face for constructors (<foo>)."
 156   :group 'factor-faces)
 157
 158 (defface factor-font-lock-setter-word (face-default-spec font-lock-function-name-face)
 159   "Face for setter words (>>foo)."
 160   :group 'factor-faces)
 161
 162 (defface factor-font-lock-parsing-word (face-default-spec font-lock-keyword-face)
 163   "Face for parsing words."
 164   :group 'factor-faces)
 165
 166 (defface factor-font-lock-help-mode-headlines '((t (:bold t :weight bold)))
 167   "Face for headlines in help buffers."
 168   :group 'factor-faces)
 169
 170 \f
 171 ;;; Compatibility
 172 (when (not (fboundp 'ring-member))
 173   (defun ring-member (ring item)
 174     (catch 'found
 175       (dotimes (ind (ring-length ring) nil)
 176         (when (equal item (ring-ref ring ind))
 177           (throw 'found ind))))))
 178
 179 \f
 180 ;;; Factor mode font lock:
 181
 182 (defconst factor--parsing-words
 183   '("{" "}" "^:" "^::" ";" "<<" "<PRIVATE" ">>"
 184     "BIN:" "BV{" "B{" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CS{" "C{"
 185     "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:"
 186     "GENERIC#" "GENERIC:" "HEX:" "HOOK:" "H{"
 187     "IN:" "INSTANCE:" "INTERSECTION:"
 188     "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "METHOD:" "MIXIN:"
 189     "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
 190     "REQUIRE:"  "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:"
 191     "TUPLE:" "T{" "t\\??" "TYPEDEF:"
 192     "UNION:" "USE:" "USING:" "V{" "VARS:" "W{"))
 193
 194 (defconst factor--regex-parsing-words-ext
 195   (regexp-opt '("B" "call-next-method" "delimiter" "f" "initial:" "read-only")
 196               'words))
 197
 198 (defconst factor--declaration-words
 199   '("flushable" "foldable" "inline" "parsing" "recursive"))
 200
 201 (defconst factor--regex-declaration-words
 202   (regexp-opt factor--declaration-words 'words))
 203
 204 (defsubst factor--regex-second-word (prefixes)
 205   (format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
 206
 207 (defconst factor--regex-method-definition
 208   "^M: +\\([^ ]+\\) +\\([^ ]+\\)")
 209
 210 (defconst factor--regex-word-definition
 211   (factor--regex-second-word '(":" "::" "GENERIC:")))
 212
 213 (defconst factor--regex-type-definition
 214   (factor--regex-second-word '("TUPLE:" "SINGLETON:")))
 215
 216 (defconst factor--regex-parent-type "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)")
 217
 218 (defconst factor--regex-constructor "<[^ >]+>")
 219
 220 (defconst factor--regex-setter "\\W>>[^ ]+\\b")
 221
 222 (defconst factor--regex-symbol-definition
 223   (factor--regex-second-word '("SYMBOL:" "VAR:")))
 224
 225 (defconst factor--regex-stack-effect " ( .* )")
 226
 227 (defconst factor--regex-using-lines "^USING: +\\(\\([^;]\\|[\n\r\f]\\)*\\);")
 228
 229 (defconst factor--regex-use-line "^USE: +\\(.*\\)$")
 230
 231 (defconst factor--font-lock-keywords
 232   `((,factor--regex-stack-effect . 'factor-font-lock-stack-effect)
 233     ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
 234     ,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
 235                              '(2 'factor-font-lock-parsing-word)))
 236               factor--parsing-words)
 237     (,factor--regex-parsing-words-ext . 'factor-font-lock-parsing-word)
 238     (,factor--regex-declaration-words 1 'factor-font-lock-declaration)
 239     (,factor--regex-word-definition 2 'factor-font-lock-word-definition)
 240     (,factor--regex-type-definition 2 'factor-font-lock-type-definition)
 241     (,factor--regex-method-definition (1 'factor-font-lock-type-definition)
 242                                       (2 'factor-font-lock-word-definition))
 243     (,factor--regex-parent-type 1 'factor-font-lock-type-definition)
 244     (,factor--regex-constructor . 'factor-font-lock-constructor)
 245     (,factor--regex-setter . 'factor-font-lock-setter-word)
 246     (,factor--regex-symbol-definition 2 'factor-font-lock-symbol-definition)
 247     (,factor--regex-use-line 1 'factor-font-lock-vocabulary-name))
 248   "Font lock keywords definition for Factor mode.")
 249
 250 \f
 251 ;;; Factor mode syntax:
 252
 253 (defconst factor--regex-definition-starters
 254   (regexp-opt '("VARS" "TUPLE" "MACRO" "MACRO:" "M" ":" "")))
 255
 256 (defconst factor--regex-definition-start
 257   (format "^\\(%s:\\) " factor--regex-definition-starters))
 258
 259 (defconst factor--regex-definition-end
 260   (format "\\(;\\( +%s\\)*\\)" factor--regex-declaration-words))
 261
 262 (defconst factor--font-lock-syntactic-keywords
 263   `(("\\(#!\\)" (1 "<"))
 264     (" \\(!\\)" (1 "<"))
 265     ("^\\(!\\)" (1 "<"))
 266     ("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))))
 267
 268 (defvar factor-mode-syntax-table nil
 269   "Syntax table used while in Factor mode.")
 270
 271 (if factor-mode-syntax-table
 272     ()
 273   (let ((i 0))
 274     (setq factor-mode-syntax-table (make-syntax-table))
 275
 276     ;; Default is atom-constituent
 277     (while (< i 256)
 278       (modify-syntax-entry i "_   " factor-mode-syntax-table)
 279       (setq i (1+ i)))
 280
 281     ;; Word components.
 282     (setq i ?0)
 283     (while (<= i ?9)
 284       (modify-syntax-entry i "w   " factor-mode-syntax-table)
 285       (setq i (1+ i)))
 286     (setq i ?A)
 287     (while (<= i ?Z)
 288       (modify-syntax-entry i "w   " factor-mode-syntax-table)
 289       (setq i (1+ i)))
 290     (setq i ?a)
 291     (while (<= i ?z)
 292       (modify-syntax-entry i "w   " factor-mode-syntax-table)
 293       (setq i (1+ i)))
 294
 295     ;; Whitespace
 296     (modify-syntax-entry ?\t " " factor-mode-syntax-table)
 297     (modify-syntax-entry ?\f " " factor-mode-syntax-table)
 298     (modify-syntax-entry ?\r " " factor-mode-syntax-table)
 299     (modify-syntax-entry ?  " " factor-mode-syntax-table)
 300
 301     ;; (end of) Comments
 302     (modify-syntax-entry ?\n ">" factor-mode-syntax-table)
 303
 304     ;; Parenthesis
 305     (modify-syntax-entry ?\[ "(]  " factor-mode-syntax-table)
 306     (modify-syntax-entry ?\] ")[  " factor-mode-syntax-table)
 307     (modify-syntax-entry ?{ "(}  " factor-mode-syntax-table)
 308     (modify-syntax-entry ?} "){  " factor-mode-syntax-table)
 309
 310     (modify-syntax-entry ?\( "()" factor-mode-syntax-table)
 311     (modify-syntax-entry ?\) ")(" factor-mode-syntax-table)
 312
 313     ;; Strings
 314     (modify-syntax-entry ?\" "\"" factor-mode-syntax-table)
 315     (modify-syntax-entry ?\\ "/" factor-mode-syntax-table)))
 316
 317 \f
 318 ;;; symbol-at-point
 319
 320 (defun factor--beginning-of-symbol ()
 321   "Move point to the beginning of the current symbol."
 322   (while (eq (char-before) ?:) (backward-char))
 323   (skip-syntax-backward "w_"))
 324
 325 (defun factor--end-of-symbol ()
 326   "Move point to the end of the current symbol."
 327   (skip-syntax-forward "w_")
 328   (while (looking-at ":") (forward-char)))
 329
 330 (put 'factor-symbol 'end-op 'factor--end-of-symbol)
 331 (put 'factor-symbol 'beginning-op 'factor--beginning-of-symbol)
 332
 333 (defsubst factor--symbol-at-point ()
 334   (let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
 335     (and (> (length s) 0) s)))
 336
 337 \f
 338 ;;; Factor mode indentation:
 339
 340 (make-variable-buffer-local
 341  (defvar factor-indent-width factor-default-indent-width
 342    "Indentation width in factor buffers. A local variable."))
 343
 344 (defun factor--guess-indent-width ()
 345   "Chooses an indentation value from existing code."
 346   (let ((word-cont "^ +[^ ]")
 347         (iw))
 348     (save-excursion
 349       (beginning-of-buffer)
 350       (while (not iw)
 351         (if (not (re-search-forward factor--regex-definition-start nil t))
 352             (setq iw factor-default-indent-width)
 353           (forward-line)
 354           (when (looking-at word-cont)
 355             (setq iw (current-indentation))))))
 356     iw))
 357
 358 (defsubst factor--ppss-brackets-depth ()
 359   (nth 0 (syntax-ppss)))
 360
 361 (defsubst factor--ppss-brackets-start ()
 362   (nth 1 (syntax-ppss)))
 363
 364 (defun factor--ppss-brackets-end ()
 365   (save-excursion
 366     (goto-char (factor--ppss-brackets-start))
 367     (condition-case nil
 368         (progn (forward-sexp)
 369                (1- (point)))
 370       (error -1))))
 371
 372 (defsubst factor--indentation-at (pos)
 373   (save-excursion (goto-char pos) (current-indentation)))
 374
 375 (defsubst factor--at-first-char-p ()
 376   (= (- (point) (line-beginning-position)) (current-indentation)))
 377
 378 (defconst factor--regex-single-liner
 379   (format "^%s" (regexp-opt '("DEFER:" "GENERIC:" "IN:"
 380                               "PRIVATE>" "<PRIVATE"
 381                               "SINGLETON:" "SYMBOL:" "USE:" "VAR:"))))
 382
 383 (defconst factor--regex-begin-of-def
 384   (format "^USING: \\|\\(%s\\)\\|\\(%s .*\\)"
 385           factor--regex-definition-start
 386           factor--regex-single-liner))
 387
 388 (defconst factor--regex-end-of-def-line
 389   (format "^.*%s" factor--regex-definition-end))
 390
 391 (defconst factor--regex-end-of-def
 392   (format "\\(%s\\)\\|\\(%s .*\\)"
 393           factor--regex-end-of-def-line
 394           factor--regex-single-liner))
 395
 396 (defsubst factor--at-begin-of-def ()
 397   (looking-at factor--regex-begin-of-def))
 398
 399 (defsubst factor--at-end-of-def ()
 400   (looking-at factor--regex-end-of-def))
 401
 402 (defsubst factor--looking-at-emptiness ()
 403   (looking-at "^[ \t]*$"))
 404
 405 (defun factor--at-setter-line ()
 406   (save-excursion
 407     (beginning-of-line)
 408     (if (not (factor--looking-at-emptiness))
 409         (re-search-forward factor--regex-setter (line-end-position) t)
 410       (forward-line -1)
 411       (or (factor--at-constructor-line)
 412           (factor--at-setter-line)))))
 413
 414 (defun factor--at-constructor-line ()
 415   (save-excursion
 416     (beginning-of-line)
 417     (re-search-forward factor--regex-constructor (line-end-position) t)))
 418
 419 (defsubst factor--increased-indentation (&optional i)
 420   (+ (or i (current-indentation)) factor-indent-width))
 421 (defsubst factor--decreased-indentation (&optional i)
 422   (- (or i (current-indentation)) factor-indent-width))
 423
 424 (defun factor--indent-in-brackets ()
 425   (save-excursion
 426     (beginning-of-line)
 427     (when (> (factor--ppss-brackets-depth) 0)
 428       (let ((op (factor--ppss-brackets-start))
 429             (cl (factor--ppss-brackets-end))
 430             (ln (line-number-at-pos)))
 431         (when (> ln (line-number-at-pos op))
 432           (if (and (> cl 0) (= ln (line-number-at-pos cl)))
 433               (factor--indentation-at op)
 434             (factor--increased-indentation (factor--indentation-at op))))))))
 435
 436 (defun factor--indent-definition ()
 437   (save-excursion
 438     (beginning-of-line)
 439     (when (factor--at-begin-of-def) 0)))
 440
 441 (defun factor--indent-setter-line ()
 442   (when (factor--at-setter-line)
 443     (save-excursion
 444       (let ((indent (and (factor--at-constructor-line) (current-indentation))))
 445         (while (not (or indent
 446                         (bobp)
 447                         (factor--at-begin-of-def)
 448                         (factor--at-end-of-def)))
 449           (if (factor--at-constructor-line)
 450               (setq indent (factor--increased-indentation))
 451             (forward-line -1)))
 452         indent))))
 453
 454 (defun factor--indent-continuation ()
 455   (save-excursion
 456     (forward-line -1)
 457     (while (and (not (bobp)) (factor--looking-at-emptiness))
 458       (forward-line -1))
 459     (if (or (factor--at-end-of-def) (factor--at-setter-line))
 460         (factor--decreased-indentation)
 461       (if (and (factor--at-begin-of-def)
 462                (not (looking-at factor--regex-using-lines)))
 463           (factor--increased-indentation)
 464         (current-indentation)))))
 465
 466 (defun factor--calculate-indentation ()
 467   "Calculate Factor indentation for line at point."
 468   (or (and (bobp) 0)
 469       (factor--indent-definition)
 470       (factor--indent-in-brackets)
 471       (factor--indent-setter-line)
 472       (factor--indent-continuation)
 473       0))
 474
 475 (defun factor--indent-line ()
 476   "Indent current line as Factor code"
 477   (let ((target (factor--calculate-indentation))
 478         (pos (- (point-max) (point))))
 479     (if (= target (current-indentation))
 480         (if (< (current-column) (current-indentation))
 481             (back-to-indentation))
 482       (beginning-of-line)
 483       (delete-horizontal-space)
 484       (indent-to target)
 485       (if (> (- (point-max) pos) (point))
 486           (goto-char (- (point-max) pos))))))
 487
 488 \f
 489 ;; Factor mode:
 490 (defvar factor-mode-map (make-sparse-keymap)
 491   "Key map used by Factor mode.")
 492
 493 (defsubst factor--beginning-of-defun (&optional times)
 494   (re-search-backward factor--regex-begin-of-def nil t times))
 495
 496 (defsubst factor--end-of-defun ()
 497   (re-search-forward factor--regex-end-of-def nil t))
 498
 499 ;;;###autoload
 500 (defun factor-mode ()
 501   "A mode for editing programs written in the Factor programming language.
 502 \\{factor-mode-map}"
 503   (interactive)
 504   (kill-all-local-variables)
 505   (use-local-map factor-mode-map)
 506   (setq major-mode 'factor-mode)
 507   (setq mode-name "Factor")
 508   ;; Font locking
 509   (set (make-local-variable 'comment-start) "! ")
 510   (set (make-local-variable 'parse-sexp-lookup-properties) t)
 511   (set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
 512   (set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
 513   (set (make-local-variable 'font-lock-defaults)
 514        `(factor--font-lock-keywords
 515          nil nil nil nil
 516          (font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
 517
 518   (set-syntax-table factor-mode-syntax-table)
 519   ;; Defun navigation
 520   (set (make-local-variable 'beginning-of-defun-function) 'factor--beginning-of-defun)
 521   (set (make-local-variable 'end-of-defun-function) 'factor--end-of-defun)
 522   (set (make-local-variable 'open-paren-in-column-0-is-defun-start) nil)
 523   ;; Indentation
 524   (set (make-local-variable 'indent-line-function) 'factor--indent-line)
 525   (setq factor-indent-width (factor--guess-indent-width))
 526   (setq indent-tabs-mode nil)
 527   ;; ElDoc
 528   (set (make-local-variable 'eldoc-documentation-function) 'factor--eldoc)
 529
 530   (run-hooks 'factor-mode-hook))
 531
 532 (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
 533
 534 \f
 535 ;;; Factor listener mode:
 536
 537 ;;;###autoload
 538 (define-derived-mode factor-listener-mode comint-mode "Factor Listener"
 539   "Major mode for interacting with an inferior Factor listener process.
 540 \\{factor-listener-mode-map}"
 541   (set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
 542
 543 (defvar factor--listener-buffer nil
 544   "The buffer in which the Factor listener is running.")
 545
 546 (defun factor--listener-start-process ()
 547   "Start an inferior Factor listener process, using
 548 `factor-binary' and `factor-image'."
 549   (setq factor--listener-buffer
 550         (apply 'make-comint "factor" (expand-file-name factor-binary) nil
 551                `("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
 552   (with-current-buffer factor--listener-buffer
 553     (factor-listener-mode)))
 554
 555 (defun factor--listener-process (&optional start)
 556   (or (and (buffer-live-p factor--listener-buffer)
 557            (get-buffer-process factor--listener-buffer))
 558       (if (not start)
 559           (error "No running factor listener. Try M-x run-factor.")
 560         (factor--listener-start-process)
 561         (factor--listener-process t))))
 562
 563 ;;;###autoload
 564 (defalias 'switch-to-factor 'run-factor)
 565 ;;;###autoload
 566 (defun run-factor (&optional arg)
 567   "Show the factor-listener buffer, starting the process if needed."
 568   (interactive)
 569   (let ((buf (process-buffer (factor--listener-process t)))
 570         (pop-up-windows factor-listener-window-allow-split))
 571     (if factor-listener-use-other-window
 572         (pop-to-buffer buf)
 573       (switch-to-buffer buf))))
 574
 575 (defun factor-telnet-to-port (port)
 576   (interactive "nPort: ")
 577   (switch-to-buffer
 578    (make-comint-in-buffer "factor-telnet" nil (cons "localhost" port))))
 579
 580 (defun factor-telnet ()
 581   (interactive)
 582   (factor-telnet-to-port 9000))
 583
 584 (defun factor-telnet-factory ()
 585   (interactive)
 586   (factor-telnet-to-port 9010))
 587
 588 \f
 589 ;;; Factor listener interaction:
 590
 591 (defun factor--listener-send-cmd (cmd)
 592   (let ((proc (factor--listener-process)))
 593     (when proc
 594       (let* ((out (get-buffer-create "*factor messages*"))
 595              (beg (with-current-buffer out (goto-char (point-max)))))
 596         (comint-redirect-send-command-to-process cmd out proc nil t)
 597         (with-current-buffer factor--listener-buffer
 598           (while (not comint-redirect-completed) (sleep-for 0 1)))
 599         (with-current-buffer out
 600           (split-string (buffer-substring-no-properties beg (point-max))
 601                         "[\"\f\n\r\v]+" t))))))
 602
 603 ;;;;; Current vocabulary:
 604 (make-variable-buffer-local
 605  (defvar factor--current-vocab nil
 606    "Current vocabulary."))
 607
 608 (defconst factor--regexp-current-vocab "^IN: +\\([^ \r\n\f]+\\)")
 609
 610 (defun factor--current-buffer-vocab ()
 611   (save-excursion
 612     (when (or (re-search-backward factor--regexp-current-vocab nil t)
 613               (re-search-forward factor--regexp-current-vocab nil t))
 614       (setq factor--current-vocab (match-string-no-properties 1)))))
 615
 616 (defun factor--current-listener-vocab ()
 617   (car (factor--listener-send-cmd "USING: parser ; in get .")))
 618
 619 (defun factor--set-current-listener-vocab (&optional vocab)
 620   (factor--listener-send-cmd
 621    (format "IN: %s" (or vocab (factor--current-buffer-vocab))))
 622   t)
 623
 624 (defmacro factor--with-vocab (vocab &rest body)
 625   (let ((current (make-symbol "current")))
 626     `(let ((,current (factor--current-listener-vocab)))
 627        (factor--set-current-listener-vocab ,vocab)
 628        (prog1 (condition-case nil (progn . ,body) (error nil))
 629          (factor--set-current-listener-vocab ,current)))))
 630
 631 (put 'factor--with-vocab 'lisp-indent-function 1)
 632
 633 ;;;;; Synchronous interaction:
 634
 635 (defsubst factor--listener-vocab-cmds (cmds &optional vocab)
 636   (factor--with-vocab vocab
 637     (mapcar #'factor--listener-send-cmd cmds)))
 638
 639 (defsubst factor--listener-vocab-cmd (cmd &optional vocab)
 640   (factor--with-vocab vocab
 641     (factor--listener-send-cmd cmd)))
 642
 643 \f
 644 ;;;;; Buffer cycling and docs
 645
 646
 647 (defconst factor--cycle-endings
 648   '(".factor" "-tests.factor" "-docs.factor"))
 649
 650 (defconst factor--regex-cycle-endings
 651   (format "\\(.*?\\)\\(%s\\)$"
 652           (regexp-opt factor--cycle-endings)))
 653
 654 (defconst factor--cycle-endings-ring
 655   (let ((ring (make-ring (length factor--cycle-endings))))
 656     (dolist (e factor--cycle-endings ring)
 657       (ring-insert ring e))))
 658
 659 (defun factor--cycle-next (file)
 660   (let* ((match (string-match factor--regex-cycle-endings file))
 661          (base (and match (match-string-no-properties 1 file)))
 662          (ending (and match (match-string-no-properties 2 file)))
 663          (idx (and ending (ring-member factor--cycle-endings-ring ending)))
 664          (gfl (lambda (i) (concat base (ring-ref factor--cycle-endings-ring i)))))
 665     (if (not idx) file
 666       (let ((l (length factor--cycle-endings)) (i 1) next)
 667         (while (and (not next) (< i l))
 668           (when (file-exists-p (funcall gfl (+ idx i)))
 669             (setq next (+ idx i)))
 670           (setq i (1+ i)))
 671         (funcall gfl (or next idx))))))
 672
 673 (defun factor-visit-other-file (&optional file)
 674   "Cycle between code, tests and docs factor files."
 675   (interactive)
 676   (find-file (factor--cycle-next (or file (buffer-file-name)))))
 677
 678 \f
 679 ;;;;; Interface: See
 680
 681 (defconst factor--regex-error-marker "^Type :help for debugging")
 682 (defconst factor--regex-data-stack "^--- Data stack:")
 683
 684 (defun factor--prune-ans-strings (ans)
 685   (nreverse
 686    (catch 'done
 687      (let ((res))
 688        (dolist (a ans res)
 689          (cond ((string-match factor--regex-stack-effect a)
 690                 (throw 'done (cons a res)))
 691                ((string-match factor--regex-data-stack a)
 692                 (throw 'done res))
 693                ((string-match factor--regex-error-marker a)
 694                 (throw 'done nil))
 695                (t (push a res))))))))
 696
 697 (defun factor--see-ans-to-string (ans)
 698   (let ((s (mapconcat #'identity (factor--prune-ans-strings ans) " "))
 699         (font-lock-verbose nil))
 700     (and (> (length s) 0)
 701          (with-temp-buffer
 702            (insert s)
 703            (factor-mode)
 704            (font-lock-fontify-buffer)
 705            (buffer-string)))))
 706
 707 (defun factor--see-current-word (&optional word)
 708   (let ((word (or word (factor--symbol-at-point))))
 709     (when word
 710       (let ((answer (factor--listener-send-cmd (format "\\ %s see" word))))
 711         (and answer (factor--see-ans-to-string answer))))))
 712
 713 (defalias 'factor--eldoc 'factor--see-current-word)
 714
 715 (defun factor-see-current-word (&optional word)
 716   "Echo in the minibuffer information about word at point."
 717   (interactive)
 718   (let* ((proc (factor--listener-process))
 719          (word (or word (factor--symbol-at-point)))
 720          (msg (factor--see-current-word word)))
 721     (if msg (message "%s" msg)
 722       (if word (message "No help found for '%s'" word)
 723         (message "No word at point")))))
 724
 725 ;;; to fix:
 726 (defun factor-run-file ()
 727   (interactive)
 728   (when (and (buffer-modified-p)
 729              (y-or-n-p (format "Save file %s? " (buffer-file-name))))
 730     (save-buffer))
 731   (when factor-display-compilation-output
 732     (factor-display-output-buffer))
 733   (comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name)))
 734   (comint-send-string "*factor*" " run-file\n"))
 735
 736 (defun factor-display-output-buffer ()
 737   (with-current-buffer "*factor*"
 738     (goto-char (point-max))
 739     (unless (get-buffer-window (current-buffer) t)
 740       (display-buffer (current-buffer) t))))
 741
 742 (defun factor-send-string (str)
 743   (let ((n (length (split-string str "\n"))))
 744     (save-excursion
 745       (set-buffer "*factor*")
 746       (goto-char (point-max))
 747       (if (> n 1) (newline))
 748       (insert str)
 749       (comint-send-input))))
 750
 751 (defun factor-send-region (start end)
 752   (interactive "r")
 753   (let ((str (buffer-substring start end))
 754         (n   (count-lines      start end)))
 755     (save-excursion
 756       (set-buffer "*factor*")
 757       (goto-char (point-max))
 758       (if (> n 1) (newline))
 759       (insert str)
 760       (comint-send-input))))
 761
 762 (defun factor-send-definition ()
 763   (interactive)
 764   (factor-send-region (search-backward ":")
 765                       (search-forward  ";")))
 766
 767 (defun factor-edit ()
 768   (interactive)
 769   (comint-send-string "*factor*" "\\ ")
 770   (comint-send-string "*factor*" (thing-at-point 'sexp))
 771   (comint-send-string "*factor*" " edit\n"))
 772
 773 (defun factor-clear ()
 774   (interactive)
 775   (factor-send-string "clear"))
 776
 777 (defun factor-comment-line ()
 778   (interactive)
 779   (beginning-of-line)
 780   (insert "! "))
 781
 782 \f
 783 ;;;; Factor help mode:
 784
 785 (defvar factor-help-mode-map (make-sparse-keymap)
 786   "Keymap for Factor help mode.")
 787
 788 (defconst factor--help-headlines
 789   (regexp-opt '("Definition"
 790                 "Examples"
 791                 "Generic word contract"
 792                 "Inputs and outputs"
 793                 "Parent topics:"
 794                 "See also"
 795                 "Syntax"
 796                 "Vocabulary"
 797                 "Warning"
 798                 "Word description")
 799               t))
 800
 801 (defconst factor--help-headlines-regexp (format "^%s" factor--help-headlines))
 802
 803 (defconst factor--help-font-lock-keywords
 804   `((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines)
 805     ,@factor--font-lock-keywords))
 806
 807 (defun factor-help-mode ()
 808   "Major mode for displaying Factor help messages.
 809 \\{factor-help-mode-map}"
 810   (interactive)
 811   (kill-all-local-variables)
 812   (use-local-map factor-help-mode-map)
 813   (setq mode-name "Factor Help")
 814   (setq major-mode 'factor-help-mode)
 815   (set (make-local-variable 'font-lock-defaults)
 816        '(factor--help-font-lock-keywords t nil nil nil))
 817   (set (make-local-variable 'comint-redirect-subvert-readonly) t)
 818   (set (make-local-variable 'comint-redirect-echo-input) nil)
 819   (set (make-local-variable 'view-no-disable-on-exit) t)
 820   (view-mode)
 821   (setq view-exit-action
 822         (lambda (buffer)
 823           ;; Use `with-current-buffer' to make sure that `bury-buffer'
 824           ;; also removes BUFFER from the selected window.
 825           (with-current-buffer buffer
 826             (bury-buffer))))
 827   (run-mode-hooks 'factor-help-mode-hook))
 828
 829 (defun factor--listener-help-buffer ()
 830   (with-current-buffer (get-buffer-create "*factor-help*")
 831     (let ((inhibit-read-only t)) (erase-buffer))
 832     (factor-help-mode)
 833     (current-buffer)))
 834
 835 (defvar factor--help-history nil)
 836
 837 (defun factor--listener-show-help (&optional see)
 838   (let* ((proc (factor--listener-process))
 839          (def (factor--symbol-at-point))
 840          (prompt (format "See%s help on%s: " (if see " short" "")
 841                          (if def (format " (%s)" def) "")))
 842          (ask (or (not (eq major-mode 'factor-mode))
 843                   (not def)
 844                   factor-help-always-ask))
 845          (cmd (format "\\ %s %s"
 846                       (if ask (read-string prompt nil 'factor--help-history def) def)
 847                       (if see "see" "help")))
 848          (hb (factor--listener-help-buffer)))
 849     (comint-redirect-send-command-to-process cmd hb proc nil)
 850     (pop-to-buffer hb)
 851     (beginning-of-buffer hb)))
 852
 853 ;;;; Interface: see/help commands
 854
 855 (defun factor-see (&optional arg)
 856   "See a help summary of symbol at point.
 857 By default, the information is shown in the minibuffer. When
 858 called with a prefix argument, the information is displayed in a
 859 separate help buffer."
 860   (interactive "P")
 861   (if (if factor-help-use-minibuffer (not arg) arg)
 862       (factor-see-current-word)
 863     (factor--listener-show-help t)))
 864
 865 (defun factor-help ()
 866   "Show extended help about the symbol at point, using a help
 867 buffer."
 868   (interactive)
 869   (factor--listener-show-help))
 870
 871 \f
 872
 873 (defun factor-refresh-all ()
 874   "Reload source files and documentation for all loaded
 875 vocabularies which have been modified on disk."
 876   (interactive)
 877   (comint-send-string "*factor*" "refresh-all\n"))
 878
 879 \f
 880 ;;; Key bindings:
 881
 882 (defun factor--define-key (key cmd &optional both)
 883   (let ((ms (list factor-mode-map)))
 884     (when both (push factor-help-mode-map ms))
 885     (dolist (m ms)
 886       (define-key m (vector '(control ?c) key) cmd)
 887       (define-key m (vector '(control ?c) `(control ,key)) cmd))))
 888
 889 (defun factor--define-auto-indent-key (key)
 890   (define-key factor-mode-map (vector key)
 891     (lambda (n)
 892       (interactive "p")
 893       (self-insert-command n)
 894       (indent-for-tab-command))))
 895
 896 (factor--define-key ?f 'factor-run-file)
 897 (factor--define-key ?r 'factor-send-region)
 898 (factor--define-key ?d 'factor-send-definition)
 899 (factor--define-key ?s 'factor-see t)
 900 (factor--define-key ?e 'factor-edit)
 901 (factor--define-key ?z 'switch-to-factor t)
 902 (factor--define-key ?o 'factor-visit-other-file)
 903 (factor--define-key ?c 'comment-region)
 904
 905 (factor--define-auto-indent-key ?\])
 906 (factor--define-auto-indent-key ?\})
 907
 908 (define-key factor-mode-map "\C-ch" 'factor-help)
 909 (define-key factor-help-mode-map "\C-ch" 'factor-help)
 910 (define-key factor-mode-map "\C-m" 'newline-and-indent)
 911
 912 (define-key factor-listener-mode-map [f8] 'factor-refresh-all)
 913
 914
 915 \f
 916 (provide 'factor)
 917 ;;; factor.el ends here