steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
John Benediktsson 2008-12-18 18:51:37 -08:00
parent b43dce4668 88ec8786fd
commit 09b5f79540
20 changed files with 330 additions and 166 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
basis/core-foundation/run-loop/run-loop.factor
View File

@ -19,9 +19,9 @@ FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
FUNCTION: SInt32 CFRunLoopRunInMode (
CFStringRef mode,
CFTimeInterval seconds,
Boolean returnAfterSourceHandled
CFStringRef mode,
CFTimeInterval seconds,
Boolean returnAfterSourceHandled
) ;
FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
@ -31,27 +31,27 @@ FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
) ;
FUNCTION: void CFRunLoopAddSource (
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveSource (
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopSourceRef source,
CFStringRef mode
) ;
FUNCTION: void CFRunLoopAddTimer (
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveTimer (
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
CFRunLoopRef rl,
CFRunLoopTimerRef timer,
CFStringRef mode
) ;
: CFRunLoopDefaultMode ( -- alien )

24
basis/core-foundation/strings/strings.factor
View File

@ -23,11 +23,11 @@ TYPEDEF: int CFStringEncoding
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
FUNCTION: CFStringRef CFStringCreateWithBytes (
CFAllocatorRef alloc,
UInt8* bytes,
CFIndex numBytes,
CFStringEncoding encoding,
Boolean isExternalRepresentation
CFAllocatorRef alloc,
UInt8* bytes,
CFIndex numBytes,
CFStringEncoding encoding,
Boolean isExternalRepresentation
) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
@ -35,16 +35,16 @@ FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
FUNCTION: Boolean CFStringGetCString (
CFStringRef theString,
char* buffer,
CFIndex bufferSize,
CFStringEncoding encoding
CFStringRef theString,
char* buffer,
CFIndex bufferSize,
CFStringEncoding encoding
) ;
FUNCTION: CFStringRef CFStringCreateWithCString (
CFAllocatorRef alloc,
char* cStr,
CFStringEncoding encoding
CFAllocatorRef alloc,
char* cStr,
CFStringEncoding encoding
) ;
: <CFString> ( string -- alien )

19
basis/io/files/info/unix/linux/linux.factor
View File

@ -3,8 +3,9 @@
USING: accessors alien.c-types alien.syntax combinators csv
io.backend io.encodings.utf8 io.files io.files.info io.streams.string
io.files.unix kernel math.order namespaces sequences sorting
system unix unix.statfs.linux unix.statvfs.linux
specialized-arrays.direct.uint arrays io.files.info.unix ;
system unix unix.statfs.linux unix.statvfs.linux io.files.links
specialized-arrays.direct.uint arrays io.files.info.unix assocs
io.pathnames ;
IN: io.files.info.unix.linux
TUPLE: linux-file-system-info < unix-file-system-info
@ -70,6 +71,16 @@ M: linux file-systems
} cleave
] map ;
: (find-mount-point) ( path mtab-paths -- mtab-entry )
[ follow-links ] dip 2dup at* [
2nip
] [
drop [ parent-directory ] dip (find-mount-point)
] if ;
: find-mount-point ( path -- mtab-entry )
parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
ERROR: file-system-not-found ;
M: linux file-system-info ( path -- )
@ -80,9 +91,7 @@ M: linux file-system-info ( path -- )
[ file-system-statvfs statvfs>file-system-info ] bi
file-system-calculations
] keep
parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
[ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
find-mount-point
{
[ file-system-name>> >>device-name drop ]
[ mount-point>> >>mount-point drop ]

5
basis/io/files/info/windows/windows.factor
View File

@ -102,10 +102,7 @@ M: windows link-info ( path -- info )
[ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ;
: calculate-file-system-info ( file-system-info -- file-system-info' )
{
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
[ ]
} cleave ;
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ;
TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ;

35
basis/io/files/links/links-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io.files.info ;
USING: help.markup help.syntax io.files.info math ;
IN: io.files.links
HELP: make-link
@ -13,11 +13,40 @@ HELP: copy-link
{ $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } }
{ $description "Copies a symbolic link without following the link." } ;
{ make-link read-link copy-link } related-words
HELP: follow-link
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Returns an absolute path from " { $link read-link } "." } ;
HELP: follow-links
{ $values
{ "path" "a pathname string" }
{ "path'" "a pathname string" }
}
{ $description "Follows a chain of symlinks up to " { $link symlink-depth } "." } ;
{ read-link follow-link follow-links } related-words
HELP: symlink-depth
{ $values
{ "value" integer }
}
{ $description "The number of redirections " { $link follow-links } " will follow." } ;
HELP: too-many-symlinks
{ $values
{ "path" "a pathname string" } { "n" integer }
}
{ $description "An error thrown when the number of redirections in a chain of symlinks surpasses the value in the " { $link symlink-depth } " variable." } ;
ARTICLE: "io.files.links" "Symbolic links"
"Reading and creating links:"
"Reading links:"
{ $subsection read-link }
{ $subsection follow-link }
{ $subsection follow-links }
"Creating links:"
{ $subsection make-link }
"Copying links:"
{ $subsection copy-link }

31
basis/io/files/links/links-tests.factor Normal file
View File

@ -0,0 +1,31 @@
USING: io.directories io.files.links tools.test
io.files.unique tools.files fry ;
IN: io.files.links.tests
: make-test-links ( n path -- )
[ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ]
[ [ number>string ] dip prepend touch-file ] 2bi ; inline
[ t ] [
[
5 "lol" make-test-links
"lol1" follow-links
current-directory get "lol5" append-path =
] with-unique-directory
] unit-test
[
[
100 "laf" make-test-links "laf1" follow-links
] with-unique-directory
] [ too-many-symlinks? ] must-fail-with
[ t ] [
110 symlink-depth [
[
100 "laf" make-test-links
"laf1" follow-links
current-directory get "laf100" append-path =
] with-unique-directory
] with-variable
] unit-test

26
basis/io/files/links/links.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel vocabs.loader ;
USING: accessors io.backend io.files.info io.files.types
io.pathnames kernel math namespaces system vocabs.loader ;
IN: io.files.links
HOOK: make-link os ( target symlink -- )
@ -10,4 +11,25 @@ HOOK: read-link os ( symlink -- path )
: copy-link ( target symlink -- )
[ read-link ] dip make-link ;
os unix? [ "io.files.links.unix" require ] when
os unix? [ "io.files.links.unix" require ] when
: follow-link ( path -- path' )
[ parent-directory ] [ read-link ] bi append-path ;
SYMBOL: symlink-depth
10 symlink-depth set-global
ERROR: too-many-symlinks path n ;
<PRIVATE
: (follow-links) ( n path -- path' )
over 0 = [ symlink-depth get too-many-symlinks ] when
dup link-info type>> +symbolic-link+ =
[ [ 1- ] [ follow-link ] bi* (follow-links) ]
[ nip ] if ; inline recursive
PRIVATE>
: follow-links ( path -- path' )
[ symlink-depth get ] dip normalize-path (follow-links) ;

2
basis/io/files/links/unix/unix.factor
View File

@ -7,4 +7,4 @@ M: unix make-link ( path1 path2 -- )
normalize-path symlink io-error ;
M: unix read-link ( path -- path' )
normalize-path read-symbolic-link ;
normalize-path read-symbolic-link ;

12
basis/x11/xim/xim.factor
View File

@ -9,14 +9,14 @@ IN: x11.xim
SYMBOL: xim
: (init-xim) ( classname medifier -- im )
XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
[ dpy get f ] dip dup XOpenIM ;
XSetLocaleModifiers [ "XSetLocaleModifiers() failed" throw ] unless
[ dpy get f ] dip dup XOpenIM ;
: init-xim ( classname -- )
dup "" (init-xim)
[ nip ]
[ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
xim set-global ;
dup "" (init-xim)
[ nip ]
[ "@im=none" (init-xim) [ "XOpenIM() failed" throw ] unless* ] if*
xim set-global ;
: close-xim ( -- )
xim get-global XCloseIM drop f xim set-global ;

22
extra/fuel/fuel.factor
View File

@ -7,7 +7,7 @@ eval help io io.files io.pathnames io.streams.string kernel
lexer listener listener.private make math memoize namespaces
parser prettyprint prettyprint.config quotations sequences sets
sorting source-files strings tools.vocabs vectors vocabs
vocabs.loader vocabs.parser ;
vocabs.loader vocabs.parser summary ;
IN: fuel
@ -160,6 +160,10 @@ M: source-file fuel-pprint path>> fuel-pprint ;
: fuel-end-eval ( -- ) [ ] (fuel-end-eval) ; inline
: fuel-run-file ( path -- ) run-file ; inline
! Edit locations
: fuel-get-edit-location ( defspec -- )
where [
first2 [ (normalize-path) ] dip 2array fuel-eval-set-result
@ -168,12 +172,23 @@ M: source-file fuel-pprint path>> fuel-pprint ;
: fuel-get-vocab-location ( vocab -- )
>vocab-link fuel-get-edit-location ; inline
! Completion support
: fuel-filter-prefix ( seq prefix -- seq )
[ drop-prefix nip length 0 = ] curry filter prune ; inline
: (fuel-get-vocabs) ( -- seq )
all-vocabs-seq [ vocab-name ] map ; inline
: fuel-get-vocabs ( -- )
(fuel-get-vocabs) fuel-eval-set-result ; inline
: fuel-get-vocabs/prefix ( prefix -- )
(fuel-get-vocabs) swap fuel-filter-prefix fuel-eval-set-result ; inline
: fuel-vocab-summary ( name -- )
>vocab-link summary fuel-eval-set-result ; inline
MEMO: (fuel-vocab-words) ( name -- seq )
>vocab-link words [ name>> ] map ;
@ -185,12 +200,13 @@ MEMO: (fuel-vocab-words) ( name -- seq )
: (fuel-get-words) ( prefix names/f -- seq )
[ fuel-vocabs-words ] [ fuel-current-words ] if* natural-sort
swap [ drop-prefix nip length 0 = ] curry filter ;
swap fuel-filter-prefix ;
: fuel-get-words ( prefix names -- )
(fuel-get-words) fuel-eval-set-result ; inline
: fuel-run-file ( path -- ) run-file ; inline
! -run=fuel support
: fuel-startup ( -- ) "listener" run-file ; inline

2
misc/fuel/README
View File

@ -90,5 +90,7 @@ C-cC-eC-r is the same as C-cC-er)).
- RET : help for word at point
- f/b : next/previous page
- SPC/S-SPC : scroll up/down
- TAB/S-TAB : next/previous headline
- C-cz : switch to listener
- q: bury buffer

17
misc/fuel/factor-mode.el
View File

@ -59,23 +59,6 @@ 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:

14
misc/fuel/fuel-base.el
View File

@ -39,6 +39,15 @@
(when (equal item (ring-ref ring ind))
(throw 'found ind)))))))
(when (not (fboundp 'completion-table-dynamic))
(defun completion-table-dynamic (fun)
(lexical-let ((fun fun))
(lambda (string pred action)
(with-current-buffer (let ((win (minibuffer-selected-window)))
(if (window-live-p win) (window-buffer win)
(current-buffer)))
(complete-with-action action (funcall fun string) string pred))))))
;;; Utilities
@ -61,6 +70,11 @@
(defsubst empty-string-p (str) (equal str ""))
(defun fuel--string-prefix-p (prefix str)
(and (>= (length str) (length prefix))
(string= (substring-no-properties 0 (length prefix) str)
(substring-no-properties prefix))))
(defun fuel--respecting-message (format &rest format-args)
"Display TEXT as a message, without hiding any minibuffer contents."
(let ((text (format " [%s]" (apply #'format format format-args))))

40
misc/fuel/fuel-completion.el
View File

@ -32,6 +32,10 @@
(fuel-eval--send/wait '(:fuel* (fuel-get-vocabs) "fuel" (:array)))))))
fuel-completion--vocabs)
(defsubst fuel-completion--vocab-list (prefix)
(fuel-eval--retort-result
(fuel-eval--send/wait `(:fuel* (,prefix fuel-get-vocabs/prefix) t t))))
(defun fuel-completion--words (prefix vocabs)
(let ((vs (if vocabs (cons :array vocabs) 'f))
(us (or vocabs 't)))
@ -55,7 +59,7 @@ performed."))
If this window is no longer active or displaying the completions
buffer then we can ignore `fuel-completion--window-cfg'."))
(defun fuel-completion--maybe-save-window-configuration ()
(defun fuel-completion--save-window-cfg ()
"Maybe save the current window configuration.
Return true if the configuration was saved."
(unless (or fuel-completion--window-cfg
@ -66,17 +70,17 @@ Return true if the configuration was saved."
(defun fuel-completion--delay-restoration ()
(add-hook 'pre-command-hook
'fuel-completion--maybe-restore-window-configuration
'fuel-completion--maybe-restore-window-cfg
nil t))
(defun fuel-completion--forget-window-configuration ()
(defun fuel-completion--forget-window-cfg ()
(setq fuel-completion--window-cfg nil)
(setq fuel-completion--completions-window nil))
(defun fuel-completion--restore-window-configuration ()
(defun fuel-completion--restore-window-cfg ()
"Restore the window config if available."
(remove-hook 'pre-command-hook
'fuel-completion--maybe-restore-window-configuration)
'fuel-completion--maybe-restore-window-cfg)
(when (and fuel-completion--window-cfg
(fuel-completion--window-active-p))
(save-excursion
@ -85,21 +89,21 @@ Return true if the configuration was saved."
(when (buffer-live-p fuel-completion--comp-buffer)
(kill-buffer fuel-completion--comp-buffer))))
(defun fuel-completion--maybe-restore-window-configuration ()
(defun fuel-completion--maybe-restore-window-cfg ()
"Restore the window configuration, if the following command
terminates a current completion."
(remove-hook 'pre-command-hook
'fuel-completion--maybe-restore-window-configuration)
'fuel-completion--maybe-restore-window-cfg)
(condition-case err
(cond ((find last-command-char "()\"'`,# \r\n:")
(fuel-completion--restore-window-configuration))
(fuel-completion--restore-window-cfg))
((not (fuel-completion--window-active-p))
(fuel-completion--forget-window-configuration))
(fuel-completion--forget-window-cfg))
(t (fuel-completion--delay-restoration)))
(error
;; Because this is called on the pre-command-hook, we mustn't let
;; errors propagate.
(message "Error in fuel-completion--restore-window-configuration: %S" err))))
(message "Error in fuel-completion--restore-window-cfg: %S" err))))
(defun fuel-completion--window-active-p ()
"Is the completion window currently active?"
@ -108,7 +112,7 @@ terminates a current completion."
fuel-completion--comp-buffer)))
(defun fuel-completion--display-comp-list (completions base)
(let ((savedp (fuel-completion--maybe-save-window-configuration)))
(let ((savedp (fuel-completion--save-window-cfg)))
(with-output-to-temp-buffer fuel-completion--comp-buffer
(display-completion-list completions base)
(let ((offset (- (point) 1 (length base))))
@ -152,14 +156,16 @@ terminates a current completion."
(defvar fuel-completion--all-words-list-func
(completion-table-dynamic 'fuel-completion--all-words-list))
(defun fuel-completion--complete (prefix)
(let* ((words (fuel-completion--word-list prefix))
(defun fuel-completion--complete (prefix vocabs)
(let* ((words (if vocabs
(fuel-completion--vocabs)
(fuel-completion--word-list prefix)))
(completions (all-completions prefix words))
(partial (try-completion prefix words))
(partial (if (eq partial t) prefix partial)))
(cons completions partial)))
(defsubst fuel-completion--read-word (prompt &optional default history all)
(defun fuel-completion--read-word (prompt &optional default history all)
(completing-read prompt
(if all fuel-completion--all-words-list-func
fuel-completion--word-list-func)
@ -174,16 +180,16 @@ Perform completion similar to Emacs' complete-symbol."
(let* ((end (point))
(beg (fuel-syntax--symbol-start))
(prefix (buffer-substring-no-properties beg end))
(result (fuel-completion--complete prefix))
(result (fuel-completion--complete prefix (fuel-syntax--in-using)))
(completions (car result))
(partial (cdr result)))
(cond ((null completions)
(fuel--respecting-message "Can't find completion for %S" prefix)
(fuel-completion--restore-window-configuration))
(fuel-completion--restore-window-cfg))
(t (insert-and-inherit (substring partial (length prefix)))
(cond ((= (length completions) 1)
(fuel--respecting-message "Sole completion")
(fuel-completion--restore-window-configuration))
(fuel-completion--restore-window-cfg))
(t (fuel--respecting-message "Complete but not unique")
(fuel-completion--display-or-scroll completions
partial)))))))

55
misc/fuel/fuel-connection.el
View File

@ -46,8 +46,7 @@
(cons :id (random))
(cons :string str)
(cons :continuation cont)
(cons :buffer (or sender-buffer (current-buffer)))
(cons :output "")))
(cons :buffer (or sender-buffer (current-buffer)))))
(defsubst fuel-con--request-p (req)
(and (listp req) (eq (car req) :fuel-connection-request)))
@ -64,11 +63,6 @@
(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))
@ -143,12 +137,11 @@
(defconst fuel-con--init-stanza (format "USE: fuel %S write" fuel-con--eot-marker))
(defconst fuel-con--comint-finished-regex
(format "%s%s" fuel-con--eot-marker fuel-con--prompt-regex))
(format "^%s%s$" fuel-con--eot-marker fuel-con--prompt-regex))
(defun fuel-con--setup-comint ()
(comint-redirect-cleanup)
(add-hook 'comint-redirect-filter-functions
'fuel-con--comint-redirect-filter t t)
(set (make-local-variable 'comint-redirect-insert-matching-regexp) t)
(add-hook 'comint-redirect-hook
'fuel-con--comint-redirect-hook nil t))
@ -158,45 +151,45 @@
;;; Requests handling:
(defsubst fuel-con--comint-buffer ()
(get-buffer-create " *fuel connection retort*"))
(defsubst fuel-con--comint-buffer-form ()
(with-current-buffer (fuel-con--comint-buffer)
(goto-char (point-min))
(condition-case nil
(read (current-buffer))
(error (list 'fuel-con-error (buffer-string))))))
(defun fuel-con--process-next (con)
(when (not (fuel-con--connection-current-request con))
(let* ((buffer (fuel-con--connection-buffer con))
(req (fuel-con--connection-pop-request con))
(str (and req (fuel-con--request-string req))))
(str (and req (fuel-con--request-string req)))
(cbuf (with-current-buffer (fuel-con--comint-buffer)
(erase-buffer)
(current-buffer))))
(if (not (buffer-live-p buffer))
(fuel-con--connection-cancel-timer con)
(when (and buffer req str)
(set-buffer buffer)
(fuel-log--info "<%s>: %s" (fuel-con--request-id req) str)
(comint-redirect-send-command (format "%s" str)
(fuel-log--buffer) nil t))))))
(comint-redirect-send-command (format "%s" str) cbuf nil t))))))
(defun fuel-con--process-completed-request (req)
(let ((str (fuel-con--request-output req))
(cont (fuel-con--request-continuation req))
(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)))
(if (not cont)
(fuel-log--warn "<%s> Droping result for request %S (%s)"
id rstr str)
id rstr req)
(condition-case cerr
(with-current-buffer (or buffer (current-buffer))
(funcall cont str)
(fuel-log--info "<%s>: processed\n\t%s" id str))
(error (fuel-log--error "<%s>: continuation failed %S \n\t%s"
id rstr cerr))))))
(defvar fuel-con--debug-comint-p nil)
(defun fuel-con--comint-redirect-filter (str)
(if (not fuel-con--connection)
(fuel-log--error "No connection in buffer (%s)" str)
(let ((req (fuel-con--connection-current-request fuel-con--connection)))
(if (not req) (fuel-log--error "No current request (%s)" str)
(fuel-con--request-output req str)
(fuel-log--info "<%s>: in progress" (fuel-con--request-id req)))))
(if fuel-con--debug-comint-p (fuel--shorten-str str 256) ""))
(funcall cont (fuel-con--comint-buffer-form))
(fuel-log--info "<%s>: processed\n\t%s" id req))
(error (fuel-log--error
"<%s>: continuation failed %S \n\t%s" id rstr cerr))))))
(defun fuel-con--comint-redirect-hook ()
(if (not fuel-con--connection)

15
misc/fuel/fuel-eval.el
View File

@ -66,7 +66,8 @@
(defsubst factor--fuel-in (in)
(cond ((null in) :in)
((eq in t) "fuel-scratchpad")
((eq in 'f) 'f)
((eq in 't) "fuel-scratchpad")
((stringp in) in)
(t (error "Invalid 'in' (%s)" in))))
@ -115,17 +116,15 @@
(defsubst fuel-eval--retort-result (ret) (nth 1 ret))
(defsubst fuel-eval--retort-output (ret) (nth 2 ret))
(defsubst fuel-eval--retort-p (ret) (listp ret))
(defsubst fuel-eval--retort-p (ret)
(and (listp ret) (= 3 (length ret))))
(defsubst fuel-eval--make-parse-error-retort (str)
(fuel-eval--retort-make (cons 'fuel-parse-retort-error str) nil))
(defun fuel-eval--parse-retort (str)
(save-current-buffer
(condition-case nil
(let ((ret (car (read-from-string str))))
(if (fuel-eval--retort-p ret) ret (error)))
(error (fuel-eval--make-parse-error-retort str)))))
(defun fuel-eval--parse-retort (ret)
(if (fuel-eval--retort-p ret) ret
(fuel-eval--make-parse-error-retort ret)))
(defsubst fuel-eval--error-name (err) (car err))

20
misc/fuel/fuel-font-lock.el
View File

@ -13,8 +13,8 @@
;;; Code:
(require 'fuel-base)
(require 'fuel-syntax)
(require 'fuel-base)
(require 'font-lock)
@ -39,6 +39,21 @@
',faces)))
(,setup))))
(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)")
(getter-word function-name "getter 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")))
;;; Font lock:
@ -59,7 +74,8 @@
(2 'factor-font-lock-word))
(,fuel-syntax--parent-type-regex 1 'factor-font-lock-type-name)
(,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
(,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
(,fuel-syntax--setter-regex 2 'factor-font-lock-setter-word)
(,fuel-syntax--getter-regex 2 'factor-font-lock-getter-word)
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
(,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name))
"Font lock keywords definition for Factor mode.")

91
misc/fuel/fuel-help.el
View File

@ -76,12 +76,15 @@
(let ((word (or word (fuel-syntax-symbol-at-point)))
(fuel-log--inhibit-p t))
(when word
(let* ((cmd `(:fuel* (((:quote ,word) synopsis :get)) t))
(ret (fuel-eval--send/wait cmd 20)))
(when (and ret (not (fuel-eval--retort-error ret)))
(let* ((cmd (if (fuel-syntax--in-using)
`(:fuel* (,word fuel-vocab-summary) t t)
`(:fuel* (((:quote ,word) synopsis :get)) t)))
(ret (fuel-eval--send/wait cmd 20))
(res (fuel-eval--retort-result ret)))
(when (and ret (not (fuel-eval--retort-error ret)) (stringp res))
(if fuel-help-minibuffer-font-lock
(fuel-help--font-lock-str (fuel-eval--retort-result ret))
(fuel-eval--retort-result ret)))))))
(fuel-help--font-lock-str res)
res))))))
(make-variable-buffer-local
(defvar fuel-autodoc-mode-string " A"
@ -152,7 +155,8 @@ displayed in the minibuffer."
fuel-help-always-ask))
(def (if ask (fuel-completion--read-word prompt
def
'fuel-help--prompt-history)
'fuel-help--prompt-history
t)
def))
(cmd `(:fuel* ((:quote ,def) ,(if see 'see 'help)) t)))
(message "Looking up '%s' ..." def)
@ -176,14 +180,41 @@ displayed in the minibuffer."
(when (re-search-forward (format "^%s" def) nil t)
(beginning-of-line)
(kill-region (point-min) (point))
(next-line)
(open-line 1)
(fuel-help--history-push (cons def (buffer-string)))))
(set-buffer-modified-p nil)
(pop-to-buffer hb)
(goto-char (point-min))
(message "%s" def)))
;;; Help mode font lock:
(defconst fuel-help--headlines
(regexp-opt '("Class description"
"Definition"
"Errors"
"Examples"
"Generic word contract"
"Inputs and outputs"
"Methods"
"Notes"
"Parent topics:"
"See also"
"Syntax"
"Variable description"
"Variable value"
"Vocabulary"
"Warning"
"Word description")
t))
(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
(defconst fuel-help--font-lock-keywords
`(,@fuel-font-lock--font-lock-keywords
(,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines)))
;;; Interactive help commands:
@ -221,8 +252,18 @@ buffer."
(error "No previous page"))
(fuel-help--insert-contents (car item) (cdr item) t)))
(defun fuel-help-next-headline (&optional count)
(interactive "P")
(end-of-line)
(when (re-search-forward fuel-help--headlines-regexp nil t (or count 1))
(beginning-of-line)))
(defun fuel-help-previous-headline (&optional count)
(interactive "P")
(re-search-backward fuel-help--headlines-regexp nil t count))
;;;; Factor help mode:
;;;; Help mode map:
(defvar fuel-help-mode-map
(let ((map (make-sparse-keymap)))
@ -231,35 +272,19 @@ buffer."
(define-key map "b" 'fuel-help-previous)
(define-key map "f" 'fuel-help-next)
(define-key map "l" 'fuel-help-previous)
(define-key map "p" 'fuel-help-previous)
(define-key map "n" 'fuel-help-next)
(define-key map (kbd "TAB") 'fuel-help-next-headline)
(define-key map (kbd "S-TAB") 'fuel-help-previous-headline)
(define-key map [(backtab)] 'fuel-help-previous-headline)
(define-key map (kbd "SPC") 'scroll-up)
(define-key map (kbd "S-SPC") 'scroll-down)
(define-key map "\C-cz" 'run-factor)
(define-key map "\C-c\C-z" 'run-factor)
map))
(defconst fuel-help--headlines
(regexp-opt '("Class description"
"Definition"
"Errors"
"Examples"
"Generic word contract"
"Inputs and outputs"
"Methods"
"Notes"
"Parent topics:"
"See also"
"Syntax"
"Variable description"
"Variable value"
"Vocabulary"
"Warning"
"Word description")
t))
(defconst fuel-help--headlines-regexp (format "^%s" fuel-help--headlines))
(defconst fuel-help--font-lock-keywords
`(,@fuel-font-lock--font-lock-keywords
(,fuel-help--headlines-regexp . 'fuel-help-font-lock-headlines)))
;;; Help mode definition:
(defun fuel-help-mode ()
"Major mode for browsing Factor documentation.

23
misc/fuel/fuel-mode.el
View File

@ -39,14 +39,24 @@
;;; 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")
(defun fuel-mode--read-file (arg)
(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)))
(when (and buffer
(buffer-modified-p buffer)
(y-or-n-p "Save file? "))
(save-buffer buffer))
(cons file buffer)))
(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* ((f/b (fuel-mode--read-file arg))
(file (car f/b))
(buffer (cdr f/b)))
(when buffer
(with-current-buffer buffer
(message "Compiling %s ..." file)
@ -61,6 +71,7 @@ With prefix argument, ask for the file to run."
(message "Compiling %s ... OK!" file)
(message "")))
(defun fuel-eval-region (begin end &optional arg)
"Sends region to Fuel's listener for evaluation.
Unless called with a prefix, switchs to the compilation results
@ -191,9 +202,10 @@ interacting with a factor listener is at your disposal.
(define-key fuel-mode-map (vector '(control ?c) `(control ,p) k) c)
(define-key fuel-mode-map (vector '(control ?c) `(control ,p) `(control ,k)) c))
(fuel-mode--key-1 ?z 'run-factor)
(fuel-mode--key-1 ?k 'fuel-run-file)
(fuel-mode--key-1 ?l 'fuel-run-file)
(fuel-mode--key-1 ?r 'fuel-eval-region)
(fuel-mode--key-1 ?z 'run-factor)
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
@ -201,6 +213,7 @@ interacting with a factor listener is at your disposal.
(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol)
(fuel-mode--key ?e ?e 'fuel-eval-extended-region)
(fuel-mode--key ?e ?l 'fuel-run-file)
(fuel-mode--key ?e ?r 'fuel-eval-region)
(fuel-mode--key ?e ?v 'fuel-edit-vocabulary)
(fuel-mode--key ?e ?w 'fuel-edit-word)

13
misc/fuel/fuel-syntax.el
View File

@ -64,7 +64,8 @@
'("flushable" "foldable" "inline" "parsing" "recursive"))
(defconst fuel-syntax--declaration-words-regex
(regexp-opt fuel-syntax--declaration-words 'words))
(format "%s\\($\\| \\)"
(regexp-opt fuel-syntax--declaration-words 'words)))
(defsubst fuel-syntax--second-word-regex (prefixes)
(format "^%s +\\([^ \r\n]+\\)" (regexp-opt prefixes t)))
@ -82,7 +83,8 @@
(defconst fuel-syntax--constructor-regex "<[^ >]+>")
(defconst fuel-syntax--setter-regex "\\W>>[^ ]+\\b")
(defconst fuel-syntax--getter-regex "\\( \\|^\\)\\([^ ]+>>\\)\\( \\|$\\)")
(defconst fuel-syntax--setter-regex "\\( \\|^\\)\\(>>[^ ]+\\)\\( \\|$\\)")
(defconst fuel-syntax--symbol-definition-regex
(fuel-syntax--second-word-regex '("SYMBOL:" "VAR:")))
@ -232,6 +234,13 @@
(defsubst fuel-syntax--at-using ()
(looking-at fuel-syntax--using-lines-regex))
(defun fuel-syntax--in-using ()
(let ((p (point)))
(save-excursion
(and (re-search-backward "^USING: " nil t)
(re-search-forward " ;" nil t)
(< p (match-end 0))))))
(defsubst fuel-syntax--beginning-of-defun (&optional times)
(re-search-backward fuel-syntax--begin-of-def-regex nil t times))