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 2009-01-13 09:17:08 -08:00
parent 25d419ea52 f920007959
commit 8f5d03f61f
34 changed files with 473 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
basis/db/tester/tester.factor
View File

@ -46,12 +46,17 @@ test-2 "TEST2" {
: db-tester2 ( test-db -- )
[
[ test-1 recreate-table ] with-db
] [
[
2 [
10 random 100 random 100 random 100 random test-1 boa
insert-tuple yield
] parallel-each
test-1 ensure-table
test-2 ensure-table
] with-db
] [
<db-pool> [
10 [
10 [
f 100 random 100 random 100 random test-1 boa
insert-tuple yield
] times
] parallel-each
] with-pooled-db
] bi ;

9
basis/html/templates/chloe/chloe-tests.factor
View File

@ -1,7 +1,8 @@
USING: html.templates html.templates.chloe
tools.test io.streams.string kernel sequences ascii boxes
namespaces xml html.components html.forms
splitting unicode.categories furnace accessors ;
splitting unicode.categories furnace accessors
html.templates.chloe.compiler ;
IN: html.templates.chloe.tests
: run-template
@ -163,3 +164,9 @@ TUPLE: person first-name last-name ;
"test12" test-template call-template
] run-template
] unit-test
[
[
"test13" test-template call-template
] run-template
] [ error>> T{ unknown-chloe-tag f "this-tag-does-not-exist" } = ] must-fail-with

7
basis/html/templates/chloe/compiler/compiler.factor
View File

@ -76,10 +76,13 @@ DEFER: compile-element
[ drop tag-stack get pop* ]
} cleave ;
ERROR: unknown-chloe-tag tag ;
: compile-chloe-tag ( tag -- )
! "Unknown chloe tag: " prepend throw
dup main>> dup tags get at
[ curry assert-depth ] [ 2drop ] ?if ;
[ curry assert-depth ]
[ unknown-chloe-tag ]
?if ;
: compile-element ( element -- )
{

7
basis/html/templates/chloe/test/test13.xml Normal file
View File

@ -0,0 +1,7 @@
<?xml version='1.0' ?>
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<t:this-tag-does-not-exist />
</t:chloe>

8
basis/http/http.factor
View File

@ -45,8 +45,8 @@ IN: http
: check-header-string ( str -- str )
#! http://en.wikipedia.org/wiki/HTTP_Header_Injection
dup "\r\n\"" intersect empty?
[ "Header injection attack" throw ] unless ;
dup "\r\n\"" intersects?
[ "Header injection attack" throw ] when ;
: write-header ( assoc -- )
>alist sort-keys [
@ -97,8 +97,8 @@ TUPLE: cookie name value version comment path domain expires max-age http-only s
] { } make ;
: check-cookie-string ( string -- string' )
dup "=;'\"\r\n" intersect empty?
[ "Bad cookie name or value" throw ] unless ;
dup "=;'\"\r\n" intersects?
[ "Bad cookie name or value" throw ] when ;
: unparse-cookie-value ( key value -- )
{

5
basis/io/directories/directories-docs.factor
View File

@ -50,6 +50,10 @@ HELP: with-directory-files
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory file names on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
HELP: with-directory-entries
{ $values { "path" "a pathname string" } { "quot" quotation } }
{ $description "Calls the quotation with the directory entries on the stack and with the directory set as the " { $link current-directory } ". Restores the current directory after the quotation is called." } ;
HELP: delete-file
{ $values { "path" "a pathname string" } }
{ $description "Deletes a file." }
@ -122,6 +126,7 @@ ARTICLE: "io.directories.listing" "Directory listing"
"Directory listing:"
{ $subsection directory-entries }
{ $subsection directory-files }
{ $subsection with-directory-entries }
{ $subsection with-directory-files } ;
ARTICLE: "io.directories.create" "Creating directories"

3
basis/io/directories/directories.factor
View File

@ -41,6 +41,9 @@ HOOK: (directory-entries) os ( path -- seq )
: directory-files ( path -- seq )
directory-entries [ name>> ] map ;
: with-directory-entries ( path quot -- )
'[ "" directory-entries @ ] with-directory ; inline
: with-directory-files ( path quot -- )
'[ "" directory-files @ ] with-directory ; inline

68
basis/io/files/info/unix/unix.factor
View File

@ -114,30 +114,6 @@ M: file-info file-mode? [ permissions>> ] dip mask? ;
PRIVATE>
: ch>file-type ( ch -- type )
{
{ CHAR: b [ +block-device+ ] }
{ CHAR: c [ +character-device+ ] }
{ CHAR: d [ +directory+ ] }
{ CHAR: l [ +symbolic-link+ ] }
{ CHAR: s [ +socket+ ] }
{ CHAR: p [ +fifo+ ] }
{ CHAR: - [ +regular-file+ ] }
[ drop +unknown+ ]
} case ;
: file-type>ch ( type -- string )
{
{ +block-device+ [ CHAR: b ] }
{ +character-device+ [ CHAR: c ] }
{ +directory+ [ CHAR: d ] }
{ +symbolic-link+ [ CHAR: l ] }
{ +socket+ [ CHAR: s ] }
{ +fifo+ [ CHAR: p ] }
{ +regular-file+ [ CHAR: - ] }
[ drop CHAR: - ]
} case ;
: UID OCT: 0004000 ; inline
: GID OCT: 0002000 ; inline
: STICKY OCT: 0001000 ; inline
@ -251,3 +227,47 @@ M: string set-file-group ( path string -- )
: file-group-name ( path -- string )
file-group-id group-name ;
: ch>file-type ( ch -- type )
{
{ CHAR: b [ +block-device+ ] }
{ CHAR: c [ +character-device+ ] }
{ CHAR: d [ +directory+ ] }
{ CHAR: l [ +symbolic-link+ ] }
{ CHAR: s [ +socket+ ] }
{ CHAR: p [ +fifo+ ] }
{ CHAR: - [ +regular-file+ ] }
[ drop +unknown+ ]
} case ;
: file-type>ch ( type -- ch )
{
{ +block-device+ [ CHAR: b ] }
{ +character-device+ [ CHAR: c ] }
{ +directory+ [ CHAR: d ] }
{ +symbolic-link+ [ CHAR: l ] }
{ +socket+ [ CHAR: s ] }
{ +fifo+ [ CHAR: p ] }
{ +regular-file+ [ CHAR: - ] }
[ drop CHAR: - ]
} case ;
<PRIVATE
: file-type>executable ( directory-entry -- string )
name>> any-execute? "*" "" ? ;
PRIVATE>
: file-type>trailing ( directory-entry -- string )
dup type>>
{
{ +directory+ [ drop "/" ] }
{ +symbolic-link+ [ drop "@" ] }
{ +fifo+ [ drop "|" ] }
{ +socket+ [ drop "=" ] }
{ +whiteout+ [ drop "%" ] }
{ +unknown+ [ file-type>executable ] }
{ +regular-file+ [ file-type>executable ] }
[ drop file-type>executable ]
} case ;

2
basis/regexp/dfa/dfa.factor
View File

@ -57,7 +57,7 @@ IN: regexp.dfa
dup
[ nfa-table>> final-states>> keys ]
[ dfa-table>> transitions>> states ] bi
[ intersect empty? not ] with filter
[ intersects? ] with filter
swap dfa-table>> final-states>>
[ conjoin ] curry each ;

8
basis/smtp/smtp.factor
View File

@ -68,8 +68,8 @@ ERROR: bad-email-address email ;
: validate-address ( string -- string' )
#! Make sure we send funky stuff to the server by accident.
dup "\r\n>" intersect empty?
[ bad-email-address ] unless ;
dup "\r\n>" intersects?
[ bad-email-address ] when ;
: mail-from ( fromaddr -- )
validate-address
@ -170,8 +170,8 @@ M: plain-auth send-auth
ERROR: invalid-header-string string ;
: validate-header ( string -- string' )
dup "\r\n" intersect empty?
[ invalid-header-string ] unless ;
dup "\r\n" intersects?
[ invalid-header-string ] when ;
: write-header ( key value -- )
[ validate-header write ]

13
basis/sorting/slots/slots-docs.factor
View File

@ -6,17 +6,17 @@ IN: sorting.slots
HELP: compare-slots
{ $values
{ "sort-specs" "a sequence of accessor/comparator pairs" }
{ "sort-specs" "a sequence of accessors ending with a comparator" }
{ "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
}
{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
HELP: sort-by-slots
{ $values
{ "seq" sequence } { "sort-specs" "a sequence of accessor/comparator pairs" }
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
{ "seq'" sequence }
}
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." }
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
{ $examples
"Sort by slot c, then b descending:"
{ $example
@ -32,6 +32,13 @@ HELP: sort-by-slots
}
} ;
HELP: split-by-slots
{ $values
{ "accessor-seqs" "a sequence of sequences of tuple accessors" }
{ "quot" quotation }
}
{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
ARTICLE: "sorting.slots" "Sorting by slots"
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
"Comparing two objects by a sequence of slots:"

105
basis/sorting/slots/slots-tests.factor
View File

@ -1,10 +1,12 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math.order sorting.slots tools.test
sorting.human ;
sorting.human arrays sequences kernel assocs multiline ;
IN: sorting.literals.tests
TUPLE: sort-test a b c ;
TUPLE: sort-test a b c tuple2 ;
TUPLE: tuple2 d ;
[
{
@ -43,8 +45,101 @@ TUPLE: sort-test a b c ;
] unit-test
[
{ }
{
{
T{ sort-test { a 1 } { b 1 } { c 10 } }
T{ sort-test { a 1 } { b 1 } { c 11 } }
}
{ T{ sort-test { a 1 } { b 3 } { c 9 } } }
{
T{ sort-test { a 2 } { b 5 } { c 3 } }
T{ sort-test { a 2 } { b 5 } { c 2 } }
}
}
] [
{ }
{ { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
{
T{ sort-test f 1 3 9 }
T{ sort-test f 1 1 10 }
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
}
{ { a>> human-<=> } { b>> <=> } } [ sort-by-slots ] keep
[ but-last-slice ] map split-by-slots [ >array ] map
] unit-test
: split-test ( seq -- seq' )
{ { a>> } { b>> } } split-by-slots ;
[ split-test ] must-infer
[ { } ]
[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
[
{
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
}
] [
{
T{ sort-test f 6 f f T{ tuple2 f 1 } }
T{ sort-test f 5 f f T{ tuple2 f 4 } }
T{ sort-test f 6 f f T{ tuple2 f 3 } }
T{ sort-test f 6 f f T{ tuple2 f 3 } }
T{ sort-test f 5 f f T{ tuple2 f 3 } }
T{ sort-test f 6 f f T{ tuple2 f 2 } }
} { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots
] unit-test
[
{
{
T{ sort-test
{ a 6 }
{ tuple2 T{ tuple2 { d 1 } } }
}
}
{
T{ sort-test
{ a 6 }
{ tuple2 T{ tuple2 { d 2 } } }
}
}
{
T{ sort-test
{ a 5 }
{ tuple2 T{ tuple2 { d 3 } } }
}
}
{
T{ sort-test
{ a 6 }
{ tuple2 T{ tuple2 { d 3 } } }
}
T{ sort-test
{ a 6 }
{ tuple2 T{ tuple2 { d 3 } } }
}
}
{
T{ sort-test
{ a 5 }
{ tuple2 T{ tuple2 { d 4 } } }
}
}
}
] [
{
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
} { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
] unit-test

21
basis/sorting/slots/slots.factor
View File

@ -1,19 +1,30 @@
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit fry kernel macros math.order
sequences words sorting ;
sequences words sorting sequences.deep assocs splitting.monotonic
math ;
IN: sorting.slots
<PRIVATE
: slot-comparator ( accessor comparator -- quot )
'[ [ _ execute ] bi@ _ execute dup +eq+ eq? [ drop f ] when ] ;
: slot-comparator ( seq -- quot )
[
but-last-slice
[ '[ [ _ execute ] bi@ ] ] map concat
] [
peek
'[ @ _ execute dup +eq+ eq? [ drop f ] when ]
] bi ;
PRIVATE>
MACRO: compare-slots ( sort-specs -- <=> )
#! sort-spec: { accessor comparator }
[ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ;
#! sort-spec: { accessors comparator }
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
: sort-by-slots ( seq sort-specs -- seq' )
'[ _ compare-slots ] sort ;
MACRO: split-by-slots ( accessor-seqs -- quot )
[ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
'[ [ _ 2&& ] slice monotonic-slice ] ;

4
basis/validators/validators.factor
View File

@ -69,8 +69,8 @@ IN: validators
: v-one-line ( str -- str )
v-required
dup "\r\n" intersect empty?
[ "must be a single line" throw ] unless ;
dup "\r\n" intersects?
[ "must be a single line" throw ] when ;
: v-one-word ( str -- str )
v-required

10
core/sets/sets-docs.factor
View File

@ -13,6 +13,8 @@ $nl
{ $subsection diff }
{ $subsection intersect }
{ $subsection union }
"Set-theoretic predicates:"
{ $subsection intersects? }
{ $subsection subset? }
{ $subsection set= }
"A word used to implement the above:"
@ -104,9 +106,15 @@ HELP: union
{ diff intersect union } related-words
HELP: intersects?
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "seq1" } " and " { $snippet "seq2" } " have any elements in common." }
{ $notes "If one of the sequences is empty, the result is always " { $link f } "." } ;
HELP: subset?
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }
{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." } ;
{ $description "Tests if every element of " { $snippet "seq1" } " is contained in " { $snippet "seq2" } "." }
{ $notes "If " { $snippet "seq1" } " is empty, the result is always " { $link t } "." } ;
HELP: set=
{ $values { "seq1" sequence } { "seq2" sequence } { "?" "a boolean" } }

8
core/sets/sets-tests.factor
View File

@ -21,3 +21,11 @@ IN: sets.tests
[ V{ 1 2 3 } ]
[ 3 V{ 1 3 2 } clone [ adjoin ] keep ] unit-test
[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test
[ f ] [ { } { 1 } intersects? ] unit-test
[ f ] [ { 1 } { } intersects? ] unit-test

17
core/sets/sets.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov, Doug Coleman.
! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel sequences vectors ;
IN: sets
@ -31,17 +31,26 @@ IN: sets
: all-unique? ( seq -- ? )
dup length <hashtable> [ (all-unique?) ] curry all? ;
<PRIVATE
: tester ( seq -- quot ) unique [ key? ] curry ; inline
PRIVATE>
: intersect ( seq1 seq2 -- newseq )
unique [ key? ] curry filter ;
tester filter ;
: intersects? ( seq1 seq2 -- ? )
tester contains? ;
: diff ( seq1 seq2 -- newseq )
unique [ key? not ] curry filter ;
tester [ not ] compose filter ;
: union ( seq1 seq2 -- newseq )
append prune ;
: subset? ( seq1 seq2 -- ? )
unique [ key? ] curry all? ;
tester all? ;
: set= ( seq1 seq2 -- ? )
[ unique ] bi@ = ;

6
core/splitting/splitting.factor
View File

@ -48,12 +48,12 @@ IN: splitting
: split ( seq separators -- pieces ) [ split, ] { } make ;
: string-lines ( str -- seq )
dup "\r\n" intersect empty? [
1array
] [
dup "\r\n" intersects? [
"\n" split [
but-last-slice [
"\r" ?tail drop "\r" split
] map
] keep peek "\r" split suffix concat
] [
1array
] if ;

1
extra/fuel/authors.txt
View File

@ -1,2 +1 @@
Jose Antonio Ortega Ruiz
Eduardo Cavazos

5
extra/fuel/fuel.factor
View File

@ -148,6 +148,8 @@ MEMO: fuel-get-article-title ( name -- )
: fuel-word-see ( name -- ) (fuel-word-see) fuel-eval-set-result ;
: fuel-word-def ( name -- ) (fuel-word-def) fuel-eval-set-result ;
: fuel-vocab-help ( name -- ) (fuel-vocab-help) fuel-eval-set-result ;
: fuel-vocab-summary ( name -- )
@ -170,4 +172,5 @@ MEMO: fuel-get-article-title ( name -- )
dup require dup scaffold-help vocab-docs-path
(normalize-path) fuel-eval-set-result ;
: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;
: fuel-scaffold-get-root ( name -- ) find-vocab-root fuel-eval-set-result ;

5
extra/fuel/help/help.factor
View File

@ -87,13 +87,16 @@ SYMBOL: vocab-list
PRIVATE>
: (fuel-word-help) ( object -- object )
: (fuel-word-help) ( name -- elem )
fuel-find-word [ [ auto-use? on (fuel-word-element) ] with-scope ] [ f ] if* ;
: (fuel-word-see) ( word -- elem )
[ name>> \ article swap ]
[ [ see ] with-string-writer \ $code swap 2array ] bi 3array ; inline
: (fuel-word-def) ( name -- str )
fuel-find-word [ [ def>> pprint ] with-string-writer ] when* ; inline
: (fuel-vocab-summary) ( name -- str ) >vocab-link summary ; inline
: (fuel-vocab-help) ( name -- str )

4
extra/webapps/calculator/calculator.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: furnace.actions furnace.redirection
USING: furnace furnace.actions furnace.redirection
http.server.dispatchers html.forms validators urls accessors
math ;
IN: webapps.calculator

2
extra/webapps/calculator/calculator.xml
View File

@ -2,6 +2,7 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html>
<head> <title>Calculator</title> </head>
<body>
@ -24,5 +25,6 @@
</t:form>
</body>
</html>
</t:chloe>

3
extra/webapps/counter/counter.xml
View File

@ -2,12 +2,13 @@
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html>
<body>
<h1><t:label t:name="counter" /></h1>
<t:button t:action="$counter-app/inc">++</t:button>
<t:button t:action="$counter-app/dec">--</t:button>
</body>
</html>
</t:chloe>

10
misc/fuel/README
View File

@ -41,6 +41,12 @@ beast.
To start the listener, try M-x run-factor.
By default, FUEL will try to use the binary and image files in the
factor installation directory. You can customize them with:
(setq fuel-listener-factor-binary <full path to factor>)
(setq fuel-listener-factor-image <full path to factor image>)
Many aspects of the environment can be customized:
M-x customize-group fuel will show you how many.
@ -74,7 +80,8 @@ beast.
- 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 (see fuel-edit-word-method custom var)
- M-, : go back to where M-. was last invoked
- M-TAB : complete word at point
- C-cC-eu : update USING: line
- C-cC-ev : edit vocabulary (M-x fuel-edit-vocabulary)
@ -98,6 +105,7 @@ beast.
- C-cC-xs : extract innermost sexp (up to point) as a separate word
- C-cC-xr : extract region as a separate word
- C-cC-xi : replace word at point by its definition
- C-cC-xv : extract region as a separate vocabulary
*** In the listener:

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

@ -144,8 +144,7 @@ code in the buffer."
(cond ((or (fuel-syntax--at-end-of-def)
(fuel-syntax--at-setter-line))
(fuel-syntax--decreased-indentation))
((and (fuel-syntax--at-begin-of-def)
(not (fuel-syntax--at-using)))
((fuel-syntax--at-begin-of-indent-def)
(fuel-syntax--increased-indentation))
(t (current-indentation)))))

6
misc/fuel/fu.el
View File

@ -8,7 +8,11 @@
;;; Code:
(add-to-list 'load-path (file-name-directory load-file-name))
(setq fuel-factor-fuel-dir (file-name-directory load-file-name))
(setq fuel-factor-root-dir (expand-file-name "../../" fuel-factor-fuel-dir))
(add-to-list 'load-path fuel-factor-fuel-dir)
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
(autoload 'factor-mode "factor-mode.el"

4
misc/fuel/fuel-debug-uses.el
View File

@ -72,7 +72,7 @@
(defvar fuel-debug--uses-restarts nil))
(defsubst fuel-debug--uses-insert-title ()
(insert "Infering USING: stanza for " fuel-debug--uses-file ".\n\n"))
(insert "Inferring USING: stanza for " fuel-debug--uses-file ".\n\n"))
(defun fuel-debug--uses-prepare (file)
(fuel--with-popup (fuel-debug--uses-buffer)
@ -173,7 +173,7 @@
map))
(defconst fuel-debug--uses-header-regex
(format "^%s.*$" (regexp-opt '("Infering USING: stanza for "
(format "^%s.*$" (regexp-opt '("Inferring USING: stanza for "
"Current USING: is already fine!"
"Current vocabulary list:"
"Correct vocabulary list:"

36
misc/fuel/fuel-edit.el
View File

@ -17,6 +17,19 @@
(require 'fuel-eval)
(require 'fuel-base)
(require 'etags)
;;; Customization
(defcustom fuel-edit-word-method nil
"How the new buffer is opened when invoking
\\[fuel-edit-word-at-point]."
:group 'fuel
:type '(choice (const :tag "Other window" window)
(const :tag "Other frame" frame)
(const :tag "Current window" nil)))
;;; Auxiliar functions:
@ -27,7 +40,9 @@
(error "Couldn't find edit location"))
(unless (file-readable-p (car loc))
(error "Couldn't open '%s' for read" (car loc)))
(find-file-other-window (car loc))
(cond ((eq fuel-edit-word-method 'window) (find-file-other-window (car loc)))
((eq fuel-edit-word-method 'frame) (find-file-other-frame (car loc)))
(t (find-file (car loc))))
(goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
(defun fuel-edit--read-vocabulary-name (refresh)
@ -46,6 +61,7 @@
(defvar fuel-edit--word-history nil)
(defvar fuel-edit--vocab-history nil)
(defvar fuel-edit--previous-location nil)
(defun fuel-edit-vocabulary (&optional refresh vocab)
"Visits vocabulary file in Emacs.
@ -74,10 +90,12 @@ With prefix, asks for the word to edit."
(interactive "P")
(let* ((word (or (and (not arg) (fuel-syntax-symbol-at-point))
(fuel-completion--read-word "Edit word: ")))
(cmd `(:fuel* ((:quote ,word) fuel-get-edit-location))))
(cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))
(marker (and (not arg) (point-marker))))
(condition-case nil
(fuel-edit--try-edit (fuel-eval--send/wait cmd))
(error (fuel-edit-vocabulary nil word)))))
(error (fuel-edit-vocabulary nil word)))
(when marker (ring-insert find-tag-marker-ring marker))))
(defun fuel-edit-word-doc-at-point (&optional arg word)
"Opens a new window visiting the documentation file for the word at point.
@ -86,7 +104,8 @@ With prefix, asks for the word to edit."
(let* ((word (or word
(and (not arg) (fuel-syntax-symbol-at-point))
(fuel-completion--read-word "Edit word: ")))
(cmd `(:fuel* ((:quote ,word) fuel-get-doc-location))))
(cmd `(:fuel* ((:quote ,word) fuel-get-doc-location)))
(marker (and (not arg) (point-marker))))
(condition-case nil
(fuel-edit--try-edit (fuel-eval--send/wait cmd))
(error
@ -95,10 +114,19 @@ With prefix, asks for the word to edit."
(y-or-n-p (concat "No documentation found. "
"Do you want to open the vocab's "
"doc file? ")))
(when marker (ring-insert find-tag-marker-ring marker))
(find-file-other-window
(format "%s-docs.factor"
(file-name-sans-extension (buffer-file-name)))))))))
(defun fuel-edit-pop-edit-word-stack ()
"Pop back to where \\[fuel-edit-word-at-point] or \\[fuel-edit-word-doc-at-point]
was last invoked."
(interactive)
(condition-case nil
(pop-tag-mark)
(error "No previous location for find word or vocab invokation")))
(provide 'fuel-edit)
;;; fuel-edit.el ends here

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

@ -66,16 +66,17 @@
(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")))
(word function-name "word, generic or method being defined")
(invalid-syntax warning "syntactically invalid constructs")))
;;; Font lock:
(defconst fuel-font-lock--font-lock-keywords
`((,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)
`((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
(,fuel-syntax--parsing-words-regex . 'factor-font-lock-parsing-word)
(,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
(,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
(,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name)
(,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration)
(,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
@ -92,8 +93,8 @@
(,fuel-syntax--constructor-regex . 'factor-font-lock-constructor)
(,fuel-syntax--setter-regex . 'factor-font-lock-setter-word)
(,fuel-syntax--getter-regex . 'factor-font-lock-getter-word)
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol))
"Font lock keywords definition for Factor mode.")
(,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)
(,fuel-syntax--bad-string-regex . 'factor-font-lock-invalid-syntax)))
(defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax)
(set (make-local-variable 'comment-start) "! ")

6
misc/fuel/fuel-listener.el
View File

@ -30,12 +30,14 @@
"Interacting with a Factor listener inside Emacs."
:group 'fuel)
(defcustom fuel-listener-factor-binary "~/factor/factor"
(defcustom fuel-listener-factor-binary
(expand-file-name "factor" fuel-factor-root-dir)
"Full path to the factor executable to use when starting a listener."
:type '(file :must-match t)
:group 'fuel-listener)
(defcustom fuel-listener-factor-image "~/factor/factor.image"
(defcustom fuel-listener-factor-image
(expand-file-name "factor.image" fuel-factor-root-dir)
"Full path to the factor image to use when starting a listener."
:type '(file :must-match t)
:group 'fuel-listener)

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

@ -181,6 +181,7 @@ interacting with a factor listener is at your disposal.
(define-key fuel-mode-map "\C-\M-x" 'fuel-eval-definition)
(define-key fuel-mode-map "\C-\M-r" 'fuel-eval-extended-region)
(define-key fuel-mode-map "\M-." 'fuel-edit-word-at-point)
(define-key fuel-mode-map "\M-," 'fuel-edit-pop-edit-word-stack)
(define-key fuel-mode-map "\C-c\M-<" 'fuel-show-callers)
(define-key fuel-mode-map "\C-c\M->" 'fuel-show-callees)
(define-key fuel-mode-map (kbd "M-TAB") 'fuel-completion--complete-symbol)
@ -197,6 +198,7 @@ interacting with a factor listener is at your disposal.
(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp)
(fuel-mode--key ?x ?r 'fuel-refactor-extract-region)
(fuel-mode--key ?x ?v 'fuel-refactor-extract-vocab)
(fuel-mode--key ?x ?i 'fuel-refactor-inline-word)
(fuel-mode--key ?d ?> 'fuel-show-callees)
(fuel-mode--key ?d ?< 'fuel-show-callers)

137
misc/fuel/fuel-refactor.el
View File

@ -18,36 +18,106 @@
(require 'fuel-syntax)
(require 'fuel-base)
;;; Word definitions in buffer
(defconst fuel-refactor--next-defun-regex
(format "^\\(:\\|MEMO:\\|MACRO:\\):? +\\(\\w+\\)\\(%s\\)\\([^;]+?\\) ;\\_>"
fuel-syntax--stack-effect-regex))
(defun fuel-refactor--previous-defun ()
(let ((pos) (result))
(while (and (not result)
(setq pos (fuel-syntax--beginning-of-defun)))
(setq result (looking-at fuel-refactor--next-defun-regex)))
(when (and result pos)
(let ((name (match-string-no-properties 2))
(body (match-string-no-properties 4))
(end (match-end 0)))
(list (split-string body nil t) name pos end)))))
(defun fuel-refactor--find (code to)
(let ((candidate) (result))
(while (and (not result)
(setq candidate (fuel-refactor--previous-defun))
(> (point) to))
(when (equal (car candidate) code)
(setq result (cdr candidate))))
result))
(defun fuel-refactor--reuse-p (word)
(save-excursion
(mark-defun)
(move-overlay fuel-stack--overlay (1+ (point)) (mark))
(unwind-protect
(and (y-or-n-p (format "Use existing word '%s'? " word)) word)
(delete-overlay fuel-stack--overlay))))
(defun fuel-refactor--code-rx (code)
(let ((words (split-string code nil t)))
(mapconcat 'regexp-quote words "[ \n\f\r]+")))
;;; Extract word:
(defun fuel-refactor--reuse-existing (code)
(save-excursion
(mark-defun)
(let ((code (split-string (substring-no-properties code) nil t))
(down (mark))
(found)
(result))
(while (and (not result)
(setq found (fuel-refactor--find code (point-min))))
(when found (setq result (fuel-refactor--reuse-p (car found)))))
(goto-char (point-max))
(while (and (not result)
(setq found (fuel-refactor--find code down)))
(when found (setq result (fuel-refactor--reuse-p (car found)))))
(and result found))))
(defun fuel-refactor--insert-word (word stack-effect code)
(let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point)))
(end (save-excursion
(re-search-backward fuel-syntax--end-of-def-regex nil t)
(forward-line 1)
(skip-syntax-forward "-"))))
(let ((start (goto-char (max beg end))))
(open-line 1)
(insert ": " word " " stack-effect "\n" code " ;\n")
(indent-region start (point))
(move-overlay fuel-stack--overlay start (point)))))
(defun fuel-refactor--extract-other (start end code)
(unwind-protect
(when (y-or-n-p "Apply refactoring to rest of buffer? ")
(save-excursion
(let ((rx (fuel-refactor--code-rx code))
(end (point)))
(query-replace-regexp rx word t (point-min) start)
(query-replace-regexp rx word t end (point-max)))))
(delete-overlay fuel-stack--overlay)))
(defun fuel-refactor--extract (begin end)
(let* ((word (read-string "New word name: "))
(code (buffer-substring begin end))
(code-str (fuel--region-to-string begin end))
(stack-effect (or (fuel-stack--infer-effect code-str)
(read-string "Stack effect: "))))
(unless (< begin end) (error "No proper region to extract"))
(unless (< begin end) (error "No proper region to extract"))
(let* ((code (buffer-substring begin end))
(existing (fuel-refactor--reuse-existing code))
(code-str (or existing (fuel--region-to-string begin end)))
(stack-effect (or existing
(fuel-stack--infer-effect code-str)
(read-string "Stack effect: ")))
(word (or (car existing) (read-string "New word name: "))))
(goto-char begin)
(delete-region begin end)
(insert word)
(indent-region begin (point))
(set-mark (point))
(let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point)))
(end (save-excursion
(re-search-backward fuel-syntax--end-of-def-regex nil t)
(forward-line 1)
(skip-syntax-forward "-")
(point))))
(goto-char (max beg end)))
(open-line 1)
(let ((start (point)))
(insert ": " word " " stack-effect "\n" code " ;\n")
(indent-region start (point))
(move-overlay fuel-stack--overlay start (point))
(goto-char (mark))
(sit-for fuel-stack-highlight-period)
(delete-overlay fuel-stack--overlay))))
(save-excursion
(let ((start (or (cadr existing) (point))))
(unless existing
(fuel-refactor--insert-word word stack-effect code))
(fuel-refactor--extract-other start
(or (car (cddr existing)) (point))
code)))))
(defun fuel-refactor-extract-region (begin end)
"Extracts current region as a separate word."
@ -71,6 +141,29 @@ word."
(if (looking-at-p ";") (point)
(fuel-syntax--end-of-symbol-pos))))
;;; Inline word:
(defun fuel-refactor--word-def (word)
(let ((def (fuel-eval--retort-result
(fuel-eval--send/wait `(:fuel* (,word fuel-word-def) "fuel")))))
(when def
(substring (substring def 2) 0 -2))))
(defun fuel-refactor-inline-word ()
"Inserts definition of word at point."
(interactive)
(let ((word (fuel-syntax-symbol-at-point)))
(unless word (error "No word at point"))
(let ((code (fuel-refactor--word-def word)))
(unless code (error "Word's definition not found"))
(fuel-syntax--beginning-of-symbol)
(kill-word 1)
(let ((start (point)))
(insert code)
(save-excursion (font-lock-fontify-region start (point)))
(indent-region start (point))))))
;;; Extract vocab:

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

@ -93,6 +93,9 @@
(defconst fuel-syntax--float-regex
"\\_<-?[0-9]+\\.[0-9]*\\([eE][+-]?[0-9]+\\)?\\_>")
(defconst fuel-syntax--bad-string-regex
"\"[^\"]*$")
(defconst fuel-syntax--word-definition-regex
(fuel-syntax--second-word-regex
'(":" "::" "GENERIC:" "DEFER:" "HOOK:" "MAIN:" "MATH:" "POSTPONE:"
@ -132,16 +135,28 @@
(defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
(defconst fuel-syntax--indent-def-starts '("" ":"
"FROM"
"INTERSECTION:"
"M" "MACRO" "MACRO:"
"MEMO" "MEMO:" "METHOD"
"PREDICATE" "PRIMITIVE"
"UNION"))
(defconst fuel-syntax--no-indent-def-starts '("SINGLETONS"
"SYMBOLS"
"TUPLE"
"VARS"))
(defconst fuel-syntax--indent-def-start-regex
(format "^\\(%s:\\) " (regexp-opt fuel-syntax--indent-def-starts)))
(defconst fuel-syntax--no-indent-def-start-regex
(format "^\\(%s:\\) " (regexp-opt fuel-syntax--no-indent-def-starts)))
(defconst fuel-syntax--definition-start-regex
(format "^\\(%s:\\) " (regexp-opt '("" ":"
"FROM"
"INTERSECTION:"
"MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD"
"PREDICATE" "PRIMITIVE"
"SINGLETONS" "SYMBOLS"
"TUPLE"
"UNION"
"VARS"))))
(format "^\\(%s:\\) " (regexp-opt (append fuel-syntax--no-indent-def-starts
fuel-syntax--indent-def-starts))))
(defconst fuel-syntax--definition-end-regex
(format "\\(\\(^\\| +\\);\\( *%s\\)*\\($\\| +\\)\\)"
@ -199,8 +214,7 @@
(modify-syntax-entry ?\ " " table)
(modify-syntax-entry ?\n " " table)
;; Strings
(modify-syntax-entry ?\" "\"" table)
;; Char quote
(modify-syntax-entry ?\\ "/" table)
table))
@ -211,6 +225,8 @@
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
;; CHARs:
("CHAR: \\(.\\)\\( \\|$\\)" (1 "w"))
;; Strings
("\\(\"\\)[^\n\r\f]*\\(\"\\)" (1 "\"") (2 "\""))
;; Let and lambda:
("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))
("\\(\\[\\)\\(let\\|wlet\\|let\\*\\)\\( \\|$\\)" (1 "(]"))
@ -256,6 +272,9 @@
(defsubst fuel-syntax--at-begin-of-def ()
(looking-at fuel-syntax--begin-of-def-regex))
(defsubst fuel-syntax--at-begin-of-indent-def ()
(looking-at fuel-syntax--indent-def-start-regex))
(defsubst fuel-syntax--at-end-of-def ()
(looking-at fuel-syntax--end-of-def-regex))