Merge branch 'master' of git://factorcode.org/git/factor
commit
5114cdb03f
|
@ -542,3 +542,15 @@ TUPLE: another-forget-accessors-test ;
|
||||||
|
|
||||||
! Missing error check
|
! Missing error check
|
||||||
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
|
[ "IN: tuples.test USE: words TUPLE: wrong-superclass < word ;" eval ] must-fail
|
||||||
|
|
||||||
|
TUPLE: subclass-forget-test ;
|
||||||
|
|
||||||
|
TUPLE: subclass-forget-test-1 < subclass-forget-test ;
|
||||||
|
TUPLE: subclass-forget-test-2 < subclass-forget-test ;
|
||||||
|
TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
|
||||||
|
|
||||||
|
[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval ] unit-test
|
||||||
|
|
||||||
|
[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
|
||||||
|
[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
|
||||||
|
[ subclass-forget-test-3 new ] must-fail
|
||||||
|
|
|
@ -81,13 +81,9 @@ HELP: print-error
|
||||||
HELP: restarts.
|
HELP: restarts.
|
||||||
{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
|
{ $description "Print a list of restarts for the most recently thrown error to " { $link output-stream } "." } ;
|
||||||
|
|
||||||
HELP: error-hook
|
|
||||||
{ $var-description "A quotation with stack effect " { $snippet "( error -- )" } " which is used by " { $link try } " to report the error to the user." }
|
|
||||||
{ $examples "The default value prints the error with " { $link print-error } ", followed by a list of restarts and a help message. The graphical listener sets this variable to display a popup instead." } ;
|
|
||||||
|
|
||||||
HELP: try
|
HELP: try
|
||||||
{ $values { "quot" "a quotation" } }
|
{ $values { "quot" "a quotation" } }
|
||||||
{ $description "Attempts to call a quotation; if it throws an error, the " { $link error-hook } " gets called, stacks are restored, and execution continues after the call to " { $link try } "." }
|
{ $description "Attempts to call a quotation; if it throws an error, the error is printed to " { $link output-stream } ", stacks are restored, and execution continues after the call to " { $link try } "." }
|
||||||
{ $examples
|
{ $examples
|
||||||
"The following example prints an error and keeps going:"
|
"The following example prints an error and keeps going:"
|
||||||
{ $code
|
{ $code
|
||||||
|
|
|
@ -64,13 +64,14 @@ M: string error. print ;
|
||||||
[ global [ "Error in print-error!" print drop ] bind ]
|
[ global [ "Error in print-error!" print drop ] bind ]
|
||||||
recover ;
|
recover ;
|
||||||
|
|
||||||
|
: print-error-and-restarts ( error -- )
|
||||||
|
print-error
|
||||||
|
restarts.
|
||||||
|
nl
|
||||||
|
"Type :help for debugging help." print flush ;
|
||||||
|
|
||||||
: try ( quot -- )
|
: try ( quot -- )
|
||||||
[
|
[ print-error-and-restarts ] recover ;
|
||||||
print-error
|
|
||||||
restarts.
|
|
||||||
nl
|
|
||||||
"Type :help for debugging help." print flush
|
|
||||||
] recover ;
|
|
||||||
|
|
||||||
ERROR: assert got expect ;
|
ERROR: assert got expect ;
|
||||||
|
|
||||||
|
@ -269,8 +270,7 @@ M: double-free summary
|
||||||
M: realloc-error summary
|
M: realloc-error summary
|
||||||
drop "Memory reallocation failed" ;
|
drop "Memory reallocation failed" ;
|
||||||
|
|
||||||
: error-in-thread. ( -- )
|
: error-in-thread. ( thread -- )
|
||||||
error-thread get-global
|
|
||||||
"Error in thread " write
|
"Error in thread " write
|
||||||
[
|
[
|
||||||
dup thread-id #
|
dup thread-id #
|
||||||
|
@ -284,7 +284,7 @@ M: thread error-in-thread ( error thread -- )
|
||||||
die drop
|
die drop
|
||||||
] [
|
] [
|
||||||
global [
|
global [
|
||||||
error-in-thread. print-error flush
|
error-thread get-global error-in-thread. print-error flush
|
||||||
] bind
|
] bind
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
|
|
|
@ -45,6 +45,8 @@ M: object stream-read-quot
|
||||||
|
|
||||||
SYMBOL: error-hook
|
SYMBOL: error-hook
|
||||||
|
|
||||||
|
[ print-error-and-restarts ] error-hook set-global
|
||||||
|
|
||||||
: listen ( -- )
|
: listen ( -- )
|
||||||
listener-hook get call prompt.
|
listener-hook get call prompt.
|
||||||
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
|
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
|
||||||
|
|
|
@ -1,5 +1,6 @@
|
||||||
USING: namespaces io tools.test threads kernel
|
USING: namespaces io tools.test threads kernel
|
||||||
concurrency.combinators math ;
|
concurrency.combinators concurrency.promises locals math
|
||||||
|
words ;
|
||||||
IN: threads.tests
|
IN: threads.tests
|
||||||
|
|
||||||
3 "x" set
|
3 "x" set
|
||||||
|
@ -27,3 +28,16 @@ yield
|
||||||
"i" tget
|
"i" tget
|
||||||
] parallel-map
|
] parallel-map
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ [ 3 throw ] "A" suspend ] [ 3 = ] must-fail-with
|
||||||
|
|
||||||
|
:: spawn-namespace-test ( -- )
|
||||||
|
[let | p [ <promise> ] g [ gensym ] |
|
||||||
|
[
|
||||||
|
g "x" set
|
||||||
|
[ "x" get p fulfill ] "B" spawn drop
|
||||||
|
] with-scope
|
||||||
|
p ?promise g eq?
|
||||||
|
] ;
|
||||||
|
|
||||||
|
[ t ] [ spawn-namespace-test ] unit-test
|
||||||
|
|
|
@ -91,6 +91,8 @@ PRIVATE>
|
||||||
[ sleep-queue heap-peek nip millis [-] ]
|
[ sleep-queue heap-peek nip millis [-] ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
|
DEFER: stop
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: schedule-sleep ( thread dt -- )
|
: schedule-sleep ( thread dt -- )
|
||||||
|
@ -111,36 +113,54 @@ PRIVATE>
|
||||||
[ ] while
|
[ ] while
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
|
: start ( namestack thread -- )
|
||||||
|
[
|
||||||
|
set-self
|
||||||
|
set-namestack
|
||||||
|
V{ } set-catchstack
|
||||||
|
{ } set-retainstack
|
||||||
|
{ } set-datastack
|
||||||
|
self quot>> [ call stop ] call-clear
|
||||||
|
] 2 (throw) ;
|
||||||
|
|
||||||
|
DEFER: next
|
||||||
|
|
||||||
|
: no-runnable-threads ( -- * )
|
||||||
|
! We should never be in a state where the only threads
|
||||||
|
! are sleeping; the I/O wait thread is always runnable.
|
||||||
|
! However, if it dies, we handle this case
|
||||||
|
! semi-gracefully.
|
||||||
|
!
|
||||||
|
! And if sleep-time outputs f, there are no sleeping
|
||||||
|
! threads either... so WTF.
|
||||||
|
sleep-time [ die 0 ] unless* (sleep) next ;
|
||||||
|
|
||||||
|
: (next) ( arg thread -- * )
|
||||||
|
f >>state
|
||||||
|
dup set-self
|
||||||
|
dup continuation>> ?box
|
||||||
|
[ nip continue-with ] [ drop start ] if ;
|
||||||
|
|
||||||
: next ( -- * )
|
: next ( -- * )
|
||||||
expire-sleep-loop
|
expire-sleep-loop
|
||||||
run-queue dup dlist-empty? [
|
run-queue dup dlist-empty? [
|
||||||
! We should never be in a state where the only threads
|
drop no-runnable-threads
|
||||||
! are sleeping; the I/O wait thread is always runnable.
|
|
||||||
! However, if it dies, we handle this case
|
|
||||||
! semi-gracefully.
|
|
||||||
!
|
|
||||||
! And if sleep-time outputs f, there are no sleeping
|
|
||||||
! threads either... so WTF.
|
|
||||||
drop sleep-time [ die 0 ] unless* (sleep) next
|
|
||||||
] [
|
] [
|
||||||
pop-back
|
pop-back dup array? [ first2 ] [ f swap ] if (next)
|
||||||
dup array? [ first2 ] [ f swap ] if dup set-self
|
|
||||||
f >>state
|
|
||||||
continuation>> box>
|
|
||||||
continue-with
|
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: stop ( -- )
|
: stop ( -- )
|
||||||
self dup exit-handler>> call
|
self [ exit-handler>> call ] [ unregister-thread ] bi next ;
|
||||||
unregister-thread next ;
|
|
||||||
|
|
||||||
: suspend ( quot state -- obj )
|
: suspend ( quot state -- obj )
|
||||||
[
|
[
|
||||||
self continuation>> >box
|
>r
|
||||||
self (>>state)
|
>r self swap call
|
||||||
self swap call next
|
r> self (>>state)
|
||||||
|
r> self continuation>> >box
|
||||||
|
next
|
||||||
] callcc1 2nip ; inline
|
] callcc1 2nip ; inline
|
||||||
|
|
||||||
: yield ( -- ) [ resume ] f suspend drop ;
|
: yield ( -- ) [ resume ] f suspend drop ;
|
||||||
|
@ -166,16 +186,7 @@ M: real sleep
|
||||||
] when drop ;
|
] when drop ;
|
||||||
|
|
||||||
: (spawn) ( thread -- )
|
: (spawn) ( thread -- )
|
||||||
[
|
[ register-thread ] [ namestack swap resume-with ] bi ;
|
||||||
resume-now [
|
|
||||||
dup set-self
|
|
||||||
dup register-thread
|
|
||||||
V{ } set-catchstack
|
|
||||||
{ } set-retainstack
|
|
||||||
>r { } set-datastack r>
|
|
||||||
quot>> [ call stop ] call-clear
|
|
||||||
] 1 (throw)
|
|
||||||
] "spawn" suspend 2drop ;
|
|
||||||
|
|
||||||
: spawn ( quot name -- thread )
|
: spawn ( quot name -- thread )
|
||||||
<thread> [ (spawn) ] keep ;
|
<thread> [ (spawn) ] keep ;
|
||||||
|
@ -184,8 +195,8 @@ M: real sleep
|
||||||
>r [ [ ] [ ] while ] curry r> spawn ;
|
>r [ [ ] [ ] while ] curry r> spawn ;
|
||||||
|
|
||||||
: in-thread ( quot -- )
|
: in-thread ( quot -- )
|
||||||
>r datastack namestack r>
|
>r datastack r>
|
||||||
[ >r set-namestack set-datastack r> call ] 3curry
|
[ >r set-datastack r> call ] 2curry
|
||||||
"Thread" spawn drop ;
|
"Thread" spawn drop ;
|
||||||
|
|
||||||
GENERIC: error-in-thread ( error thread -- )
|
GENERIC: error-in-thread ( error thread -- )
|
||||||
|
|
|
@ -6,11 +6,21 @@ HELP: parallel-map
|
||||||
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
|
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the results at the end." }
|
||||||
{ $errors "Throws an error if one of the iterations throws an error." } ;
|
{ $errors "Throws an error if one of the iterations throws an error." } ;
|
||||||
|
|
||||||
|
HELP: 2parallel-map
|
||||||
|
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- newelt )" } } { "newseq" sequence } }
|
||||||
|
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", collecting the results at the end." }
|
||||||
|
{ $errors "Throws an error if one of the iterations throws an error." } ;
|
||||||
|
|
||||||
HELP: parallel-each
|
HELP: parallel-each
|
||||||
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
|
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
|
||||||
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
|
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", blocking until all quotations complete." }
|
||||||
{ $errors "Throws an error if one of the iterations throws an error." } ;
|
{ $errors "Throws an error if one of the iterations throws an error." } ;
|
||||||
|
|
||||||
|
HELP: 2parallel-each
|
||||||
|
{ $values { "seq1" sequence } { "seq2" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- )" } } }
|
||||||
|
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to pairwise elements of " { $snippet "seq1" } " and " { $snippet "seq2" } ", blocking until all quotations complete." }
|
||||||
|
{ $errors "Throws an error if one of the iterations throws an error." } ;
|
||||||
|
|
||||||
HELP: parallel-filter
|
HELP: parallel-filter
|
||||||
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } }
|
{ $values { "seq" sequence } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "newseq" sequence } }
|
||||||
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
|
{ $description "Spawns a new thread for applying " { $snippet "quot" } " to every element of " { $snippet "seq" } ", collecting the elements for which the quotation yielded a true value." }
|
||||||
|
@ -19,7 +29,9 @@ HELP: parallel-filter
|
||||||
ARTICLE: "concurrency.combinators" "Concurrent combinators"
|
ARTICLE: "concurrency.combinators" "Concurrent combinators"
|
||||||
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"
|
"The " { $vocab-link "concurrency.combinators" } " vocabulary provides concurrent variants of " { $link each } ", " { $link map } " and " { $link filter } ":"
|
||||||
{ $subsection parallel-each }
|
{ $subsection parallel-each }
|
||||||
|
{ $subsection 2parallel-each }
|
||||||
{ $subsection parallel-map }
|
{ $subsection parallel-map }
|
||||||
|
{ $subsection 2parallel-map }
|
||||||
{ $subsection parallel-filter } ;
|
{ $subsection parallel-filter } ;
|
||||||
|
|
||||||
ABOUT: "concurrency.combinators"
|
ABOUT: "concurrency.combinators"
|
||||||
|
|
|
@ -1,9 +1,11 @@
|
||||||
IN: concurrency.combinators.tests
|
IN: concurrency.combinators.tests
|
||||||
USING: concurrency.combinators tools.test random kernel math
|
USING: concurrency.combinators tools.test random kernel math
|
||||||
concurrency.mailboxes threads sequences accessors ;
|
concurrency.mailboxes threads sequences accessors arrays ;
|
||||||
|
|
||||||
[ [ drop ] parallel-each ] must-infer
|
[ [ drop ] parallel-each ] must-infer
|
||||||
|
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
|
||||||
[ [ ] parallel-map ] must-infer
|
[ [ ] parallel-map ] must-infer
|
||||||
|
{ 2 1 } [ [ 2array ] 2parallel-map ] must-infer-as
|
||||||
[ [ ] parallel-filter ] must-infer
|
[ [ ] parallel-filter ] must-infer
|
||||||
|
|
||||||
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
|
[ { 1 4 9 } ] [ { 1 2 3 } [ sq ] parallel-map ] unit-test
|
||||||
|
@ -22,3 +24,24 @@ concurrency.mailboxes threads sequences accessors ;
|
||||||
10 over [ push ] curry parallel-each
|
10 over [ push ] curry parallel-each
|
||||||
length
|
length
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ { 10 20 30 } ] [
|
||||||
|
{ 1 4 3 } { 10 5 10 } [ * ] 2parallel-map
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ { -9 -1 -7 } ] [
|
||||||
|
{ 1 4 3 } { 10 5 10 } [ - ] 2parallel-map
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
{ 1 4 3 } { 1 0 1 } [ / drop ] 2parallel-each
|
||||||
|
] must-fail
|
||||||
|
|
||||||
|
[ 20 ]
|
||||||
|
[
|
||||||
|
V{ } clone
|
||||||
|
10 10 pick [ [ push ] [ push ] bi ] curry 2parallel-each
|
||||||
|
length
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ { f } [ "OOPS" throw ] parallel-each ] must-fail
|
||||||
|
|
|
@ -4,14 +4,27 @@ USING: concurrency.futures concurrency.count-downs sequences
|
||||||
kernel ;
|
kernel ;
|
||||||
IN: concurrency.combinators
|
IN: concurrency.combinators
|
||||||
|
|
||||||
: parallel-map ( seq quot -- newseq )
|
: (parallel-each) ( n quot -- )
|
||||||
[ curry future ] curry map dup [ ?future ] change-each ;
|
>r <count-down> r> keep await ; inline
|
||||||
inline
|
|
||||||
|
|
||||||
: parallel-each ( seq quot -- )
|
: parallel-each ( seq quot -- )
|
||||||
over length <count-down>
|
over length [
|
||||||
[ [ >r curry r> spawn-stage ] 2curry each ] keep await ;
|
[ >r curry r> spawn-stage ] 2curry each
|
||||||
inline
|
] (parallel-each) ; inline
|
||||||
|
|
||||||
|
: 2parallel-each ( seq1 seq2 quot -- )
|
||||||
|
2over min-length [
|
||||||
|
[ >r 2curry r> spawn-stage ] 2curry 2each
|
||||||
|
] (parallel-each) ; inline
|
||||||
|
|
||||||
: parallel-filter ( seq quot -- newseq )
|
: parallel-filter ( seq quot -- newseq )
|
||||||
over >r pusher >r each r> r> like ; inline
|
over >r pusher >r each r> r> like ; inline
|
||||||
|
|
||||||
|
: future-values dup [ ?future ] change-each ; inline
|
||||||
|
|
||||||
|
: parallel-map ( seq quot -- newseq )
|
||||||
|
[ curry future ] curry map future-values ;
|
||||||
|
inline
|
||||||
|
|
||||||
|
: 2parallel-map ( seq1 seq2 quot -- newseq )
|
||||||
|
[ 2curry future ] curry 2map future-values ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: dlists kernel math concurrency.promises
|
USING: dlists kernel math concurrency.promises
|
||||||
concurrency.mailboxes ;
|
concurrency.mailboxes debugger accessors ;
|
||||||
IN: concurrency.count-downs
|
IN: concurrency.count-downs
|
||||||
|
|
||||||
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
|
! http://java.sun.com/j2se/1.5.0/docs/api/java/util/concurrent/CountDownLatch.html
|
||||||
|
@ -9,9 +9,7 @@ IN: concurrency.count-downs
|
||||||
TUPLE: count-down n promise ;
|
TUPLE: count-down n promise ;
|
||||||
|
|
||||||
: count-down-check ( count-down -- )
|
: count-down-check ( count-down -- )
|
||||||
dup count-down-n zero? [
|
dup n>> zero? [ t swap promise>> fulfill ] [ drop ] if ;
|
||||||
t swap count-down-promise fulfill
|
|
||||||
] [ drop ] if ;
|
|
||||||
|
|
||||||
: <count-down> ( n -- count-down )
|
: <count-down> ( n -- count-down )
|
||||||
dup 0 < [ "Invalid count for count down" throw ] when
|
dup 0 < [ "Invalid count for count down" throw ] when
|
||||||
|
@ -19,15 +17,12 @@ TUPLE: count-down n promise ;
|
||||||
dup count-down-check ;
|
dup count-down-check ;
|
||||||
|
|
||||||
: count-down ( count-down -- )
|
: count-down ( count-down -- )
|
||||||
dup count-down-n dup zero? [
|
dup n>> dup zero?
|
||||||
"Count down already done" throw
|
[ "Count down already done" throw ]
|
||||||
] [
|
[ 1- >>n count-down-check ] if ;
|
||||||
1- over set-count-down-n
|
|
||||||
count-down-check
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: await-timeout ( count-down timeout -- )
|
: await-timeout ( count-down timeout -- )
|
||||||
>r count-down-promise r> ?promise-timeout drop ;
|
>r promise>> r> ?promise-timeout ?linked t assert= ;
|
||||||
|
|
||||||
: await ( count-down -- )
|
: await ( count-down -- )
|
||||||
f await-timeout ;
|
f await-timeout ;
|
||||||
|
@ -35,5 +30,4 @@ TUPLE: count-down n promise ;
|
||||||
: spawn-stage ( quot count-down -- )
|
: spawn-stage ( quot count-down -- )
|
||||||
[ [ count-down ] curry compose ] keep
|
[ [ count-down ] curry compose ] keep
|
||||||
"Count down stage"
|
"Count down stage"
|
||||||
swap count-down-promise
|
swap promise>> mailbox>> spawn-linked-to drop ;
|
||||||
promise-mailbox spawn-linked-to drop ;
|
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
IN: concurrency.mailboxes
|
IN: concurrency.mailboxes
|
||||||
USING: dlists threads sequences continuations
|
USING: dlists threads sequences continuations
|
||||||
namespaces random math quotations words kernel arrays assocs
|
namespaces random math quotations words kernel arrays assocs
|
||||||
init system concurrency.conditions accessors ;
|
init system concurrency.conditions accessors debugger ;
|
||||||
|
|
||||||
TUPLE: mailbox threads data closed ;
|
TUPLE: mailbox threads data closed ;
|
||||||
|
|
||||||
|
@ -83,6 +83,9 @@ M: mailbox dispose
|
||||||
|
|
||||||
TUPLE: linked-error error thread ;
|
TUPLE: linked-error error thread ;
|
||||||
|
|
||||||
|
M: linked-error error.
|
||||||
|
[ thread>> error-in-thread. ] [ error>> error. ] bi ;
|
||||||
|
|
||||||
C: <linked-error> linked-error
|
C: <linked-error> linked-error
|
||||||
|
|
||||||
: ?linked dup linked-error? [ rethrow ] when ;
|
: ?linked dup linked-error? [ rethrow ] when ;
|
||||||
|
|
|
@ -11,3 +11,8 @@ SYMBOL: test
|
||||||
[ 2 ] [ 1 test get interval-at ] unit-test
|
[ 2 ] [ 1 test get interval-at ] unit-test
|
||||||
[ f ] [ 2 test get interval-at ] unit-test
|
[ f ] [ 2 test get interval-at ] unit-test
|
||||||
[ f ] [ 0 test get interval-at ] unit-test
|
[ f ] [ 0 test get interval-at ] unit-test
|
||||||
|
|
||||||
|
[ { { { 1 4 } 3 } { { 4 8 } 6 } } <interval-map> ] must-fail
|
||||||
|
|
||||||
|
[ { { { 1 3 } 2 } { { 4 5 } 4 } { { 7 8 } 4 } } ]
|
||||||
|
[ { { 1 2 } { 2 2 } { 3 2 } { 4 4 } { 5 4 } { 7 4 } { 8 4 } } coalesce ] unit-test
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
USING: kernel sequences arrays math.intervals accessors
|
USING: kernel sequences arrays math.intervals accessors
|
||||||
math.order sorting math assocs ;
|
math.order sorting math assocs locals namespaces ;
|
||||||
IN: interval-maps
|
IN: interval-maps
|
||||||
|
|
||||||
TUPLE: interval-map array ;
|
TUPLE: interval-map array ;
|
||||||
|
@ -24,6 +24,8 @@ M: interval >interval ;
|
||||||
: ensure-disjoint ( intervals -- intervals )
|
: ensure-disjoint ( intervals -- intervals )
|
||||||
dup keys [ interval-intersect not ] monotonic?
|
dup keys [ interval-intersect not ] monotonic?
|
||||||
[ "Intervals are not disjoint" throw ] unless ;
|
[ "Intervals are not disjoint" throw ] unless ;
|
||||||
|
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: interval-at* ( key map -- value ? )
|
: interval-at* ( key map -- value ? )
|
||||||
|
@ -35,7 +37,20 @@ PRIVATE>
|
||||||
: interval-key? ( key map -- ? ) interval-at* nip ;
|
: interval-key? ( key map -- ? ) interval-at* nip ;
|
||||||
|
|
||||||
: <interval-map> ( specification -- map )
|
: <interval-map> ( specification -- map )
|
||||||
all-intervals ensure-disjoint
|
all-intervals { } assoc-like
|
||||||
[ [ first to>> ] compare ] sort
|
[ [ first to>> ] compare ] sort ensure-disjoint
|
||||||
[ interval-node boa ] { } assoc>map
|
[ interval-node boa ] { } assoc>map
|
||||||
interval-map boa ;
|
interval-map boa ;
|
||||||
|
|
||||||
|
:: coalesce ( alist -- specification )
|
||||||
|
! Only works with integer keys, because they're discrete
|
||||||
|
! Makes 2array keys
|
||||||
|
[
|
||||||
|
alist sort-keys unclip first2 dupd roll
|
||||||
|
[| oldkey oldval key val | ! Underneath is start
|
||||||
|
oldkey 1+ key =
|
||||||
|
oldval val = and
|
||||||
|
[ oldkey 2array oldval 2array , key ] unless
|
||||||
|
key val
|
||||||
|
] assoc-each [ 2array ] bi@ ,
|
||||||
|
] { } make ;
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io io.backend io.timeouts io.pipes system kernel
|
USING: system kernel namespaces strings hashtables sequences
|
||||||
namespaces strings hashtables sequences assocs combinators
|
assocs combinators vocabs.loader init threads continuations
|
||||||
vocabs.loader init threads continuations math io.encodings
|
math accessors concurrency.flags destructors
|
||||||
io.streams.duplex io.nonblocking io.streams.duplex accessors
|
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
|
||||||
concurrency.flags destructors ;
|
io.streams.duplex io.nonblocking ;
|
||||||
IN: io.launcher
|
IN: io.launcher
|
||||||
|
|
||||||
TUPLE: process < identity-tuple
|
TUPLE: process < identity-tuple
|
||||||
|
@ -149,15 +149,11 @@ M: process set-timeout set-process-timeout ;
|
||||||
|
|
||||||
M: process timed-out kill-process ;
|
M: process timed-out kill-process ;
|
||||||
|
|
||||||
M: object pipeline-element-quot
|
M: object run-pipeline-element
|
||||||
[
|
[ >process swap >>stdout swap >>stdin run-detached ]
|
||||||
>process
|
[ drop [ [ close-handle ] when* ] bi@ ]
|
||||||
swap >>stdout
|
3bi
|
||||||
swap >>stdin
|
wait-for-process ;
|
||||||
run-detached
|
|
||||||
] curry ;
|
|
||||||
|
|
||||||
M: process wait-for-pipeline-element wait-for-process ;
|
|
||||||
|
|
||||||
: <process-reader*> ( process encoding -- process stream )
|
: <process-reader*> ( process encoding -- process stream )
|
||||||
[
|
[
|
||||||
|
|
|
@ -23,34 +23,31 @@ HOOK: (pipe) io-backend ( -- pipe )
|
||||||
r> <encoder-duplex>
|
r> <encoder-duplex>
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
: with-fds ( input-fd output-fd quot -- )
|
<PRIVATE
|
||||||
>r >r [ <reader> dup add-always-destructor ] [ input-stream get ] if* r> r> [
|
|
||||||
>r [ <writer> dup add-always-destructor ] [ output-stream get ] if* r>
|
|
||||||
with-output-stream*
|
|
||||||
] 2curry with-input-stream* ; inline
|
|
||||||
|
|
||||||
: <pipes> ( n -- pipes )
|
: ?reader [ <reader> dup add-always-destructor ] [ input-stream get ] if* ;
|
||||||
[ (pipe) dup add-always-destructor ] replicate
|
: ?writer [ <writer> dup add-always-destructor ] [ output-stream get ] if* ;
|
||||||
f f pipe boa [ prefix ] [ suffix ] bi
|
|
||||||
2 <clumps> ;
|
|
||||||
|
|
||||||
: with-pipe-fds ( seq -- results )
|
GENERIC: run-pipeline-element ( input-fd output-fd obj -- quot )
|
||||||
|
|
||||||
|
M: callable run-pipeline-element
|
||||||
[
|
[
|
||||||
[ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
|
>r [ ?reader ] [ ?writer ] bi*
|
||||||
[ >r [ first in>> ] [ second out>> ] bi r> 2curry ] 2map
|
r> with-streams*
|
||||||
[ call ] parallel-map
|
|
||||||
] with-destructors ;
|
] with-destructors ;
|
||||||
|
|
||||||
GENERIC: pipeline-element-quot ( obj -- quot )
|
: <pipes> ( n -- pipes )
|
||||||
|
[
|
||||||
|
[ (pipe) dup add-error-destructor ] replicate
|
||||||
|
T{ pipe } [ prefix ] [ suffix ] bi
|
||||||
|
2 <clumps>
|
||||||
|
] with-destructors ;
|
||||||
|
|
||||||
M: callable pipeline-element-quot
|
PRIVATE>
|
||||||
[ with-fds ] curry ;
|
|
||||||
|
|
||||||
GENERIC: wait-for-pipeline-element ( obj -- result )
|
|
||||||
|
|
||||||
M: object wait-for-pipeline-element ;
|
|
||||||
|
|
||||||
: run-pipeline ( seq -- results )
|
: run-pipeline ( seq -- results )
|
||||||
[ pipeline-element-quot ] map
|
[ length dup zero? [ drop { } ] [ 1- <pipes> ] if ] keep
|
||||||
with-pipe-fds
|
[
|
||||||
[ wait-for-pipeline-element ] map ;
|
>r [ first in>> ] [ second out>> ] bi
|
||||||
|
r> run-pipeline-element
|
||||||
|
] 2parallel-map ;
|
||||||
|
|
|
@ -99,7 +99,7 @@ accessors kernel sequences io.encodings.utf8 ;
|
||||||
utf8 file-contents
|
utf8 file-contents
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [ "append-test" temp-file delete-file ] unit-test
|
[ "append-test" temp-file delete-file ] ignore-errors
|
||||||
|
|
||||||
[ "hi\nhi\n" ] [
|
[ "hi\nhi\n" ] [
|
||||||
2 [
|
2 [
|
||||||
|
|
|
@ -13,9 +13,11 @@ TUPLE: macosx-monitor < monitor handle ;
|
||||||
] curry each ;
|
] curry each ;
|
||||||
|
|
||||||
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
|
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
|
||||||
path mailbox macosx-monitor new-monitor
|
[let | path [ path normalize-path ] |
|
||||||
dup [ enqueue-notifications ] curry
|
path mailbox macosx-monitor new-monitor
|
||||||
path 1array 0 0 <event-stream> >>handle ;
|
dup [ enqueue-notifications ] curry
|
||||||
|
path 1array 0 0 <event-stream> >>handle
|
||||||
|
] ;
|
||||||
|
|
||||||
M: macosx-monitor dispose
|
M: macosx-monitor dispose
|
||||||
handle>> dispose ;
|
handle>> dispose ;
|
||||||
|
|
|
@ -9,6 +9,7 @@ IN: io.unix.pipes.tests
|
||||||
"ls"
|
"ls"
|
||||||
[
|
[
|
||||||
input-stream [ utf8 <decoder> ] change
|
input-stream [ utf8 <decoder> ] change
|
||||||
|
output-stream [ utf8 <encoder> ] change
|
||||||
input-stream get lines reverse [ print ] each f
|
input-stream get lines reverse [ print ] each f
|
||||||
]
|
]
|
||||||
"grep x"
|
"grep x"
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Daniel Ehrenberg
|
|
@ -0,0 +1,35 @@
|
||||||
|
USING: help.syntax help.markup ;
|
||||||
|
IN: lcs
|
||||||
|
|
||||||
|
HELP: levenshtein
|
||||||
|
{ $values { "old" "a sequence" } { "new" "a sequence" } { "n" "the Levenshtein distance" } }
|
||||||
|
{ $description "Calculates the Levenshtein distance between old and new, that is, the minimal number of changes from the old sequence to the new one, in terms of deleting, inserting and replacing characters." } ;
|
||||||
|
|
||||||
|
HELP: lcs
|
||||||
|
{ $values { "seq1" "a sequence" } { "seq2" "a sequence" } { "lcs" "a longest common subsequence" } }
|
||||||
|
{ $description "Given two sequences, calculates a longest common subsequence between them. Note two things: this is only one of the many possible LCSs, and the LCS may not be contiguous." } ;
|
||||||
|
|
||||||
|
HELP: diff
|
||||||
|
{ $values { "old" "a sequence" } { "new" "a sequence" } { "diff" "an edit script" } }
|
||||||
|
{ $description "Given two sequences, find a minimal edit script from the old to the new. There may be more than one minimal edit script, and this chooses one arbitrarily. This script is in the form of an array of the tuples of the classes " { $link retain } ", " { $link delete } " and " { $link insert } " which have their information stored in the 'item' slot." } ;
|
||||||
|
|
||||||
|
HELP: retain
|
||||||
|
{ $class-description "Represents an action in an edit script where an item is kept, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is retained" } ;
|
||||||
|
|
||||||
|
HELP: delete
|
||||||
|
{ $class-description "Represents an action in an edit script where an item is deleted, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is deleted" } ;
|
||||||
|
|
||||||
|
HELP: insert
|
||||||
|
{ $class-description "Represents an action in an edit script where an item is added, going from the initial sequence to the final sequence. This has one slot, called item, containing the thing which is inserted" } ;
|
||||||
|
|
||||||
|
ARTICLE: "lcs" "LCS, Diffing and Distance"
|
||||||
|
"This vocabulary provides words for three apparently unrelated but in fact very similar problems: finding a longest common subsequence between two sequences, getting a minimal edit script (diff) between two sequences, and calculating the Levenshtein distance between two sequences. The implementations of these algorithms are very closely related, and all running times are O(nm), where n and m are the lengths of the input sequences."
|
||||||
|
{ $subsection lcs }
|
||||||
|
{ $subsection diff }
|
||||||
|
{ $subsection levenshtein }
|
||||||
|
"The " { $link diff } " word returns a sequence of tuples of the following classes. They all hold their contents in the 'item' slot."
|
||||||
|
{ $subsection insert }
|
||||||
|
{ $subsection delete }
|
||||||
|
{ $subsection retain } ;
|
||||||
|
|
||||||
|
ABOUT: "lcs"
|
|
@ -0,0 +1,25 @@
|
||||||
|
! Copyright (C) 2006 Slava Pestov.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: tools.test lcs ;
|
||||||
|
|
||||||
|
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
|
||||||
|
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
|
||||||
|
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
|
||||||
|
[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
|
||||||
|
|
||||||
|
[ "hell" ] [ "hello" "hell" lcs ] unit-test
|
||||||
|
[ "hell" ] [ "hell" "hello" lcs ] unit-test
|
||||||
|
[ "ell" ] [ "ell" "hell" lcs ] unit-test
|
||||||
|
[ "ell" ] [ "hell" "ell" lcs ] unit-test
|
||||||
|
[ "abd" ] [ "faxbcd" "abdef" lcs ] unit-test
|
||||||
|
|
||||||
|
[ {
|
||||||
|
T{ delete f CHAR: f }
|
||||||
|
T{ retain f CHAR: a }
|
||||||
|
T{ delete f CHAR: x }
|
||||||
|
T{ retain f CHAR: b }
|
||||||
|
T{ delete f CHAR: c }
|
||||||
|
T{ retain f CHAR: d }
|
||||||
|
T{ insert f CHAR: e }
|
||||||
|
T{ insert f CHAR: f }
|
||||||
|
} ] [ "faxbcd" "abdef" diff ] unit-test
|
|
@ -0,0 +1,97 @@
|
||||||
|
USING: sequences kernel math locals math.order math.ranges
|
||||||
|
accessors combinators.lib arrays namespaces combinators ;
|
||||||
|
IN: lcs
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
: levenshtein-step ( insert delete change same? -- next )
|
||||||
|
0 1 ? + >r [ 1+ ] bi@ r> min min ;
|
||||||
|
|
||||||
|
: lcs-step ( insert delete change same? -- next )
|
||||||
|
1 -9999 ? + max max ; ! Replace -9999 with -inf when added
|
||||||
|
|
||||||
|
:: loop-step ( i j matrix old new step -- )
|
||||||
|
i j 1+ matrix nth nth ! insertion
|
||||||
|
i 1+ j matrix nth nth ! deletion
|
||||||
|
i j matrix nth nth ! replace/retain
|
||||||
|
i old nth j new nth = ! same?
|
||||||
|
step call
|
||||||
|
i 1+ j 1+ matrix nth set-nth ; inline
|
||||||
|
|
||||||
|
: lcs-initialize ( |str1| |str2| -- matrix )
|
||||||
|
[ drop 0 <array> ] with map ;
|
||||||
|
|
||||||
|
: levenshtein-initialize ( |str1| |str2| -- matrix )
|
||||||
|
[ [ + ] curry map ] with map ;
|
||||||
|
|
||||||
|
:: run-lcs ( old new init step -- matrix )
|
||||||
|
[let | matrix [ old length 1+ new length 1+ init call ] |
|
||||||
|
old length [0,b) [| i |
|
||||||
|
new length [0,b)
|
||||||
|
[| j | i j matrix old new step loop-step ]
|
||||||
|
each
|
||||||
|
] each matrix ] ; inline
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: levenshtein ( old new -- n )
|
||||||
|
[ levenshtein-initialize ] [ levenshtein-step ]
|
||||||
|
run-lcs peek peek ;
|
||||||
|
|
||||||
|
TUPLE: retain item ;
|
||||||
|
TUPLE: delete item ;
|
||||||
|
TUPLE: insert item ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
TUPLE: trace-state old new table i j ;
|
||||||
|
|
||||||
|
: old-nth ( state -- elt )
|
||||||
|
[ i>> 1- ] [ old>> ] bi nth ;
|
||||||
|
|
||||||
|
: new-nth ( state -- elt )
|
||||||
|
[ j>> 1- ] [ new>> ] bi nth ;
|
||||||
|
|
||||||
|
: top-beats-side? ( state -- ? )
|
||||||
|
[ [ i>> ] [ j>> 1- ] [ table>> ] tri nth nth ]
|
||||||
|
[ [ i>> 1- ] [ j>> ] [ table>> ] tri nth nth ] bi > ;
|
||||||
|
|
||||||
|
: retained? ( state -- ? )
|
||||||
|
{
|
||||||
|
[ i>> 0 > ] [ j>> 0 > ]
|
||||||
|
[ [ old-nth ] [ new-nth ] bi = ]
|
||||||
|
} <-&& ;
|
||||||
|
|
||||||
|
: do-retain ( state -- state )
|
||||||
|
dup old-nth retain boa ,
|
||||||
|
[ 1- ] change-i [ 1- ] change-j ;
|
||||||
|
|
||||||
|
: inserted? ( state -- ? )
|
||||||
|
[ j>> 0 > ]
|
||||||
|
[ [ i>> zero? ] [ top-beats-side? ] or? ] and? ;
|
||||||
|
|
||||||
|
: do-insert ( state -- state )
|
||||||
|
dup new-nth insert boa , [ 1- ] change-j ;
|
||||||
|
|
||||||
|
: deleted? ( state -- ? )
|
||||||
|
[ i>> 0 > ]
|
||||||
|
[ [ j>> zero? ] [ top-beats-side? not ] or? ] and? ;
|
||||||
|
|
||||||
|
: do-delete ( state -- state )
|
||||||
|
dup old-nth delete boa , [ 1- ] change-i ;
|
||||||
|
|
||||||
|
: (trace-diff) ( state -- )
|
||||||
|
{
|
||||||
|
{ [ dup retained? ] [ do-retain (trace-diff) ] }
|
||||||
|
{ [ dup inserted? ] [ do-insert (trace-diff) ] }
|
||||||
|
{ [ dup deleted? ] [ do-delete (trace-diff) ] }
|
||||||
|
[ drop ] ! i=j=0
|
||||||
|
} cond ;
|
||||||
|
|
||||||
|
: trace-diff ( old new table -- diff )
|
||||||
|
[ ] [ first length 1- ] [ length 1- ] tri trace-state boa
|
||||||
|
[ (trace-diff) ] { } make reverse ;
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: diff ( old new -- diff )
|
||||||
|
2dup [ lcs-initialize ] [ lcs-step ] run-lcs trace-diff ;
|
||||||
|
|
||||||
|
: lcs ( seq1 seq2 -- lcs )
|
||||||
|
[ diff [ retain? ] filter ] keep [ item>> ] swap map-as ;
|
|
@ -0,0 +1 @@
|
||||||
|
Levenshtein distance and diff between sequences
|
|
@ -0,0 +1 @@
|
||||||
|
algorithms
|
|
@ -1 +0,0 @@
|
||||||
Slava Pestov
|
|
|
@ -1,9 +0,0 @@
|
||||||
! Copyright (C) 2006 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
IN: levenshtein.tests
|
|
||||||
USING: tools.test levenshtein ;
|
|
||||||
|
|
||||||
[ 3 ] [ "sitting" "kitten" levenshtein ] unit-test
|
|
||||||
[ 3 ] [ "kitten" "sitting" levenshtein ] unit-test
|
|
||||||
[ 1 ] [ "freshpak" "freshpack" levenshtein ] unit-test
|
|
||||||
[ 1 ] [ "freshpack" "freshpak" levenshtein ] unit-test
|
|
|
@ -1,47 +0,0 @@
|
||||||
! Copyright (C) 2006 Slava Pestov.
|
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
|
||||||
USING: arrays help io kernel math namespaces sequences
|
|
||||||
math.order ;
|
|
||||||
IN: levenshtein
|
|
||||||
|
|
||||||
: <matrix> ( m n -- matrix )
|
|
||||||
[ drop 0 <array> ] with map ; inline
|
|
||||||
|
|
||||||
: matrix-> nth nth ; inline
|
|
||||||
: ->matrix nth set-nth ; inline
|
|
||||||
|
|
||||||
SYMBOL: d
|
|
||||||
|
|
||||||
: ->d ( n i j -- ) d get ->matrix ; inline
|
|
||||||
: d-> ( i j -- n ) d get matrix-> ; inline
|
|
||||||
|
|
||||||
SYMBOL: costs
|
|
||||||
|
|
||||||
: init-d ( str1 str2 -- )
|
|
||||||
[ length 1+ ] bi@ 2dup <matrix> d set
|
|
||||||
[ 0 over ->d ] each
|
|
||||||
[ dup 0 ->d ] each ; inline
|
|
||||||
|
|
||||||
: compute-costs ( str1 str2 -- )
|
|
||||||
swap [
|
|
||||||
[ = 0 1 ? ] with { } map-as
|
|
||||||
] curry { } map-as costs set ; inline
|
|
||||||
|
|
||||||
: levenshtein-step ( i j -- )
|
|
||||||
[ 1+ d-> 1+ ] 2keep
|
|
||||||
[ >r 1+ r> d-> 1+ ] 2keep
|
|
||||||
[ d-> ] 2keep
|
|
||||||
[ costs get matrix-> + min min ] 2keep
|
|
||||||
>r 1+ r> 1+ ->d ; inline
|
|
||||||
|
|
||||||
: levenshtein-result ( -- n ) d get peek peek ; inline
|
|
||||||
|
|
||||||
: levenshtein ( str1 str2 -- n )
|
|
||||||
[
|
|
||||||
2dup init-d
|
|
||||||
2dup compute-costs
|
|
||||||
[ length ] bi@ [
|
|
||||||
[ levenshtein-step ] curry each
|
|
||||||
] with each
|
|
||||||
levenshtein-result
|
|
||||||
] with-scope ;
|
|
|
@ -1 +0,0 @@
|
||||||
Levenshtein edit distance algorithm
|
|
|
@ -114,7 +114,7 @@ IN: tools.deploy.shaker
|
||||||
continuations:error-continuation
|
continuations:error-continuation
|
||||||
continuations:error-thread
|
continuations:error-thread
|
||||||
continuations:restarts
|
continuations:restarts
|
||||||
error-hook
|
listener:error-hook
|
||||||
init:init-hooks
|
init:init-hooks
|
||||||
inspector:inspector-hook
|
inspector:inspector-hook
|
||||||
io.thread:io-thread
|
io.thread:io-thread
|
||||||
|
|
|
@ -1,11 +1,11 @@
|
||||||
IN: ui.tools.interactor.tests
|
IN: ui.tools.interactor.tests
|
||||||
USING: ui.tools.interactor ui.gadgets.panes namespaces
|
USING: ui.tools.interactor ui.gadgets.panes namespaces
|
||||||
ui.gadgets.editors concurrency.promises threads listener
|
ui.gadgets.editors concurrency.promises threads listener
|
||||||
tools.test kernel calendar parser ;
|
tools.test kernel calendar parser accessors ;
|
||||||
|
|
||||||
|
\ <interactor> must-infer
|
||||||
|
|
||||||
[
|
[
|
||||||
\ <interactor> must-infer
|
|
||||||
|
|
||||||
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
|
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
|
||||||
|
|
||||||
[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
|
[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
|
||||||
|
@ -13,6 +13,7 @@ tools.test kernel calendar parser ;
|
||||||
[ ] [ <promise> "promise" set ] unit-test
|
[ ] [ <promise> "promise" set ] unit-test
|
||||||
|
|
||||||
[
|
[
|
||||||
|
self "interactor" get (>>thread)
|
||||||
"interactor" get stream-read-quot "promise" get fulfill
|
"interactor" get stream-read-quot "promise" get fulfill
|
||||||
] "Interactor test" spawn drop
|
] "Interactor test" spawn drop
|
||||||
|
|
||||||
|
@ -27,3 +28,14 @@ tools.test kernel calendar parser ;
|
||||||
|
|
||||||
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
|
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
|
||||||
] with-interactive-vocabs
|
] with-interactive-vocabs
|
||||||
|
|
||||||
|
! Hang
|
||||||
|
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
|
||||||
|
|
||||||
|
[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
|
||||||
|
|
||||||
|
[ ] [ 1000 sleep ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "interactor" get interactor-eof ] unit-test
|
||||||
|
|
|
@ -1,53 +1,53 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays assocs combinators continuations documents
|
USING: arrays assocs combinators continuations documents
|
||||||
hashtables io io.styles kernel math
|
hashtables io io.styles kernel math math.order math.vectors
|
||||||
math.vectors models namespaces parser prettyprint quotations
|
models namespaces parser prettyprint quotations sequences
|
||||||
sequences strings threads listener
|
strings threads listener classes.tuple ui.commands ui.gadgets
|
||||||
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
|
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
|
||||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
ui.gestures definitions calendar concurrency.flags
|
||||||
definitions boxes calendar concurrency.flags ui.tools.workspace
|
ui.tools.workspace accessors ;
|
||||||
accessors math.order ;
|
|
||||||
IN: ui.tools.interactor
|
IN: ui.tools.interactor
|
||||||
|
|
||||||
TUPLE: interactor history output flag thread help ;
|
! If waiting is t, we're waiting for user input, and invoking
|
||||||
|
! evaluate-input resumes the thread.
|
||||||
|
TUPLE: interactor output history flag thread waiting help ;
|
||||||
|
|
||||||
|
: register-self ( interactor -- )
|
||||||
|
self >>thread drop ;
|
||||||
|
|
||||||
: interactor-continuation ( interactor -- continuation )
|
: interactor-continuation ( interactor -- continuation )
|
||||||
interactor-thread box-value
|
thread>> continuation>> value>> ;
|
||||||
thread-continuation box-value ;
|
|
||||||
|
|
||||||
: interactor-busy? ( interactor -- ? )
|
: interactor-busy? ( interactor -- ? )
|
||||||
interactor-thread box-full? not ;
|
#! We're busy if there's no thread to resume.
|
||||||
|
[ waiting>> ]
|
||||||
|
[ thread>> dup [ thread-registered? ] when ]
|
||||||
|
bi and not ;
|
||||||
|
|
||||||
: interactor-use ( interactor -- seq )
|
: interactor-use ( interactor -- seq )
|
||||||
dup interactor-busy? [ drop f ] [
|
dup interactor-busy? [ drop f ] [
|
||||||
use swap
|
use swap
|
||||||
interactor-continuation continuation-name
|
interactor-continuation name>>
|
||||||
assoc-stack
|
assoc-stack
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: init-caret-help ( interactor -- )
|
: <help-model> ( interactor -- model )
|
||||||
dup editor-caret 1/3 seconds <delay>
|
editor-caret 1/3 seconds <delay> ;
|
||||||
swap set-interactor-help ;
|
|
||||||
|
|
||||||
: init-interactor-history ( interactor -- )
|
|
||||||
V{ } clone swap set-interactor-history ;
|
|
||||||
|
|
||||||
: init-interactor-state ( interactor -- )
|
|
||||||
<flag> over set-interactor-flag
|
|
||||||
<box> swap set-interactor-thread ;
|
|
||||||
|
|
||||||
: <interactor> ( output -- gadget )
|
: <interactor> ( output -- gadget )
|
||||||
<source-editor>
|
<source-editor>
|
||||||
interactor construct-editor
|
interactor construct-editor
|
||||||
tuck set-interactor-output
|
V{ } clone >>history
|
||||||
dup init-interactor-history
|
<flag> >>flag
|
||||||
dup init-interactor-state
|
dup <help-model> >>help
|
||||||
dup init-caret-help ;
|
swap >>output ;
|
||||||
|
|
||||||
M: interactor graft*
|
M: interactor graft*
|
||||||
dup delegate graft*
|
[ delegate graft* ] [ dup help>> add-connection ] bi ;
|
||||||
dup interactor-help add-connection ;
|
|
||||||
|
M: interactor ungraft*
|
||||||
|
[ dup help>> remove-connection ] [ delegate ungraft ] bi ;
|
||||||
|
|
||||||
: word-at-loc ( loc interactor -- word )
|
: word-at-loc ( loc interactor -- word )
|
||||||
over [
|
over [
|
||||||
|
@ -58,7 +58,7 @@ M: interactor graft*
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
M: interactor model-changed
|
M: interactor model-changed
|
||||||
2dup interactor-help eq? [
|
2dup help>> eq? [
|
||||||
swap model-value over word-at-loc swap show-summary
|
swap model-value over word-at-loc swap show-summary
|
||||||
] [
|
] [
|
||||||
delegate model-changed
|
delegate model-changed
|
||||||
|
@ -69,7 +69,7 @@ M: interactor model-changed
|
||||||
[ H{ { font-style bold } } format ] with-nesting ;
|
[ H{ { font-style bold } } format ] with-nesting ;
|
||||||
|
|
||||||
: interactor-input. ( string interactor -- )
|
: interactor-input. ( string interactor -- )
|
||||||
interactor-output [
|
output>> [
|
||||||
dup string? [ dup write-input nl ] [ short. ] if
|
dup string? [ dup write-input nl ] [ short. ] if
|
||||||
] with-output-stream* ;
|
] with-output-stream* ;
|
||||||
|
|
||||||
|
@ -77,7 +77,7 @@ M: interactor model-changed
|
||||||
over empty? [ 2drop ] [ interactor-history push-new ] if ;
|
over empty? [ 2drop ] [ interactor-history push-new ] if ;
|
||||||
|
|
||||||
: interactor-continue ( obj interactor -- )
|
: interactor-continue ( obj interactor -- )
|
||||||
interactor-thread box> resume-with ;
|
thread>> resume-with ;
|
||||||
|
|
||||||
: clear-input ( interactor -- ) gadget-model clear-doc ;
|
: clear-input ( interactor -- ) gadget-model clear-doc ;
|
||||||
|
|
||||||
|
@ -99,10 +99,12 @@ M: interactor model-changed
|
||||||
] unless drop ;
|
] unless drop ;
|
||||||
|
|
||||||
: interactor-yield ( interactor -- obj )
|
: interactor-yield ( interactor -- obj )
|
||||||
[
|
dup thread>> self eq? [
|
||||||
[ interactor-thread >box ] keep
|
t >>waiting
|
||||||
interactor-flag raise-flag
|
[ [ flag>> raise-flag ] curry "input" suspend ] keep
|
||||||
] curry "input" suspend ;
|
f >>waiting
|
||||||
|
drop
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
M: interactor stream-readln
|
M: interactor stream-readln
|
||||||
[ interactor-yield ] keep interactor-finish
|
[ interactor-yield ] keep interactor-finish
|
||||||
|
@ -161,7 +163,8 @@ M: interactor stream-read-quot
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
M: interactor pref-dim*
|
M: interactor pref-dim*
|
||||||
0 over line-height 4 * 2array swap delegate pref-dim* vmax ;
|
[ line-height 4 * 0 swap 2array ] [ delegate pref-dim* ] bi
|
||||||
|
vmax ;
|
||||||
|
|
||||||
interactor "interactor" f {
|
interactor "interactor" f {
|
||||||
{ T{ key-down f f "RET" } evaluate-input }
|
{ T{ key-down f f "RET" } evaluate-input }
|
||||||
|
|
|
@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
|
||||||
ui.tools.listener hashtables kernel namespaces parser sequences
|
ui.tools.listener hashtables kernel namespaces parser sequences
|
||||||
tools.test ui.commands ui.gadgets ui.gadgets.editors
|
tools.test ui.commands ui.gadgets ui.gadgets.editors
|
||||||
ui.gadgets.panes vocabs words tools.test.ui slots.private
|
ui.gadgets.panes vocabs words tools.test.ui slots.private
|
||||||
threads arrays generic ;
|
threads arrays generic threads accessors listener ;
|
||||||
IN: ui.tools.listener.tests
|
IN: ui.tools.listener.tests
|
||||||
|
|
||||||
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
||||||
|
@ -15,7 +15,7 @@ IN: ui.tools.listener.tests
|
||||||
[ "dup" ] [
|
[ "dup" ] [
|
||||||
\ dup word-completion-string
|
\ dup word-completion-string
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "equal?" ]
|
[ "equal?" ]
|
||||||
[ \ array \ equal? method word-completion-string ] unit-test
|
[ \ array \ equal? method word-completion-string ] unit-test
|
||||||
|
|
||||||
|
@ -28,9 +28,26 @@ IN: ui.tools.listener.tests
|
||||||
[ ] [
|
[ ] [
|
||||||
"i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
|
"i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
"i" get gadget-model doc-end
|
"i" get gadget-model doc-end
|
||||||
"i" get editor-caret* =
|
"i" get editor-caret* =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! Race condition discovered by SimonRC
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
"listener" get input>>
|
||||||
|
[ stream-read-quot drop ]
|
||||||
|
[ stream-read-quot drop ] bi
|
||||||
|
] "OH, HAI" spawn drop
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ "listener" get clear-output ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "listener" get restart-listener ] unit-test
|
||||||
|
|
||||||
|
[ ] [ 1000 sleep ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "listener" get com-end ] unit-test
|
||||||
] with-grafted-gadget
|
] with-grafted-gadget
|
||||||
|
|
|
@ -20,7 +20,7 @@ TUPLE: listener-gadget input output stack ;
|
||||||
[ input>> ] [ output>> <pane-stream> ] bi ;
|
[ input>> ] [ output>> <pane-stream> ] bi ;
|
||||||
|
|
||||||
: <listener-input> ( listener -- gadget )
|
: <listener-input> ( listener -- gadget )
|
||||||
listener-gadget-output <pane-stream> <interactor> ;
|
output>> <pane-stream> <interactor> ;
|
||||||
|
|
||||||
: listener-input, ( -- )
|
: listener-input, ( -- )
|
||||||
g <listener-input> g-> set-listener-gadget-input
|
g <listener-input> g-> set-listener-gadget-input
|
||||||
|
@ -32,31 +32,29 @@ TUPLE: listener-gadget input output stack ;
|
||||||
"cookbook" ($link) "." print nl ;
|
"cookbook" ($link) "." print nl ;
|
||||||
|
|
||||||
M: listener-gadget focusable-child*
|
M: listener-gadget focusable-child*
|
||||||
listener-gadget-input ;
|
input>> ;
|
||||||
|
|
||||||
M: listener-gadget call-tool* ( input listener -- )
|
M: listener-gadget call-tool* ( input listener -- )
|
||||||
>r input-string r> listener-gadget-input set-editor-string ;
|
>r string>> r> input>> set-editor-string ;
|
||||||
|
|
||||||
M: listener-gadget tool-scroller
|
M: listener-gadget tool-scroller
|
||||||
listener-gadget-output find-scroller ;
|
output>> find-scroller ;
|
||||||
|
|
||||||
: wait-for-listener ( listener -- )
|
: wait-for-listener ( listener -- )
|
||||||
#! Wait for the listener to start.
|
#! Wait for the listener to start.
|
||||||
listener-gadget-input interactor-flag wait-for-flag ;
|
input>> flag>> wait-for-flag ;
|
||||||
|
|
||||||
: workspace-busy? ( workspace -- ? )
|
: workspace-busy? ( workspace -- ? )
|
||||||
workspace-listener listener-gadget-input interactor-busy? ;
|
listener>> input>> interactor-busy? ;
|
||||||
|
|
||||||
: listener-input ( string -- )
|
: listener-input ( string -- )
|
||||||
get-workspace
|
get-workspace listener>> input>> set-editor-string ;
|
||||||
workspace-listener
|
|
||||||
listener-gadget-input set-editor-string ;
|
|
||||||
|
|
||||||
: (call-listener) ( quot listener -- )
|
: (call-listener) ( quot listener -- )
|
||||||
listener-gadget-input interactor-call ;
|
input>> interactor-call ;
|
||||||
|
|
||||||
: call-listener ( quot -- )
|
: call-listener ( quot -- )
|
||||||
[ workspace-busy? not ] get-workspace* workspace-listener
|
[ workspace-busy? not ] get-workspace* listener>>
|
||||||
[ dup wait-for-listener (call-listener) ] 2curry
|
[ dup wait-for-listener (call-listener) ] 2curry
|
||||||
"Listener call" spawn drop ;
|
"Listener call" spawn drop ;
|
||||||
|
|
||||||
|
@ -68,8 +66,7 @@ M: listener-operation invoke-command ( target command -- )
|
||||||
|
|
||||||
: eval-listener ( string -- )
|
: eval-listener ( string -- )
|
||||||
get-workspace
|
get-workspace
|
||||||
workspace-listener
|
listener>> input>> [ set-editor-string ] keep
|
||||||
listener-gadget-input [ set-editor-string ] keep
|
|
||||||
evaluate-input ;
|
evaluate-input ;
|
||||||
|
|
||||||
: listener-run-files ( seq -- )
|
: listener-run-files ( seq -- )
|
||||||
|
@ -80,10 +77,10 @@ M: listener-operation invoke-command ( target command -- )
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: com-end ( listener -- )
|
: com-end ( listener -- )
|
||||||
listener-gadget-input interactor-eof ;
|
input>> interactor-eof ;
|
||||||
|
|
||||||
: clear-output ( listener -- )
|
: clear-output ( listener -- )
|
||||||
listener-gadget-output pane-clear ;
|
output>> pane-clear ;
|
||||||
|
|
||||||
\ clear-output H{ { +listener+ t } } define-command
|
\ clear-output H{ { +listener+ t } } define-command
|
||||||
|
|
||||||
|
@ -147,23 +144,26 @@ M: stack-display tool-scroller
|
||||||
|
|
||||||
: listener-thread ( listener -- )
|
: listener-thread ( listener -- )
|
||||||
dup listener-streams [
|
dup listener-streams [
|
||||||
[
|
[ [ ui-listener-hook ] curry listener-hook set ]
|
||||||
[ [ ui-listener-hook ] curry listener-hook set ]
|
[ [ ui-error-hook ] curry error-hook set ]
|
||||||
[ [ ui-error-hook ] curry error-hook set ]
|
[ [ ui-inspector-hook ] curry inspector-hook set ] tri
|
||||||
[ [ ui-inspector-hook ] curry inspector-hook set ] tri
|
welcome.
|
||||||
welcome.
|
listener
|
||||||
listener
|
] with-streams* ;
|
||||||
] with-input-stream*
|
|
||||||
] with-output-stream* ;
|
|
||||||
|
|
||||||
: start-listener-thread ( listener -- )
|
: start-listener-thread ( listener -- )
|
||||||
[ listener-thread ] curry "Listener" spawn drop ;
|
[
|
||||||
|
[ input>> register-self ] [ listener-thread ] bi
|
||||||
|
] curry "Listener" spawn drop ;
|
||||||
|
|
||||||
: restart-listener ( listener -- )
|
: restart-listener ( listener -- )
|
||||||
#! Returns when listener is ready to receive input.
|
#! Returns when listener is ready to receive input.
|
||||||
dup com-end dup clear-output
|
{
|
||||||
dup start-listener-thread
|
[ com-end ]
|
||||||
wait-for-listener ;
|
[ clear-output ]
|
||||||
|
[ start-listener-thread ]
|
||||||
|
[ wait-for-listener ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
: init-listener ( listener -- )
|
: init-listener ( listener -- )
|
||||||
f <model> swap set-listener-gadget-stack ;
|
f <model> swap set-listener-gadget-stack ;
|
||||||
|
@ -189,10 +189,7 @@ M: listener-gadget handle-gesture* ( gadget gesture delegate -- ? )
|
||||||
[ default-gesture-handler ] [ 3drop f ] if ;
|
[ default-gesture-handler ] [ 3drop f ] if ;
|
||||||
|
|
||||||
M: listener-gadget graft*
|
M: listener-gadget graft*
|
||||||
dup delegate graft*
|
[ delegate graft* ] [ restart-listener ] bi ;
|
||||||
dup listener-gadget-input interactor-thread ?box 2drop
|
|
||||||
restart-listener ;
|
|
||||||
|
|
||||||
M: listener-gadget ungraft*
|
M: listener-gadget ungraft*
|
||||||
dup com-end
|
[ com-end ] [ delegate ungraft* ] bi ;
|
||||||
delegate ungraft* ;
|
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
USING: unicode.syntax.backend kernel sequences assocs io.files
|
USING: unicode.syntax.backend kernel sequences assocs io.files
|
||||||
io.encodings ascii math.ranges io splitting math.parser
|
io.encodings ascii math.ranges io splitting math.parser
|
||||||
namespaces byte-arrays locals math sets io.encodings.ascii
|
namespaces byte-arrays locals math sets io.encodings.ascii
|
||||||
words compiler.units ;
|
words compiler.units arrays interval-maps ;
|
||||||
IN: unicode.script
|
IN: unicode.script
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
VALUE: char>num-table
|
VALUE: script-table
|
||||||
VALUE: num>name-table
|
SYMBOL: interned
|
||||||
|
|
||||||
: parse-script ( stream -- assoc )
|
: parse-script ( stream -- assoc )
|
||||||
! assoc is code point/range => name
|
! assoc is code point/range => name
|
||||||
|
@ -14,26 +14,18 @@ VALUE: num>name-table
|
||||||
";" split1 [ [ blank? ] trim ] bi@
|
";" split1 [ [ blank? ] trim ] bi@
|
||||||
] H{ } map>assoc ;
|
] H{ } map>assoc ;
|
||||||
|
|
||||||
: set-if ( value var -- )
|
: range, ( value key -- )
|
||||||
dup 500000 < [ set ] [ 2drop ] if ;
|
swap interned get
|
||||||
|
[ word-name = ] with find nip 2array , ;
|
||||||
|
|
||||||
: expand-ranges ( assoc -- char-assoc )
|
: expand-ranges ( assoc -- interval-map )
|
||||||
! char-assoc is code point => name
|
[
|
||||||
[ [
|
[
|
||||||
CHAR: . pick member? [
|
CHAR: . pick member? [
|
||||||
swap ".." split1 [ hex> ] bi@ [a,b]
|
swap ".." split1 [ hex> ] bi@ 2array
|
||||||
[ set-if ] with each
|
] [ swap hex> ] if range,
|
||||||
] [ swap hex> set-if ] if
|
] assoc-each
|
||||||
] assoc-each ] H{ } make-assoc ;
|
] { } make <interval-map> ;
|
||||||
|
|
||||||
: hash>byte-array ( hash -- byte-array )
|
|
||||||
[ keys supremum 1+ <byte-array> dup ] keep
|
|
||||||
[ -rot set-nth ] with assoc-each ;
|
|
||||||
|
|
||||||
: make-char>num ( assoc -- char>num-table )
|
|
||||||
expand-ranges
|
|
||||||
[ num>name-table index ] assoc-map
|
|
||||||
hash>byte-array ;
|
|
||||||
|
|
||||||
: >symbols ( strings -- symbols )
|
: >symbols ( strings -- symbols )
|
||||||
[
|
[
|
||||||
|
@ -41,9 +33,9 @@ VALUE: num>name-table
|
||||||
] with-compilation-unit ;
|
] with-compilation-unit ;
|
||||||
|
|
||||||
: process-script ( ranges -- )
|
: process-script ( ranges -- )
|
||||||
[ values prune \ num>name-table set-value ]
|
dup values prune >symbols interned [
|
||||||
[ make-char>num \ char>num-table set-value ] bi
|
expand-ranges \ script-table set-value
|
||||||
num>name-table >symbols \ num>name-table set-value ;
|
] with-variable ;
|
||||||
|
|
||||||
: load-script ( -- )
|
: load-script ( -- )
|
||||||
"resource:extra/unicode/script/Scripts.txt"
|
"resource:extra/unicode/script/Scripts.txt"
|
||||||
|
@ -52,5 +44,7 @@ VALUE: num>name-table
|
||||||
load-script
|
load-script
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
|
SYMBOL: Unknown
|
||||||
|
|
||||||
: script-of ( char -- script )
|
: script-of ( char -- script )
|
||||||
char>num-table nth num>name-table nth ;
|
script-table interval-at [ Unknown ] unless* ;
|
||||||
|
|
Loading…
Reference in New Issue