Merge branch 'master' of git://factorcode.org/git/factor

extra/fuel/fuel.factor

@@ -5,7 +5,7 @@ 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 ;
+quotations sequences strings source-files vectors vocabs vocabs.loader ;
 
 IN: fuel
 
@@ -151,8 +151,17 @@ M: source-file fuel-pprint path>> fuel-pprint ;
 : fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
 
 : fuel-get-edit-location ( defspec -- )
-    where [ first2 [ (normalize-path) ] dip 2array fuel-eval-set-result ]
+    where [
-    when* ;
+       first2 [ (normalize-path) ] dip 2array fuel-eval-set-result
+    ] when* ;
+
+: fuel-get-vocab-location ( vocab -- )
+    vocab-source-path [
+        (normalize-path) 1 2array fuel-eval-set-result
+    ] when* ;
+
+: fuel-get-vocabs ( -- )
+    vocabs fuel-eval-set-result ; inline
 
 : fuel-run-file ( path -- ) run-file ; inline
 

misc/fuel/README

@@ -56,6 +56,7 @@ the same as C-cz)).
  - C-co : cycle between code, tests and docs factor files
 
  - M-. : edit word at point in Emacs (also in listener)
+ - C-cC-ev : edit vocabulary
 
  - C-cr, C-cC-er : eval region
  - C-M-r, C-cC-ee : eval region, extending it to definition boundaries

misc/fuel/factor-mode.el

@@ -112,13 +112,16 @@ code in the buffer."
   (save-excursion
     (beginning-of-line)
     (when (> (fuel-syntax--brackets-depth) 0)
-      (let ((op (fuel-syntax--brackets-start))
+      (let* ((op (fuel-syntax--brackets-start))
              (cl (fuel-syntax--brackets-end))
-            (ln (line-number-at-pos)))
+             (ln (line-number-at-pos))
+             (iop (fuel-syntax--indentation-at op)))
         (when (> ln (line-number-at-pos op))
-          (if (and (> cl 0) (= ln (line-number-at-pos cl)))
+          (if (and (> cl 0)
-              (fuel-syntax--indentation-at op)
+                   (= (- cl (point)) (current-indentation))
-            (fuel-syntax--increased-indentation (fuel-syntax--indentation-at op))))))))
+                   (= ln (line-number-at-pos cl)))
+              iop
+            (fuel-syntax--increased-indentation iop)))))))
 
 (defun factor-mode--indent-definition ()
   (save-excursion

misc/fuel/fuel-connection.el

@@ -40,7 +40,8 @@
         (cons :id (random))
         (cons :string str)
         (cons :continuation cont)
-        (cons :buffer (or sender-buffer (current-buffer)))))
+        (cons :buffer (or sender-buffer (current-buffer)))
+        (cons :output "")))
 
 (defsubst fuel-con--request-p (req)
   (and (listp req) (eq (car req) :fuel-connection-request)))
@@ -57,6 +58,11 @@
 (defsubst fuel-con--request-buffer (req)
   (cdr (assoc :buffer req)))
 
+(defun fuel-con--request-output (req &optional suffix)
+  (let ((cell (assoc :output req)))
+    (when suffix (setcdr cell (concat (cdr cell) suffix)))
+    (cdr cell)))
+
 (defsubst fuel-con--request-deactivate (req)
   (setcdr (assoc :continuation req) nil))
 
@@ -96,9 +102,10 @@
   (let ((reqs (assoc :requests c))
         (current (assoc :current c)))
     (setcdr current (prog1 (cadr reqs) (setcdr reqs (cddr reqs))))
-    (if (and current (fuel-con--request-deactivated-p current))
+    (if (and (cdr current)
+             (fuel-con--request-deactivated-p (cdr current)))
         (fuel-con--connection-pop-request c)
-      current)))
+      (cdr current))))
 
 
 ;;; Connection setup:
@@ -111,7 +118,52 @@
 
 (defun fuel-con--setup-comint ()
   (add-hook 'comint-redirect-filter-functions
-            'fuel-con--comint-redirect-filter t t))
+            'fuel-con--comint-redirect-filter t t)
+  (add-hook 'comint-redirect-hook
+            'fuel-con--comint-redirect-hook))
+
+
+;;; Logging:
+
+(defvar fuel-con--log-size 32000
+  "Maximum size of the Factor messages log.")
+
+(defvar fuel-con--log-verbose-p t
+  "Log level for Factor messages.")
+
+(define-derived-mode factor-messages-mode fundamental-mode "Factor Messages"
+  "Simple mode to log interactions with the factor listener"
+  (kill-all-local-variables)
+  (buffer-disable-undo)
+  (set (make-local-variable 'comint-redirect-subvert-readonly) t)
+  (add-hook 'after-change-functions
+            '(lambda (b e len)
+               (let ((inhibit-read-only t))
+                 (when (> b fuel-con--log-size)
+                   (delete-region (point-min) b))))
+            nil t)
+  (setq buffer-read-only t))
+
+(defun fuel-con--log-buffer ()
+  (or (get-buffer "*factor messages*")
+      (save-current-buffer
+        (set-buffer (get-buffer-create "*factor messages*"))
+        (factor-messages-mode)
+        (current-buffer))))
+
+(defun fuel-con--log-msg (type &rest args)
+  (with-current-buffer (fuel-con--log-buffer)
+    (let ((inhibit-read-only t))
+      (insert (format "\n%s: %s\n" type (apply 'format args))))))
+
+(defsubst fuel-con--log-warn (&rest args)
+  (apply 'fuel-con--log-msg 'WARNING args))
+
+(defsubst fuel-con--log-error (&rest args)
+  (apply 'fuel-con--log-msg 'ERROR args))
+
+(defsubst fuel-con--log-info (&rest args)
+  (if fuel-con--log-verbose-p (apply 'fuel-con--log-msg 'INFO args) ""))
 
 
 ;;; Requests handling:
@@ -123,31 +175,44 @@
            (str (and req (fuel-con--request-string req))))
       (when (and buffer req str)
         (set-buffer buffer)
-        (comint-redirect-send-command str
+        (when fuel-con--log-verbose-p
-                                      (get-buffer-create "*factor messages*")
+          (with-current-buffer (fuel-con--log-buffer)
-                                      nil
+            (let ((inhibit-read-only t))
-                                      t)))))
+              (fuel-con--log-info "<%s>: %s" (fuel-con--request-id req) str))))
+        (comint-redirect-send-command str (fuel-con--log-buffer) nil t)))))
 
-(defun fuel-con--comint-redirect-filter (str)
+(defun fuel-con--process-completed-request (req)
-  (if (not fuel-con--connection)
+  (let ((str (fuel-con--request-output req))
-      (format "\nERROR: No connection in buffer (%s)\n" str)
+        (cont (fuel-con--request-continuation req))
-    (let ((req (fuel-con--connection-current-request fuel-con--connection)))
-      (if (not req) (format "\nERROR: No current request (%s)\n" str)
-        (let ((cont (fuel-con--request-continuation req))
         (id (fuel-con--request-id req))
         (rstr (fuel-con--request-string req))
         (buffer (fuel-con--request-buffer req)))
-          (prog1
     (if (not cont)
-                  (format "\nWARNING: Droping result for request %s:%S (%s)\n"
+        (fuel-con--log-warn "<%s> Droping result for request %S (%s)"
                             id rstr str)
       (condition-case cerr
           (with-current-buffer (or buffer (current-buffer))
             (funcall cont str)
-                      (format "\nINFO: %s:%S processed\nINFO: %s\n" id rstr str))
+            (fuel-con--log-info "<%s>: processed\n\t%s" id str))
-                  (error (format "\nERROR: continuation failed %s:%S \nERROR: %s\n"
+        (error (fuel-con--log-error "<%s>: continuation failed %S \n\t%s"
-                                 id rstr cerr))))
+                                    id rstr cerr))))))
-            (fuel-con--connection-clean-current-request fuel-con--connection)))))))
+
+(defun fuel-con--comint-redirect-filter (str)
+  (if (not fuel-con--connection)
+      (fuel-con--log-error "No connection in buffer (%s)" str)
+    (let ((req (fuel-con--connection-current-request fuel-con--connection)))
+      (if (not req) (fuel-con--log-error "No current request (%s)" str)
+        (fuel-con--request-output req str)
+        (fuel-con--log-info "<%s>: in progress" (fuel-con--request-id req)))))
+  ".\n")
+
+(defun fuel-con--comint-redirect-hook ()
+  (if (not fuel-con--connection)
+      (fuel-con--log-error "No connection in buffer")
+    (let ((req (fuel-con--connection-current-request fuel-con--connection)))
+      (if (not req) (fuel-con--log-error "No current request (%s)" str)
+        (fuel-con--process-completed-request req)
+        (fuel-con--connection-clean-current-request fuel-con--connection)))))
 
 
 ;;; Message sending interface:

misc/fuel/fuel-debug.el

@@ -253,13 +253,14 @@ invoking restarts as needed.
 \\{fuel-debug-mode-map}"
   (interactive)
   (kill-all-local-variables)
+  (buffer-disable-undo)
   (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)
+  (setq buffer-read-only t)
   (run-hooks 'fuel-debug-mode-hook))
 
 

misc/fuel/fuel-help.el

@@ -261,6 +261,7 @@ buffer."
 \\{fuel-help-mode-map}"
   (interactive)
   (kill-all-local-variables)
+  (buffer-disable-undo)
   (use-local-map fuel-help-mode-map)
   (setq mode-name "Factor Help")
   (setq major-mode 'fuel-help-mode)
@@ -271,7 +272,7 @@ buffer."
   (fuel-autodoc-mode)
 
   (run-mode-hooks 'fuel-help-mode-hook)
-  (toggle-read-only 1))
+  (setq buffer-read-only t))
 
 
 (provide 'fuel-help)

misc/fuel/fuel-mode.el

@@ -97,6 +97,16 @@ buffer in case of errors."
       (unless (< begin end) (error "No evaluable definition around point"))
       (fuel-eval-region begin end arg))))
 
+(defun fuel--try-edit (ret)
+  (let* ((err (fuel-eval--retort-error ret))
+         (loc (fuel-eval--retort-result ret)))
+    (when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
+      (error "Couldn't find edit location for '%s'" word))
+    (unless (file-readable-p (car loc))
+      (error "Couldn't open '%s' for read" (car loc)))
+    (find-file-other-window (car loc))
+    (goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
+
 (defun fuel-edit-word-at-point (&optional arg)
   "Opens a new window visiting the definition of the word at point.
 With prefix, asks for the word to edit."
@@ -109,17 +119,29 @@ With prefix, asks for the word to edit."
                                         (if word (format " (%s)" word) ""))
                                 word)
                  word)))
+    (let ((str (fuel-eval--cmd/string
+                (format "\\ %s fuel-get-edit-location" word))))
+      (condition-case nil
+          (fuel--try-edit (fuel-eval--send/wait str))
+        (error (fuel-edit-vocabulary word))))))
+
+(defvar fuel--vocabs-prompt-history nil)
+
+(defun fuel--read-vocabulary-name ()
+  (let* ((str (fuel-eval--cmd/string "fuel-get-vocabs" t "fuel" t))
+         (vocabs (fuel-eval--retort-result (fuel-eval--send/wait str)))
+         (prompt "Vocabulary name: "))
+    (if vocabs
+        (completing-read prompt vocabs nil t nil fuel--vocabs-prompt-history)
+      (read-string prompt nil fuel--vocabs-prompt-history))))
+
+(defun fuel-edit-vocabulary (vocab)
+  "Visits vocabulary file in Emacs.
+When called interactively, asks for vocabulary with completion."
+  (interactive (list (fuel--read-vocabulary-name)))
   (let* ((str (fuel-eval--cmd/string
-                 (format "\\ %s fuel-get-edit-location" word)))
+               (format "%S fuel-get-vocab-location" vocab) t "fuel" t)))
-           (ret (fuel-eval--send/wait str))
+    (fuel--try-edit (fuel-eval--send/wait str))))
-           (err (fuel-eval--retort-error ret))
-           (loc (fuel-eval--retort-result ret)))
-      (when (or err (not loc) (not (listp loc)) (not (stringp (car loc))))
-        (error "Couldn't find edit location for '%s'" word))
-      (unless (file-readable-p (car loc))
-        (error "Couldn't open '%s' for read" (car loc)))
-      (find-file-other-window (car loc))
-      (goto-line (if (numberp (cadr loc)) (cadr loc) 1)))))
 
 
 ;;; Minor mode definition:
@@ -173,6 +195,8 @@ interacting with a factor listener is at your disposal.
 (define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
 (fuel-mode--key ?e ?e 'fuel-eval-extended-region)
 
+(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
+
 (define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
 
 (fuel-mode--key ?d ?a 'fuel-autodoc-mode)