FUEL: First stab at the debugger: error/restart display and restart invokation.
Jose A. Ortega Ruiz
parent
90cdb6c4f4
commit
faa6989fe9
|
|
@ -1,50 +1,70 @@
|
|||
! Copyright (C) 2008 Jose Antonio Ortega Ruiz.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
USING: accessors arrays classes.tuple compiler.units continuations debugger
|
||||
definitions eval io io.files io.streams.string kernel listener listener.private
|
||||
make math namespaces parser prettyprint quotations sequences strings
|
||||
vectors vocabs.loader ;
|
||||
USING: accessors arrays classes classes.tuple compiler.units
|
||||
combinators continuations debugger definitions eval help
|
||||
io io.files io.streams.string kernel lexer listener listener.private
|
||||
make math namespaces parser prettyprint prettyprint.config
|
||||
quotations sequences strings source-files vectors vocabs.loader ;
|
||||
|
||||
IN: fuel
|
||||
|
||||
! <PRIVATE
|
||||
! Evaluation status:
|
||||
|
||||
TUPLE: fuel-status in use ds? ;
|
||||
TUPLE: fuel-status in use ds? restarts ;
|
||||
|
||||
SYMBOL: fuel-status-stack
|
||||
V{ } clone fuel-status-stack set-global
|
||||
|
||||
: push-fuel-status ( -- )
|
||||
in get use get clone display-stacks? get
|
||||
fuel-status boa
|
||||
fuel-status-stack get push ;
|
||||
|
||||
: pop-fuel-status ( -- )
|
||||
fuel-status-stack get empty? [
|
||||
fuel-status-stack get pop
|
||||
[ in>> in set ]
|
||||
[ use>> clone use set ]
|
||||
[ ds?>> display-stacks? swap [ on ] [ off ] if ] tri
|
||||
] unless ;
|
||||
|
||||
SYMBOL: fuel-eval-result
|
||||
f clone fuel-eval-result set-global
|
||||
|
||||
SYMBOL: fuel-eval-output
|
||||
f clone fuel-eval-result set-global
|
||||
|
||||
! PRIVATE>
|
||||
SYMBOL: fuel-eval-res-flag
|
||||
t clone fuel-eval-res-flag set-global
|
||||
|
||||
: fuel-eval-restartable? ( -- ? )
|
||||
fuel-eval-res-flag get-global ; inline
|
||||
|
||||
: fuel-eval-restartable ( -- )
|
||||
t fuel-eval-res-flag set-global ; inline
|
||||
|
||||
: fuel-eval-non-restartable ( -- )
|
||||
f fuel-eval-res-flag set-global ; inline
|
||||
|
||||
: push-fuel-status ( -- )
|
||||
in get use get clone display-stacks? get restarts get-global clone
|
||||
fuel-status boa
|
||||
fuel-status-stack get push ;
|
||||
|
||||
: pop-fuel-status ( -- )
|
||||
fuel-status-stack get empty? [
|
||||
fuel-status-stack get pop {
|
||||
[ in>> in set ]
|
||||
[ use>> clone use set ]
|
||||
[ ds?>> display-stacks? swap [ on ] [ off ] if ]
|
||||
[
|
||||
restarts>> fuel-eval-restartable? [ drop ] [
|
||||
clone restarts set-global
|
||||
] if
|
||||
]
|
||||
} cleave
|
||||
] unless ;
|
||||
|
||||
|
||||
! Lispy pretty printing
|
||||
|
||||
GENERIC: fuel-pprint ( obj -- )
|
||||
|
||||
M: object fuel-pprint pprint ;
|
||||
M: object fuel-pprint pprint ; inline
|
||||
|
||||
M: f fuel-pprint drop "nil" write ;
|
||||
M: f fuel-pprint drop "nil" write ; inline
|
||||
|
||||
M: integer fuel-pprint pprint ;
|
||||
M: integer fuel-pprint pprint ; inline
|
||||
|
||||
M: string fuel-pprint pprint ;
|
||||
M: string fuel-pprint pprint ; inline
|
||||
|
||||
M: sequence fuel-pprint
|
||||
dup empty? [ drop f fuel-pprint ] [
|
||||
|
|
@ -53,12 +73,30 @@ M: sequence fuel-pprint
|
|||
")" write
|
||||
] if ;
|
||||
|
||||
M: tuple fuel-pprint tuple>array fuel-pprint ;
|
||||
M: tuple fuel-pprint tuple>array fuel-pprint ; inline
|
||||
|
||||
M: continuation fuel-pprint drop "~continuation~" write ;
|
||||
M: continuation fuel-pprint drop ":continuation" write ; inline
|
||||
|
||||
M: restart fuel-pprint name>> fuel-pprint ; inline
|
||||
|
||||
SYMBOL: :restarts
|
||||
|
||||
: fuel-restarts ( obj -- seq )
|
||||
compute-restarts :restarts prefix ; inline
|
||||
|
||||
M: condition fuel-pprint
|
||||
[ error>> ] [ fuel-restarts ] bi 2array condition prefix fuel-pprint ;
|
||||
|
||||
M: source-file-error fuel-pprint
|
||||
[ file>> ] [ error>> ] bi 2array source-file-error prefix
|
||||
fuel-pprint ;
|
||||
|
||||
M: source-file fuel-pprint path>> fuel-pprint ;
|
||||
|
||||
! Evaluation vocabulary
|
||||
|
||||
: fuel-eval-set-result ( obj -- )
|
||||
clone fuel-eval-result set-global ;
|
||||
clone fuel-eval-result set-global ; inline
|
||||
|
||||
: fuel-retort ( -- )
|
||||
error get
|
||||
|
|
@ -67,7 +105,7 @@ M: continuation fuel-pprint drop "~continuation~" write ;
|
|||
3array fuel-pprint ;
|
||||
|
||||
: fuel-forget-error ( -- )
|
||||
f error set-global ;
|
||||
f error set-global ; inline
|
||||
|
||||
: (fuel-begin-eval) ( -- )
|
||||
push-fuel-status
|
||||
|
|
@ -76,23 +114,25 @@ M: continuation fuel-pprint drop "~continuation~" write ;
|
|||
f fuel-eval-result set-global
|
||||
f fuel-eval-output set-global ;
|
||||
|
||||
: fuel-run-with-output ( quot -- )
|
||||
with-string-writer fuel-eval-output set-global ; inline
|
||||
|
||||
: (fuel-end-eval) ( quot -- )
|
||||
with-string-writer fuel-eval-output set-global
|
||||
fuel-retort
|
||||
pop-fuel-status ;
|
||||
fuel-run-with-output fuel-retort pop-fuel-status ; inline
|
||||
|
||||
: (fuel-eval) ( lines -- )
|
||||
[ [ parse-lines ] with-compilation-unit call ] curry [ drop ] recover ;
|
||||
[ [ parse-lines ] with-compilation-unit call ] curry
|
||||
[ print-error ] recover ; inline
|
||||
|
||||
: (fuel-eval-each) ( lines -- )
|
||||
[ 1vector (fuel-eval) ] each ;
|
||||
[ 1vector (fuel-eval) ] each ; inline
|
||||
|
||||
: (fuel-eval-usings) ( usings -- )
|
||||
[ "USING: " prepend " ;" append ] map
|
||||
(fuel-eval-each) fuel-forget-error ;
|
||||
|
||||
: (fuel-eval-in) ( in -- )
|
||||
[ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ;
|
||||
[ dup "IN: " prepend 1vector (fuel-eval) in set ] when* ; inline
|
||||
|
||||
: fuel-eval-in-context ( lines in usings -- )
|
||||
(fuel-begin-eval) [
|
||||
|
|
@ -107,15 +147,15 @@ M: continuation fuel-pprint drop "~continuation~" write ;
|
|||
fuel-retort ;
|
||||
|
||||
: fuel-eval ( lines -- )
|
||||
(fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ;
|
||||
(fuel-begin-eval) [ (fuel-eval) ] (fuel-end-eval) ; inline
|
||||
|
||||
: fuel-end-eval ( -- )
|
||||
[ ] (fuel-end-eval) ;
|
||||
: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
|
||||
|
||||
: fuel-get-edit-location ( defspec -- )
|
||||
where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ] when* ;
|
||||
|
||||
: fuel-startup ( -- )
|
||||
"listener" run ;
|
||||
: fuel-run-file ( path -- ) run-file ; inline
|
||||
|
||||
: fuel-startup ( -- ) "listener" run ; inline
|
||||
|
||||
MAIN: fuel-startup
|
||||
|
|
|
|||
|
|
@ -47,18 +47,29 @@ M-x customize-group fuel will show you how many.
|
|||
Quick key reference
|
||||
-------------------
|
||||
|
||||
(Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
|
||||
the same as C-cz)).
|
||||
|
||||
* In factor files:
|
||||
|
||||
- C-cz : switch to listener
|
||||
- C-co : cycle between code, tests and docs factor files
|
||||
|
||||
- M-. : edit word at point in Emacs
|
||||
- M-. : edit word at point in Emacs (also in listener)
|
||||
|
||||
- C-cr, C-cC-er : eval region
|
||||
- C-M-r, C-cC-ee : eval region, extending it to definition boundaries
|
||||
- C-M-x, C-cC-ex : eval definition around point
|
||||
- C-ck, C-cC-ek : compile file
|
||||
|
||||
- C-cC-da : toggle autodoc mode
|
||||
- C-cC-dd : help for word at point
|
||||
- C-cC-ds : short help word at point
|
||||
|
||||
Chords ending in a single letter <x> accept also C-<x> (e.g. C-cC-z is
|
||||
the same as C-cz).
|
||||
* In the debugger (it pops up upon eval/compilation errors):
|
||||
|
||||
- g : go to error
|
||||
- <digit> : invoke nth restart
|
||||
- q : bury buffer
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -59,6 +59,23 @@ code in the buffer."
|
|||
:type 'hook
|
||||
:group 'factor-mode)
|
||||
|
||||
|
||||
;;; Faces:
|
||||
|
||||
(fuel-font-lock--define-faces
|
||||
factor-font-lock font-lock factor-mode
|
||||
((comment comment "comments")
|
||||
(constructor type "constructors (<foo>)")
|
||||
(declaration keyword "declaration words")
|
||||
(parsing-word keyword "parsing words")
|
||||
(setter-word function-name "setter words (>>foo)")
|
||||
(stack-effect comment "stack effect specifications")
|
||||
(string string "strings")
|
||||
(symbol variable-name "name of symbol being defined")
|
||||
(type-name type "type names")
|
||||
(vocabulary-name constant "vocabulary names")
|
||||
(word function-name "word, generic or method being defined")))
|
||||
|
||||
|
||||
;;; Syntax table:
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,234 @@
|
|||
;;; fuel-debug.el -- debugging factor code
|
||||
|
||||
;; Copyright (C) 2008 Jose Antonio Ortega Ruiz
|
||||
;; See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
|
||||
;; Keywords: languages, fuel, factor
|
||||
;; Start date: Sun Dec 07, 2008 04:16
|
||||
|
||||
;;; Comentary:
|
||||
|
||||
;; A mode for displaying the results of run-file and evaluation, with
|
||||
;; support for restarts.
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'fuel-base)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-font-lock)
|
||||
|
||||
|
||||
;;; Customization:
|
||||
|
||||
(defgroup fuel-debug nil
|
||||
"Major mode for interaction with the Factor debugger"
|
||||
:group 'fuel)
|
||||
|
||||
(defcustom fuel-debug-mode-hook nil
|
||||
"Hook run after `fuel-debug-mode' activates"
|
||||
:group 'fuel-debug
|
||||
:type 'hook)
|
||||
|
||||
(defcustom fuel-debug-show-short-help t
|
||||
"Whether to show short help on available keys in debugger"
|
||||
:group 'fuel-debug
|
||||
:type 'boolean)
|
||||
|
||||
(fuel-font-lock--define-faces
|
||||
fuel-debug-font-lock font-lock fuel-debug
|
||||
((error warning "highlighting errors")
|
||||
(line variable-name "line numbers in errors/warnings")
|
||||
(column variable-name "column numbers in errors/warnings")
|
||||
(info comment "information headers")
|
||||
(restart-number warning "restart numbers")
|
||||
(restart-name function-name "restart names")))
|
||||
|
||||
|
||||
;;; Compilation results buffer:
|
||||
|
||||
(defvar fuel-debug--buffer nil)
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--last-ret nil))
|
||||
|
||||
(make-variable-buffer-local
|
||||
(defvar fuel-debug--file nil))
|
||||
|
||||
(defun fuel-debug--buffer ()
|
||||
(or (and (buffer-live-p fuel-debug--buffer) fuel-debug--buffer)
|
||||
(with-current-buffer
|
||||
(setq fuel-debug--buffer (get-buffer-create "*fuel dbg*"))
|
||||
(fuel-debug-mode)
|
||||
(current-buffer))))
|
||||
|
||||
(defun fuel-debug--display-retort (ret &optional success-msg no-pop file)
|
||||
(let ((err (fuel-eval--retort-error ret))
|
||||
(inhibit-read-only t))
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
(erase-buffer)
|
||||
(when err (insert (format "Error: %S\n\n" (fuel-eval--error-name err))))
|
||||
(fuel-debug--display-output-1 ret)
|
||||
(when (and (not err) success-msg)
|
||||
(message "%s" success-msg)
|
||||
(insert "\n" success-msg "\n"))
|
||||
(when err
|
||||
(fuel-debug--display-restarts err)
|
||||
(let ((hstr (fuel-debug--help-string err)))
|
||||
(if fuel-debug-show-short-help
|
||||
(insert "-----------\n" hstr "\n")
|
||||
(message "%s" hstr))))
|
||||
(setq fuel-debug--last-ret ret)
|
||||
(setq fuel-debug--file file)
|
||||
(goto-char (point-max)))
|
||||
(when (and err (not no-pop)) (pop-to-buffer fuel-debug--buffer))))
|
||||
|
||||
(defun fuel-debug--display-output-1 (ret)
|
||||
(let* ((last (fuel-eval--retort-output fuel-debug--last-ret))
|
||||
(current (fuel-eval--retort-output ret))
|
||||
(llen (length last))
|
||||
(clen (length current))
|
||||
(trail (and last (substring-no-properties last (/ llen 2))))
|
||||
(p (point)))
|
||||
(save-excursion (insert current))
|
||||
(when (and (> clen llen) (> llen 0) (search-forward trail nil t))
|
||||
(delete-region p (point)))
|
||||
(goto-char (point-max))))
|
||||
|
||||
(defun fuel-debug--display-restarts (err)
|
||||
(let* ((rs (fuel-eval--error-restarts err))
|
||||
(rsn (length rs)))
|
||||
(when rs
|
||||
(insert "\n\nRestarts:\n\n")
|
||||
(dotimes (n rsn)
|
||||
(insert (format ":%s %s\n" (1+ n) (nth n rs))))
|
||||
(newline))))
|
||||
|
||||
(defun fuel-debug--help-string (err)
|
||||
(format "Press %s%s 'q' to bury buffer"
|
||||
(if (fuel-eval--error-file err) "g to visit file, " "")
|
||||
(let ((rsn (length (fuel-eval--error-restarts err))))
|
||||
(cond ((zerop rsn) "")
|
||||
((= 1 rsn) "1 to invoke restart, ")
|
||||
(t (format "1-%s to invoke restarts, " rsn))))))
|
||||
|
||||
(defun fuel-debug--buffer-file ()
|
||||
(with-current-buffer (fuel-debug--buffer)
|
||||
(or fuel-debug--file
|
||||
(and fuel-debug--last-ret
|
||||
(fuel-eval--error-file
|
||||
(fuel-eval--retort-error fuel-debug--last-ret))))))
|
||||
|
||||
(defsubst fuel-debug--buffer-error ()
|
||||
(fuel-eval--retort-error fuel-debug--last-ret))
|
||||
|
||||
(defsubst fuel-debug--buffer-restarts ()
|
||||
(fuel-eval--error-restarts (fuel-debug--buffer-error)))
|
||||
|
||||
|
||||
;;; Font lock and other pattern matching:
|
||||
|
||||
(defconst fuel-debug--error-file-regex "^P\" \\([^\"]+\\)\"")
|
||||
(defconst fuel-debug--error-line-regex "\\([0-9]+\\):")
|
||||
(defconst fuel-debug--error-cont-regex "^ +\\(\\^\\)$")
|
||||
|
||||
(defconst fuel-debug--error-regex
|
||||
(format "%s\n%s"
|
||||
fuel-debug--error-file-regex
|
||||
fuel-debug--error-line-regex))
|
||||
|
||||
(defconst fuel-debug--named-restart-regex
|
||||
(format "^\\(%s\\) " (regexp-opt '(":warnings" ":errors" ":linkage"))))
|
||||
|
||||
(defconst fuel-debug--restart-regex
|
||||
"^:\\([0-9]+\\) \\(.+\\)")
|
||||
|
||||
(defconst fuel-debug--font-lock-keywords
|
||||
`((,fuel-debug--error-file-regex . 'fuel-debug-font-lock-error)
|
||||
(,fuel-debug--error-line-regex 1 'fuel-debug-font-lock-line)
|
||||
(,fuel-debug--error-cont-regex 1 'fuel-debug-font-lock-column)
|
||||
(,fuel-debug--restart-regex (1 'fuel-debug-font-lock-restart-number)
|
||||
(2 'fuel-debug-font-lock-restart-name))
|
||||
(,fuel-debug--named-restart-regex 1 'fuel-debug-font-lock-restart-number)
|
||||
("^\\(Restarts?\\|Loading\\) .+$" . 'fuel-debug-font-lock-info)
|
||||
("^Error: " . 'fuel-debug-font-lock-error)))
|
||||
|
||||
(defun fuel-debug--font-lock-setup ()
|
||||
(set (make-local-variable 'font-lock-defaults)
|
||||
'(fuel-debug--font-lock-keywords t nil nil nil)))
|
||||
|
||||
;;; Buffer navigation:
|
||||
|
||||
(defun fuel-debug-goto-error ()
|
||||
(interactive)
|
||||
(let* ((err (or (fuel-debug--buffer-error)
|
||||
(error "No errors reported")))
|
||||
(file (or (fuel-eval--error-file err)
|
||||
(error "No file associated with error")))
|
||||
(l/c (fuel-eval--error-line/column err))
|
||||
(line (or (car l/c) 1))
|
||||
(col (or (cdr l/c) 0)))
|
||||
(find-file-other-window file)
|
||||
(goto-line line)
|
||||
(forward-char col)))
|
||||
|
||||
(defun fuel-debug--read-restart-no ()
|
||||
(let ((rs (fuel-debug--buffer-restarts)))
|
||||
(unless rs (error "No restarts available"))
|
||||
(let* ((rsn (length rs))
|
||||
(prompt (format "Restart number? (1-%s): " rsn))
|
||||
(no 0))
|
||||
(while (or (> (setq no (read-number prompt)) rsn)
|
||||
(< no 1)))
|
||||
no)))
|
||||
|
||||
(defun fuel-debug-exec-restart (&optional n confirm)
|
||||
(interactive (list (fuel-debug--read-restart-no)))
|
||||
(let ((n (or n 1))
|
||||
(rs (fuel-debug--buffer-restarts)))
|
||||
(when (zerop (length rs))
|
||||
(error "No restarts available"))
|
||||
(when (or (< n 1) (> n (length rs)))
|
||||
(error "Restart %s not available" n))
|
||||
(when (or (not confirm)
|
||||
(y-or-n-p (format "Invoke restart %s? " n)))
|
||||
(message "Invoking restart %s" n)
|
||||
(let* ((file (fuel-debug--buffer-file))
|
||||
(buffer (if file (find-file-noselect file) (current-buffer))))
|
||||
(with-current-buffer buffer
|
||||
(fuel-debug--display-retort
|
||||
(fuel-eval--eval-string/context (format ":%s" n))
|
||||
(format "Restart %s (%s) successful" n (nth (1- n) rs))))))))
|
||||
|
||||
|
||||
;;; Fuel Debug mode:
|
||||
|
||||
(defvar fuel-debug-mode-map
|
||||
(let ((map (make-keymap)))
|
||||
(suppress-keymap map)
|
||||
(define-key map "g" 'fuel-debug-goto-error)
|
||||
(define-key map "\C-c\C-c" 'fuel-debug-goto-error)
|
||||
(define-key map "q" 'bury-buffer)
|
||||
(dotimes (n 9)
|
||||
(define-key map (vector (+ ?1 n))
|
||||
`(lambda () (interactive) (fuel-debug-exec-restart ,(1+ n) t))))
|
||||
map))
|
||||
|
||||
(defun fuel-debug-mode ()
|
||||
"A major mode for displaying Factor's compilation results and
|
||||
invoking restarts as needed.
|
||||
\\{fuel-debug-mode-map}"
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(setq major-mode 'factor-mode)
|
||||
(setq mode-name "Fuel Debug")
|
||||
(use-local-map fuel-debug-mode-map)
|
||||
(fuel-debug--font-lock-setup)
|
||||
(setq fuel-debug--file nil)
|
||||
(setq fuel-debug--last-ret nil)
|
||||
(toggle-read-only 1)
|
||||
(run-hooks 'fuel-debug-mode-hook))
|
||||
|
||||
|
||||
(provide 'fuel-debug)
|
||||
;;; fuel-debug.el ends here
|
||||
|
|
@ -38,7 +38,8 @@
|
|||
(when (and (> fuel-eval-log-max-length 0)
|
||||
(> (point) fuel-eval-log-max-length))
|
||||
(erase-buffer))
|
||||
(when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256) "\n"))
|
||||
(when fuel-eval--log (insert "\n>> " (fuel--shorten-str str 256)))
|
||||
(newline)
|
||||
(let ((beg (point)))
|
||||
(comint-redirect-send-command-to-process str (current-buffer) proc nil t)
|
||||
(with-current-buffer (process-buffer proc)
|
||||
|
|
@ -58,8 +59,6 @@
|
|||
|
||||
(defsubst fuel-eval--retort-p (ret) (listp ret))
|
||||
|
||||
(defsubst fuel-eval--error-name (err) (car err))
|
||||
|
||||
(defsubst fuel-eval--make-parse-error-retort (str)
|
||||
(fuel-eval--retort-make 'parse-retort-error nil str))
|
||||
|
||||
|
|
@ -83,29 +82,60 @@
|
|||
(defsubst fuel-eval--factor-array (strs)
|
||||
(format "V{ %S }" (mapconcat 'identity strs " ")))
|
||||
|
||||
(defsubst fuel-eval--eval-strings (strs)
|
||||
(let ((str (format "%s fuel-eval" (fuel-eval--factor-array strs))))
|
||||
(defsubst fuel-eval--eval-strings (strs &optional no-restart)
|
||||
(let ((str (format "fuel-eval-%s %s fuel-eval"
|
||||
(if no-restart "non-restartable" "restartable")
|
||||
(fuel-eval--factor-array strs))))
|
||||
(fuel-eval--send/retort str)))
|
||||
|
||||
(defsubst fuel-eval--eval-string (str)
|
||||
(fuel-eval--eval-strings (list str)))
|
||||
(defsubst fuel-eval--eval-string (str &optional no-restart)
|
||||
(fuel-eval--eval-strings (list str) no-restart))
|
||||
|
||||
(defun fuel-eval--eval-strings/context (strs)
|
||||
(defun fuel-eval--eval-strings/context (strs &optional no-restart)
|
||||
(let ((usings (fuel-syntax--usings-update)))
|
||||
(fuel-eval--send/retort
|
||||
(format "%s %S %s fuel-eval-in-context"
|
||||
(format "fuel-eval-%s %s %S %s fuel-eval-in-context"
|
||||
(if no-restart "non-restartable" "restartable")
|
||||
(fuel-eval--factor-array strs)
|
||||
(or fuel-syntax--current-vocab "f")
|
||||
(if usings (fuel-eval--factor-array usings) "f")))))
|
||||
|
||||
(defsubst fuel-eval--eval-string/context (str)
|
||||
(fuel-eval--eval-strings/context (list str)))
|
||||
(defsubst fuel-eval--eval-string/context (str &optional no-restart)
|
||||
(fuel-eval--eval-strings/context (list str) no-restart))
|
||||
|
||||
(defun fuel-eval--eval-region/context (begin end)
|
||||
(defun fuel-eval--eval-region/context (begin end &optional no-restart)
|
||||
(let ((lines (split-string (buffer-substring-no-properties begin end)
|
||||
"[\f\n\r\v]+" t)))
|
||||
(when (> (length lines) 0)
|
||||
(fuel-eval--eval-strings/context lines))))
|
||||
(fuel-eval--eval-strings/context lines no-restart))))
|
||||
|
||||
|
||||
;;; Error parsing
|
||||
|
||||
(defsubst fuel-eval--error-name (err) (car err))
|
||||
|
||||
(defsubst fuel-eval--error-restarts (err)
|
||||
(cdr (assoc :restarts (fuel-eval--error-name-p err 'condition))))
|
||||
|
||||
(defun fuel-eval--error-name-p (err name)
|
||||
(unless (null err)
|
||||
(or (and (eq (fuel-eval--error-name err) name) err)
|
||||
(assoc name err))))
|
||||
|
||||
(defsubst fuel-eval--error-file (err)
|
||||
(nth 1 (fuel-eval--error-name-p err 'source-file-error)))
|
||||
|
||||
(defsubst fuel-eval--error-lexer-p (err)
|
||||
(or (fuel-eval--error-name-p err 'lexer-error)
|
||||
(fuel-eval--error-name-p (fuel-eval--error-name-p err 'source-file-error)
|
||||
'lexer-error)))
|
||||
|
||||
(defsubst fuel-eval--error-line/column (err)
|
||||
(let ((err (fuel-eval--error-lexer-p err)))
|
||||
(cons (nth 1 err) (nth 2 err))))
|
||||
|
||||
(defsubst fuel-eval--error-line-text (err)
|
||||
(nth 3 (fuel-eval--error-lexer-p err)))
|
||||
|
||||
|
||||
(provide 'fuel-eval)
|
||||
|
|
|
|||
|
|
@ -21,30 +21,23 @@
|
|||
|
||||
;;; Faces:
|
||||
|
||||
(defmacro fuel-font-lock--face (face def doc)
|
||||
(let ((face (intern (format "factor-font-lock-%s" (symbol-name face))))
|
||||
(def (intern (format "font-lock-%s-face" (symbol-name def)))))
|
||||
(defmacro fuel-font-lock--make-face (prefix def-prefix group face def doc)
|
||||
(let ((face (intern (format "%s-%s" prefix face)))
|
||||
(def (intern (format "%s-%s-face" def-prefix def))))
|
||||
`(defface ,face (face-default-spec ,def)
|
||||
,(format "Face for %s." doc)
|
||||
:group 'factor-mode
|
||||
:group ',group
|
||||
:group 'faces)))
|
||||
|
||||
(defmacro fuel-font-lock--faces-setup ()
|
||||
(cons 'progn
|
||||
(mapcar (lambda (f) (cons 'fuel-font-lock--face f))
|
||||
'((comment comment "comments")
|
||||
(constructor type "constructors (<foo>)")
|
||||
(declaration keyword "declaration words")
|
||||
(parsing-word keyword "parsing words")
|
||||
(setter-word function-name "setter words (>>foo)")
|
||||
(stack-effect comment "stack effect specifications")
|
||||
(string string "strings")
|
||||
(symbol variable-name "name of symbol being defined")
|
||||
(type-name type "type names")
|
||||
(vocabulary-name constant "vocabulary names")
|
||||
(word function-name "word, generic or method being defined")))))
|
||||
|
||||
(fuel-font-lock--faces-setup)
|
||||
(defmacro fuel-font-lock--define-faces (prefix def-prefix group faces)
|
||||
(let ((setup (make-symbol (format "%s--faces-setup" prefix))))
|
||||
`(progn
|
||||
(defmacro ,setup ()
|
||||
(cons 'progn
|
||||
(mapcar (lambda (f) (append '(fuel-font-lock--make-face
|
||||
,prefix ,def-prefix ,group) f))
|
||||
',faces)))
|
||||
(,setup))))
|
||||
|
||||
|
||||
;;; Font lock:
|
||||
|
|
|
|||
|
|
@ -68,10 +68,11 @@
|
|||
|
||||
(defun fuel-help--word-synopsis (&optional word)
|
||||
(let ((word (or word (fuel-syntax-symbol-at-point)))
|
||||
(fuel-eval--log nil))
|
||||
(fuel-eval--log t))
|
||||
(when word
|
||||
(let ((ret (fuel-eval--eval-string/context
|
||||
(format "\\ %s synopsis fuel-eval-set-result" word))))
|
||||
(format "\\ %s synopsis fuel-eval-set-result" word)
|
||||
t)))
|
||||
(when (not (fuel-eval--retort-error ret))
|
||||
(if fuel-help-minibuffer-font-lock
|
||||
(fuel-help--font-lock-str (fuel-eval--retort-result ret))
|
||||
|
|
@ -170,7 +171,7 @@ displayed in the minibuffer."
|
|||
(def (if ask (read-string prompt nil 'fuel-help--history def) def))
|
||||
(cmd (format "\\ %s %s" def (if see "see" "help")))
|
||||
(fuel-eval--log nil)
|
||||
(ret (fuel-eval--eval-string/context cmd))
|
||||
(ret (fuel-eval--eval-string/context cmd t))
|
||||
(out (fuel-eval--retort-output ret)))
|
||||
(if (or (fuel-eval--retort-error ret) (empty-string-p out))
|
||||
(message "No help for '%s'" def)
|
||||
|
|
|
|||
|
|
@ -59,10 +59,15 @@ buffer."
|
|||
(error "Could not run factor: %s is not executable" factor))
|
||||
(unless (file-readable-p image)
|
||||
(error "Could not run factor: image file %s not readable" image))
|
||||
(setq fuel-listener-buffer
|
||||
(make-comint "fuel listener" factor nil "-run=fuel" (format "-i=%s" image)))
|
||||
(setq fuel-listener-buffer (get-buffer-create "*fuel listener*"))
|
||||
(with-current-buffer fuel-listener-buffer
|
||||
(fuel-listener-mode))))
|
||||
(fuel-listener-mode)
|
||||
(message "Starting FUEL listener ...")
|
||||
(comint-exec fuel-listener-buffer "factor"
|
||||
factor nil `("-run=fuel" ,(format "-i=%s" image)))
|
||||
(fuel-listener--wait-for-prompt 20)
|
||||
(fuel-eval--send-string "USE: fuel")
|
||||
(message "FUEL listener up and running!"))))
|
||||
|
||||
(defun fuel-listener--process (&optional start)
|
||||
(or (and (buffer-live-p fuel-listener-buffer)
|
||||
|
|
@ -74,6 +79,23 @@ buffer."
|
|||
|
||||
(setq fuel-eval--default-proc-function 'fuel-listener--process)
|
||||
|
||||
|
||||
;;; Prompt chasing
|
||||
|
||||
(defun fuel-listener--wait-for-prompt (&optional timeout)
|
||||
(let ((proc (get-buffer-process fuel-listener-buffer))
|
||||
(seen))
|
||||
(with-current-buffer fuel-listener-buffer
|
||||
(while (progn (goto-char comint-last-input-end)
|
||||
(not (or seen
|
||||
(setq seen
|
||||
(re-search-forward comint-prompt-regexp nil t))
|
||||
(not (accept-process-output proc timeout))))))
|
||||
(goto-char (point-max)))
|
||||
(unless seen
|
||||
(pop-to-buffer fuel-listener-buffer)
|
||||
(error "No prompt found!"))))
|
||||
|
||||
|
||||
;;; Interface: starting fuel listener
|
||||
|
||||
|
|
@ -94,30 +116,17 @@ buffer."
|
|||
|
||||
(defconst fuel-listener--prompt-regex "( [^)]* ) ")
|
||||
|
||||
(defun fuel-listener--wait-for-prompt (&optional timeout)
|
||||
(let ((proc (fuel-listener--process)))
|
||||
(with-current-buffer fuel-listener-buffer
|
||||
(goto-char comint-last-input-end)
|
||||
(while (not (or (re-search-forward comint-prompt-regexp nil t)
|
||||
(not (accept-process-output proc timeout))))
|
||||
(goto-char comint-last-input-end))
|
||||
(goto-char (point-max)))))
|
||||
|
||||
(defun fuel-listener--startup ()
|
||||
(fuel-listener--wait-for-prompt)
|
||||
(fuel-eval--send-string "USE: fuel")
|
||||
(message "FUEL listener up and running!"))
|
||||
|
||||
(define-derived-mode fuel-listener-mode comint-mode "Fuel Listener"
|
||||
"Major mode for interacting with an inferior Factor listener process.
|
||||
\\{fuel-listener-mode-map}"
|
||||
(set (make-local-variable 'comint-prompt-regexp)
|
||||
fuel-listener--prompt-regex)
|
||||
(set (make-local-variable 'comint-prompt-read-only) t)
|
||||
(fuel-listener--startup))
|
||||
(setq fuel-listener--compilation-begin nil))
|
||||
|
||||
;; (define-key fuel-listener-mode-map "\C-w" 'comint-kill-region)
|
||||
;; (define-key fuel-listener-mode-map "\C-k" 'comint-kill-whole-line)
|
||||
(define-key fuel-listener-mode-map "\C-ch" 'fuel-help)
|
||||
(define-key fuel-listener-mode-map "\M-." 'fuel-edit-word-at-point)
|
||||
(define-key fuel-listener-mode-map "\C-ck" 'fuel-run-file)
|
||||
|
||||
|
||||
(provide 'fuel-listener)
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@
|
|||
(require 'fuel-base)
|
||||
(require 'fuel-syntax)
|
||||
(require 'fuel-font-lock)
|
||||
(require 'fuel-debug)
|
||||
(require 'fuel-help)
|
||||
(require 'fuel-eval)
|
||||
(require 'fuel-listener)
|
||||
|
|
@ -37,33 +38,58 @@
|
|||
|
||||
;;; User commands
|
||||
|
||||
(defun fuel-run-file (&optional arg)
|
||||
"Sends the current file to Factor for compilation.
|
||||
With prefix argument, ask for the file to run."
|
||||
(interactive "P")
|
||||
(let* ((file (or (and arg (read-file-name "File: " nil (buffer-file-name) t))
|
||||
(buffer-file-name)))
|
||||
(file (expand-file-name file))
|
||||
(buffer (find-file-noselect file))
|
||||
(cmd (format "%S fuel-run-file" file)))
|
||||
(when buffer
|
||||
(with-current-buffer buffer
|
||||
(fuel-debug--display-retort (fuel-eval--eval-string/context cmd)
|
||||
(format "%s successfully compiled" file)
|
||||
nil
|
||||
file)))))
|
||||
|
||||
(defun fuel-eval-region (begin end &optional arg)
|
||||
"Sends region to Fuel's listener for evaluation.
|
||||
With prefix, switchs to the listener's buffer afterwards."
|
||||
Unless called with a prefix, switchs to the compilation results
|
||||
buffer in case of errors."
|
||||
(interactive "r\nP")
|
||||
(let* ((ret (fuel-eval--eval-region/context begin end))
|
||||
(err (fuel-eval--retort-error ret)))
|
||||
(message "%s" (or err (fuel--shorten-region begin end 70))))
|
||||
(when arg (pop-to-buffer fuel-listener-buffer)))
|
||||
(fuel-debug--display-retort
|
||||
(fuel-eval--eval-region/context begin end)
|
||||
(format "%s%s"
|
||||
(if fuel-syntax--current-vocab
|
||||
(format "IN: %s " fuel-syntax--current-vocab)
|
||||
"")
|
||||
(fuel--shorten-region begin end 70))
|
||||
arg
|
||||
(buffer-file-name)))
|
||||
|
||||
(defun fuel-eval-extended-region (begin end &optional arg)
|
||||
"Sends region extended outwards to nearest definitions,
|
||||
to Fuel's listener for evaluation. With prefix, switchs to the
|
||||
listener's buffer afterwards."
|
||||
to Fuel's listener for evaluation.
|
||||
Unless called with a prefix, switchs to the compilation results
|
||||
buffer in case of errors."
|
||||
(interactive "r\nP")
|
||||
(fuel-eval-region (save-excursion (goto-char begin) (mark-defun) (point))
|
||||
(save-excursion (goto-char end) (mark-defun) (mark))))
|
||||
(save-excursion (goto-char end) (mark-defun) (mark))
|
||||
arg))
|
||||
|
||||
(defun fuel-eval-definition (&optional arg)
|
||||
"Sends definition around point to Fuel's listener for evaluation.
|
||||
With prefix, switchs to the listener's buffer afterwards."
|
||||
Unless called with a prefix, switchs to the compilation results
|
||||
buffer in case of errors."
|
||||
(interactive "P")
|
||||
(save-excursion
|
||||
(mark-defun)
|
||||
(let* ((begin (point))
|
||||
(end (mark)))
|
||||
(unless (< begin end) (error "No evaluable definition around point"))
|
||||
(fuel-eval-region begin end))))
|
||||
(fuel-eval-region begin end arg))))
|
||||
|
||||
(defun fuel-edit-word-at-point (&optional arg)
|
||||
"Opens a new window visiting the definition of the word at point.
|
||||
|
|
@ -128,6 +154,9 @@ interacting with a factor listener is at your disposal.
|
|||
|
||||
(fuel-mode--key-1 ?z 'run-factor)
|
||||
|
||||
(fuel-mode--key-1 ?k 'fuel-run-file)
|
||||
(fuel-mode--key ?e ?k 'fuel-run-file)
|
||||
|
||||
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
|
||||
(fuel-mode--key ?e ?x 'fuel-eval-definition)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue