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

db4
Bruno Deferrari 2008-11-22 17:44:54 -02:00
commit 8733599182
148 changed files with 3339 additions and 1768 deletions

1
.gitignore vendored
View File

@ -20,3 +20,4 @@ temp
logs
work
build-support/wordsize
*.bak

View File

@ -161,7 +161,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor*.*
rm -f factor*.dll libfactor.{a,so,dylib}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o

View File

@ -52,17 +52,17 @@ HELP: 3||
{ "quot" quotation } }
{ $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ;
HELP: n&&-rewrite
HELP: n&&
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each AND quotation." } ;
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ;
HELP: n||-rewrite
HELP: n||
{ $values
{ "quots" "a sequence of quotations" } { "N" integer }
{ "quots" "a sequence of quotations" } { "n" integer }
{ "quot" quotation } }
{ $description "A macro that reqrites the code to pass " { $snippet "N" } " parameters from the stack to each OR quotation." } ;
{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each OR quotation." } ;
ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
"The " { $vocab-link "combinators.short-circuit" } " vocabulary stops a computation early once a condition is met." $nl
@ -77,8 +77,8 @@ ARTICLE: "combinators.short-circuit" "Short-circuit combinators"
{ $subsection 2|| }
{ $subsection 3|| }
"Generalized combinators:"
{ $subsection n&&-rewrite }
{ $subsection n||-rewrite }
{ $subsection n&& }
{ $subsection n|| }
;
ABOUT: "combinators.short-circuit"

View File

@ -1,35 +1,26 @@
USING: kernel combinators quotations arrays sequences assocs
locals generalizations macros fry ;
locals generalizations macros fry ;
IN: combinators.short-circuit
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO:: n&& ( quots n -- quot )
[ f ]
quots [| q | { [ drop n ndup q call dup not ] [ drop n ndrop f ] } ] map
[ n nnip ] suffix 1array
[ cond ] 3append ;
:: n&&-rewrite ( quots N -- quot )
quots
[ '[ drop N ndup @ dup not ] [ drop N ndrop f ] 2array ]
map
[ t ] [ N nnip ] 2array suffix
'[ f _ cond ] ;
MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ;
MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ;
MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ;
MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ;
MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ;
MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ;
MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ;
MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ;
MACRO:: n|| ( quots n -- quot )
[ f ]
quots
[| q | { [ drop n ndup q call dup ] [ n nnip ] } ] map
{ [ drop n ndrop t ] [ f ] } suffix 1array
[ cond ] 3append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
:: n||-rewrite ( quots N -- quot )
quots
[ '[ drop N ndup @ dup ] [ N nnip ] 2array ]
map
[ drop N ndrop t ] [ f ] 2array suffix
'[ f _ cond ] ;
MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ;
MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ;
MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ;
MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ;
MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ;
MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ;
MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ;

View File

@ -1,7 +1,5 @@
USING: kernel sequences math stack-checker effects accessors macros
combinators.short-circuit ;
fry combinators.short-circuit ;
IN: combinators.short-circuit.smart
<PRIVATE
@ -13,6 +11,6 @@ IN: combinators.short-circuit.smart
PRIVATE>
MACRO: && ( quots -- quot ) dup arity n&&-rewrite ;
MACRO: && ( quots -- quot ) dup arity '[ _ _ n&& ] ;
MACRO: || ( quots -- quot ) dup arity n||-rewrite ;
MACRO: || ( quots -- quot ) dup arity '[ _ _ n|| ] ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals
namespaces sequences words combinators combinators.short-circuit
namespaces sequences words combinators
arrays compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
@ -253,12 +253,13 @@ DEFER: (value-info-union)
{ [ over not ] [ 2drop f ] }
[
{
[ [ class>> ] bi@ class<= ]
[ [ interval>> ] bi@ interval-subset? ]
[ literals<= ]
[ [ length>> ] bi@ value-info<= ]
[ [ slots>> ] bi@ [ value-info<= ] 2all? ]
} 2&&
{ [ 2dup [ class>> ] bi@ class<= not ] [ f ] }
{ [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] }
{ [ 2dup literals<= not ] [ f ] }
{ [ 2dup [ length>> ] bi@ value-info<= not ] [ f ] }
{ [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] }
[ t ]
} cond 2nip
]
} cond ;

View File

@ -138,6 +138,12 @@ most-negative-fixnum most-positive-fixnum [a,b]
\ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op
\ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op
{ /mod fixnum/mod } [
\ /i \ mod
[ "outputs" word-prop ] bi@
'[ _ _ 2bi ] "outputs" set-word-prop
] each
\ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op
\ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op

View File

@ -27,11 +27,17 @@ HELP: parallel-filter
{ $errors "Throws an error if one of the iterations throws an error." } ;
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 various combinators."
$nl
"Concurrent sequence combinators:"
{ $subsection parallel-each }
{ $subsection 2parallel-each }
{ $subsection parallel-map }
{ $subsection 2parallel-map }
{ $subsection parallel-filter } ;
{ $subsection parallel-filter }
"Concurrent cleave combinators:"
{ $subsection parallel-cleave }
{ $subsection parallel-spread }
{ $subsection parallel-napply } ;
ABOUT: "concurrency.combinators"

View File

@ -1,6 +1,7 @@
IN: concurrency.combinators.tests
USING: concurrency.combinators tools.test random kernel math
concurrency.mailboxes threads sequences accessors arrays ;
concurrency.mailboxes threads sequences accessors arrays
math.parser ;
[ [ drop ] parallel-each ] must-infer
{ 2 0 } [ [ 2drop ] 2parallel-each ] must-infer-as
@ -45,3 +46,10 @@ concurrency.mailboxes threads sequences accessors arrays ;
] unit-test
[ { f } [ "OOPS" throw ] parallel-each ] must-fail
[ "1a" "4b" "3c" ] [
2
{ [ 1- ] [ sq ] [ 1+ ] } parallel-cleave
[ number>string ] 3 parallel-napply
{ [ "a" append ] [ "b" append ] [ "c" append ] } parallel-spread
] unit-test

View File

@ -1,34 +1,58 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.futures concurrency.count-downs sequences
kernel ;
kernel macros fry combinators generalizations ;
IN: concurrency.combinators
<PRIVATE
: (parallel-each) ( n quot -- )
>r <count-down> r> keep await ; inline
[ <count-down> ] dip keep await ; inline
PRIVATE>
: parallel-each ( seq quot -- )
over length [
[ >r curry r> spawn-stage ] 2curry each
'[ _ curry _ spawn-stage ] each
] (parallel-each) ; inline
: 2parallel-each ( seq1 seq2 quot -- )
2over min-length [
[ >r 2curry r> spawn-stage ] 2curry 2each
'[ _ 2curry _ spawn-stage ] 2each
] (parallel-each) ; inline
: parallel-filter ( seq quot -- newseq )
over >r pusher >r each r> r> like ; inline
over [ pusher [ each ] dip ] dip like ; inline
<PRIVATE
: [future] ( quot -- quot' ) '[ _ curry future ] ; inline
: future-values dup [ ?future ] change-each ; inline
PRIVATE>
: parallel-map ( seq quot -- newseq )
[ curry future ] curry map future-values ;
inline
[future] map future-values ; inline
: 2parallel-map ( seq1 seq2 quot -- newseq )
[ 2curry future ] curry 2map future-values ;
'[ _ 2curry future ] 2map future-values ;
<PRIVATE
: (parallel-spread) ( n -- spread-array )
[ ?future ] <repetition> ; inline
: (parallel-cleave) ( quots -- quot-array spread-array )
[ [future] ] map dup length (parallel-spread) ; inline
PRIVATE>
MACRO: parallel-cleave ( quots -- )
(parallel-cleave) '[ _ cleave _ spread ] ;
MACRO: parallel-spread ( quots -- )
(parallel-cleave) '[ _ spread _ spread ] ;
MACRO: parallel-napply ( quot n -- )
[ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ;

View File

@ -335,6 +335,24 @@ big-endian on
7 ds-reg 0 STW
] f f f \ fixnum-mod define-sub-primitive
[
3 ds-reg 0 LWZ
ds-reg ds-reg 4 SUBI
4 ds-reg 0 LWZ
5 4 3 DIVW
5 ds-reg 0 STW
] f f f \ fixnum/i-fast define-sub-primitive
[
3 ds-reg 0 LWZ
4 ds-reg -4 LWZ
5 4 3 DIVW
6 5 3 MULLW
7 6 4 SUBF
5 ds-reg -4 STW
7 ds-reg 0 STW
] f f f \ fixnum/mod-fast define-sub-primitive
[
3 ds-reg 0 LWZ
3 3 1 SRAWI

View File

@ -305,16 +305,33 @@ big-endian off
ds-reg [] arg1 MOV ! push to stack
] f f f \ fixnum-shift-fast define-sub-primitive
[
: jit-fixnum-/mod
temp-reg ds-reg [] MOV ! load second parameter
ds-reg bootstrap-cell SUB ! adjust stack pointer
div-arg ds-reg [] MOV ! load first parameter
div-arg ds-reg bootstrap-cell neg [+] MOV ! load first parameter
mod-arg div-arg MOV ! make a copy
mod-arg bootstrap-cell-bits 1- SAR ! sign-extend
temp-reg IDIV ! divide
temp-reg IDIV ; ! divide
[
jit-fixnum-/mod
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] mod-arg MOV ! push to stack
] f f f \ fixnum-mod define-sub-primitive
[
jit-fixnum-/mod
ds-reg bootstrap-cell SUB ! adjust stack pointer
div-arg tag-bits get SHL ! tag it
ds-reg [] div-arg MOV ! push to stack
] f f f \ fixnum/i-fast define-sub-primitive
[
jit-fixnum-/mod
div-arg tag-bits get SHL ! tag it
ds-reg [] mod-arg MOV ! push to stack
ds-reg bootstrap-cell neg [+] div-arg MOV
] f f f \ fixnum/mod-fast define-sub-primitive
[
arg0 ds-reg [] MOV ! load local number
fixnum>slot@ ! turn local number into offset

View File

@ -206,9 +206,8 @@ M: no-cond summary
M: no-case summary
drop "Fall-through in case" ;
M: slice-error error.
"Cannot create slice because " write
reason>> print ;
M: slice-error summary
drop "Cannot create slice" ;
M: bounds-error summary drop "Sequence index out of bounds" ;

View File

@ -5,9 +5,9 @@ sequences strings splitting combinators unicode.categories
math.order ;
IN: documents
: +col ( loc n -- newloc ) >r first2 r> + 2array ;
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
: +line ( loc n -- newloc ) >r first2 swap r> + swap 2array ;
: +line ( loc n -- newloc ) [ first2 swap ] dip + swap 2array ;
: =col ( n loc -- newloc ) first swap 2array ;
@ -31,10 +31,10 @@ TUPLE: document < model locs ;
: doc-line ( n document -- string ) value>> nth ;
: doc-lines ( from to document -- slice )
>r 1+ r> value>> <slice> ;
[ 1+ ] dip value>> <slice> ;
: start-on-line ( document from line# -- n1 )
>r dup first r> = [ nip second ] [ 2drop 0 ] if ;
[ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
: end-on-line ( document to line# -- n2 )
over first over = [
@ -47,12 +47,14 @@ TUPLE: document < model locs ;
2over = [
3drop
] [
>r [ first ] bi@ 1+ dup <slice> r> each
[ [ first ] bi@ 1+ dup <slice> ] dip each
] if ; inline
: start/end-on-line ( from to line# -- n1 n2 )
tuck >r >r document get -rot start-on-line r> r>
document get -rot end-on-line ;
tuck
[ [ document get ] 2dip start-on-line ]
[ [ document get ] 2dip end-on-line ]
2bi* ;
: (doc-range) ( from to line# -- )
[ start/end-on-line ] keep document get doc-line <slice> , ;
@ -60,16 +62,18 @@ TUPLE: document < model locs ;
: doc-range ( from to document -- string )
[
document set 2dup [
>r 2dup r> (doc-range)
[ 2dup ] dip (doc-range)
] each-line 2drop
] { } make "\n" join ;
: text+loc ( lines loc -- loc )
over >r over length 1 = [
nip first2
] [
first swap length 1- + 0
] if r> peek length + 2array ;
over [
over length 1 = [
nip first2
] [
first swap length 1- + 0
] if
] dip peek length + 2array ;
: prepend-first ( str seq -- )
0 swap [ append ] change-nth ;
@ -78,25 +82,25 @@ TUPLE: document < model locs ;
[ length 1- ] keep [ prepend ] change-nth ;
: loc-col/str ( loc document -- str col )
>r first2 swap r> nth swap ;
[ first2 swap ] dip nth swap ;
: prepare-insert ( newinput from to lines -- newinput )
tuck loc-col/str tail-slice >r loc-col/str head-slice r>
tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
pick append-last over prepend-first ;
: (set-doc-range) ( newlines from to lines -- )
[ prepare-insert ] 3keep
>r [ first ] bi@ 1+ r>
[ [ first ] bi@ 1+ ] dip
replace-slice ;
: set-doc-range ( string from to document -- )
[
>r >r >r string-lines r> [ text+loc ] 2keep r> r>
[ [ string-lines ] dip [ text+loc ] 2keep ] 2dip
[ [ (set-doc-range) ] keep ] change-model
] keep update-locs ;
: remove-doc-range ( from to document -- )
>r >r >r "" r> r> r> set-doc-range ;
[ "" ] 3dip set-doc-range ;
: last-line# ( document -- line )
value>> length 1- ;
@ -111,7 +115,7 @@ TUPLE: document < model locs ;
dupd doc-line length 2array ;
: line-end? ( loc document -- ? )
>r first2 swap r> doc-line length = ;
[ first2 swap ] dip doc-line length = ;
: doc-end ( document -- loc )
[ last-line# ] keep line-end ;
@ -123,7 +127,7 @@ TUPLE: document < model locs ;
over first 0 < [
2drop { 0 0 }
] [
>r first2 swap tuck r> validate-col 2array
[ first2 swap tuck ] dip validate-col 2array
] if
] if ;
@ -131,7 +135,7 @@ TUPLE: document < model locs ;
value>> "\n" join ;
: set-doc-string ( string document -- )
>r string-lines V{ } like r> [ set-model ] keep
[ string-lines V{ } like ] dip [ set-model ] keep
[ doc-end ] [ update-locs ] bi ;
: clear-doc ( document -- )
@ -141,17 +145,17 @@ GENERIC: prev-elt ( loc document elt -- newloc )
GENERIC: next-elt ( loc document elt -- newloc )
: prev/next-elt ( loc document elt -- start end )
3dup next-elt >r prev-elt r> ;
[ prev-elt ] [ next-elt ] 3bi ;
: elt-string ( loc document elt -- string )
over >r prev/next-elt r> doc-range ;
[ prev/next-elt ] [ drop ] 2bi doc-range ;
TUPLE: char-elt ;
: (prev-char) ( loc document quot -- loc )
-rot {
{ [ over { 0 0 } = ] [ drop ] }
{ [ over second zero? ] [ >r first 1- r> line-end ] }
{ [ over second zero? ] [ [ first 1- ] dip line-end ] }
[ pick call ]
} cond nip ; inline
@ -175,14 +179,14 @@ M: one-char-elt prev-elt 2drop ;
M: one-char-elt next-elt 2drop ;
: (word-elt) ( loc document quot -- loc )
pick >r
>r >r first2 swap r> doc-line r> call
r> =col ; inline
pick [
[ [ first2 swap ] dip doc-line ] dip call
] dip =col ; inline
: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
: break-detector ( ? -- quot )
[ >r blank? r> xor ] curry ; inline
[ [ blank? ] dip xor ] curry ; inline
: (prev-word) ( ? col str -- col )
rot break-detector find-last-from drop ?1+ ;
@ -195,17 +199,17 @@ TUPLE: one-word-elt ;
M: one-word-elt prev-elt
drop
[ f -rot >r 1- r> (prev-word) ] (word-elt) ;
[ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
M: one-word-elt next-elt
drop
[ f -rot (next-word) ] (word-elt) ;
[ [ f ] 2dip (next-word) ] (word-elt) ;
TUPLE: word-elt ;
M: word-elt prev-elt
drop
[ [ >r 1- r> ((word-elt)) (prev-word) ] (word-elt) ]
[ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
(prev-char) ;
M: word-elt next-elt
@ -219,7 +223,7 @@ M: one-line-elt prev-elt
2drop first 0 2array ;
M: one-line-elt next-elt
drop >r first dup r> doc-line length 2array ;
drop [ first dup ] dip doc-line length 2array ;
TUPLE: line-elt ;

View File

@ -0,0 +1 @@
Marc Fauconneau

View File

@ -0,0 +1,16 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 make ;
IN: editors.notepad2
: notepad2-path ( -- str )
\ notepad2-path get-global [
program-files "C:\\Windows\\system32\\notepad.exe" append-path
] unless* ;
: notepad2 ( file line -- )
[
notepad2-path ,
"/g" , number>string , ,
] { } make run-detached drop ;
[ notepad2 ] edit-hook set-global

View File

@ -0,0 +1 @@
Notepad2 editor integration

View File

@ -0,0 +1 @@
unportable

View File

@ -15,10 +15,13 @@ HELP: fry
} ;
HELP: '[
{ $syntax "code... ]" }
{ $syntax "'[ code... ]" }
{ $description "Literal fried quotation. Expands into code which takes values from the stack and substitutes them in place of the fry specifiers " { $link _ } " and " { $link @ } "." }
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: >r/r>-in-fry-error
{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to " { $link >r } " or " { $link r> } ". Explicit retain stack manipulation of this form does not work with fry; use " { $link dip } " instead." } ;
ARTICLE: "fry.examples" "Examples of fried quotations"
"The easiest way to understand fried quotations is to look at some examples."
$nl
@ -49,6 +52,8 @@ $nl
"{ 8 13 14 27 } [ even? ] 5 [ dup ] swap [ ? ] curry 3compose map"
"{ 8 13 14 27 } [ even? dup 5 ? ] map"
}
"The following is a no-op:"
{ $code "'[ @ ]" }
"Here are some built-in combinators rewritten in terms of fried quotations:"
{ $table
{ { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
@ -71,21 +76,27 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
} ;
ARTICLE: "fry.limitations" "Fried quotation limitations"
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead." ;
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead."
$nl
"An error thrown if a fried quotation contains calls to " { $link >r } " and " { $link r> } ":"
{ $subsection >r/r>-in-fry-error } ;
ARTICLE: "fry" "Fried quotations"
"A " { $emphasis "fried quotation" } " differs from a literal quotation in that when it is evaluated, instead of just pushing itself on the stack, it consumes zero or more stack values and inserts them into the quotation."
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
$nl
"Fried quotations are denoted with a special parsing word:"
"Fried quotations are started by a special parsing word:"
{ $subsection POSTPONE: '[ }
"Fried quotations contain zero or more " { $emphasis "fry specifiers" } ":"
"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:"
{ $subsection _ }
{ $subsection @ }
"When a fried quotation is being evaluated, values are consumed from the stack and spliced into the quotation from right to left."
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
{ $subsection "fry.examples" }
{ $subsection "fry.philosophy" }
{ $subsection "fry.limitations" }
"Quotations can also be fried without using a parsing word:"
{ $subsection fry } ;
"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
$nl
"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
{ $subsection fry }
"Fried quotations are an abstraction on top of the " { $link "compositional-combinators" } "; their use is encouraged over the combinators, because often the fry form is shorter and clearer than the combinator form." ;
ABOUT: "fry"

View File

@ -1,23 +1,20 @@
IN: fry.tests
USING: fry tools.test math prettyprint kernel io arrays
sequences ;
sequences eval accessors ;
[ [ 3 + ] ] [ 3 '[ _ + ] ] unit-test
[ [ 1 3 + ] ] [ 1 3 '[ _ _ + ] ] unit-test
[ [ 1 + ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
[ [ 1 [ + ] call ] ] [ 1 [ + ] '[ _ @ ] ] unit-test
[ [ 1 + . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
[ [ 1 [ + ] call . ] ] [ 1 [ + ] '[ _ @ . ] ] unit-test
[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
[ [ [ + ] [ - ] [ call ] dip call ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
[ [ "a" write "b" print ] ]
[ [ "a" "b" [ write ] dip print ] ]
[ "a" "b" '[ _ write _ print ] ] unit-test
[ [ 1 2 + 3 4 - ] ]
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
[ 1/2 ] [
1 '[ [ _ ] dip / ] 2 swap call
] unit-test
@ -58,3 +55,10 @@ sequences ;
[ { { { 3 } } } ] [
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
[ "USING: fry kernel ; f '[ >r _ r> ]" eval ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
1 2 3 4 '[ "a" _ 2array "b" _ 2array "c" _ 2array "d" _ 2array 4array ] call
] unit-test

View File

@ -1,33 +1,37 @@
! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences combinators parser splitting math
quotations arrays make words ;
quotations arrays make words locals.backend summary sets ;
IN: fry
: _ ( -- * ) "Only valid inside a fry" throw ;
: @ ( -- * ) "Only valid inside a fry" throw ;
ERROR: >r/r>-in-fry-error ;
<PRIVATE
DEFER: (shallow-fry)
DEFER: shallow-fry
: [ncurry] ( n -- quot )
{
{ 0 [ [ ] ] }
{ 1 [ [ curry ] ] }
{ 2 [ [ 2curry ] ] }
{ 3 [ [ 3curry ] ] }
[ \ curry <repetition> ]
} case ;
: ((shallow-fry)) ( accum quot adder -- result )
>r shallow-fry r>
append swap [
[ prepose ] curry append
] unless-empty ; inline
M: >r/r>-in-fry-error summary
drop
"Explicit retain stack manipulation is not permitted in fried quotations" ;
: (shallow-fry) ( accum quot -- result )
[ 1quotation ] [
unclip {
{ \ _ [ [ curry ] ((shallow-fry)) ] }
{ \ @ [ [ compose ] ((shallow-fry)) ] }
[ swap >r suffix r> (shallow-fry) ]
} case
] if-empty ;
: check-fry ( quot -- quot )
dup { >r r> load-locals get-local drop-locals } intersect
empty? [ >r/r>-in-fry-error ] unless ;
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
: shallow-fry ( quot -- quot' )
check-fry
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
{ _ } split [ length 1- [ncurry] ] [ spread>quot ] bi prefix ;
PREDICATE: fry-specifier < word { _ @ } memq? ;

View File

@ -36,3 +36,5 @@ IN: generalizations.tests
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
[ ] [ { } 0 firstn ] unit-test
[ "a" ] [ { "a" } 1 firstn ] unit-test
[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test

View File

@ -6,8 +6,11 @@ math.ranges combinators macros quotations fry arrays ;
IN: generalizations
MACRO: nsequence ( n seq -- quot )
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce ;
[
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
] keep
'[ @ _ like ] ;
MACRO: narray ( n -- quot )
'[ _ { } nsequence ] ;

View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax io kernel math namespaces parser
prettyprint sequences vocabs.loader namespaces stack-checker ;
prettyprint sequences vocabs.loader namespaces stack-checker
help ;
IN: help.cookbook
ARTICLE: "cookbook-syntax" "Basic syntax cookbook"
@ -324,6 +325,19 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
} ;
ARTICLE: "cookbook-next" "Next steps"
"Once you have read through " { $link "first-program" } " and " { $link "cookbook" } ", the best way to keep learning Factor is to start looking at some simple example programs. Here are a few particularly nice vocabularies which should keep you busy for a little while:"
{ $list
{ $vocab-link "base64" }
{ $vocab-link "roman" }
{ $vocab-link "rot13" }
{ $vocab-link "smtp" }
{ $vocab-link "time-server" }
{ $vocab-link "tools.hexdump" }
{ $vocab-link "webapps.counter" }
}
"If you see code in there that you do not understand, use " { $link see } " and " { $link help } " to explore." ;
ARTICLE: "cookbook" "Factor cookbook"
"The Factor cookbook is a high-level overview of the most important concepts required to program in Factor."
{ $subsection "cookbook-syntax" }
@ -336,6 +350,7 @@ ARTICLE: "cookbook" "Factor cookbook"
{ $subsection "cookbook-scripts" }
{ $subsection "cookbook-compiler" }
{ $subsection "cookbook-philosophy" }
{ $subsection "cookbook-pitfalls" } ;
{ $subsection "cookbook-pitfalls" }
{ $subsection "cookbook-next" } ;
ABOUT: "cookbook"

View File

@ -34,7 +34,7 @@ IN: help.definitions.tests
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ; HELP: xxx ;" eval ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup help ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup >link synopsis print ] unit-test
] with-file-vocabs

View File

@ -1,8 +1,8 @@
IN: help.handbook.tests
USING: help tools.test ;
[ ] [ "article-index" help ] unit-test
[ ] [ "primitive-index" help ] unit-test
[ ] [ "error-index" help ] unit-test
[ ] [ "type-index" help ] unit-test
[ ] [ "class-index" help ] unit-test
[ ] [ "article-index" print-topic ] unit-test
[ ] [ "primitive-index" print-topic ] unit-test
[ ] [ "error-index" print-topic ] unit-test
[ ] [ "type-index" print-topic ] unit-test
[ ] [ "class-index" print-topic ] unit-test

View File

@ -65,6 +65,11 @@ $nl
{ "word" { "the basic unit of code, analogous to a function or procedure in other programming languages. See " { $link "words" } } }
} ;
ARTICLE: "tail-call-opt" "Tail-call optimization"
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $emphasis "tail-call optimization" } " and the Factor implementation guarantees that it will be performed."
$nl
"Tail-call optimization allows iterative algorithms to be implemented in an efficient manner using recursion, without the need for any kind of primitive looping construct in the language. However, in practice, most iteration is performed via combinators such as " { $link while } ", " { $link each } ", " { $link map } ", " { $link assoc-each } ", and so on. The definitions of these combinators do bottom-out in recursive words, however." ;
ARTICLE: "evaluator" "Evaluation semantics"
{ $link "quotations" } " are evaluated sequentially from beginning to end. When the end is reached, the quotation returns to its caller. As each object in the quotation is evaluated in turn, an action is taken based on its type:"
{ $list
@ -72,7 +77,7 @@ ARTICLE: "evaluator" "Evaluation semantics"
{ "a " { $link wrapper } " - the wrapped object is pushed on the data stack. Wrappers are used to push word objects directly on the stack when they would otherwise execute. See the " { $link POSTPONE: \ } " parsing word." }
{ "All other types of objects are pushed on the data stack." }
}
"If the last action performed is the execution of a word, the current quotation is not saved on the call stack; this is known as " { $snippet "tail-recursion" } " and allows iterative algorithms to execute without incurring unbounded call stack usage."
{ $subsection "tail-call-opt" }
{ $see-also "compiler" } ;
ARTICLE: "objects" "Objects"

View File

@ -129,12 +129,17 @@ HELP: $title
{ $values { "topic" "a help article name or a word" } }
{ $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ;
HELP: print-topic
{ $values { "topic" "an article name or a word" } }
{ $description
"Displays a help topic on " { $link output-stream } "."
} ;
HELP: help
{ $values { "topic" "an article name or a word" } }
{ $description
"Displays a help article or documentation associated to a word on " { $link output-stream } "."
"Displays a help topic."
} ;
HELP: about
{ $values { "vocab" "a vocabulary specifier" } }
{ $description

View File

@ -19,7 +19,7 @@ GENERIC: word-help* ( word -- content )
{ { "object" object } { "?" "a boolean" } } $values
[
"Tests if the object is an instance of the " ,
first "predicating" word-prop \ $link swap 2array ,
first "predicating" word-prop <$link> ,
" class." ,
] { } make $description ;
@ -58,15 +58,36 @@ M: word article-title
append
] if ;
M: word article-content
<PRIVATE
: (word-help) ( word -- element )
[
\ $vocabulary over 2array ,
dup word-help %
\ $related over 2array ,
dup get-global [ \ $value swap 2array , ] when*
\ $definition swap 2array ,
{
[ \ $vocabulary swap 2array , ]
[ word-help % ]
[ \ $related swap 2array , ]
[ get-global [ \ $value swap 2array , ] when* ]
[ \ $definition swap 2array , ]
} cleave
] { } make ;
M: word article-content (word-help) ;
<PRIVATE
: word-with-methods ( word -- elements )
[
[ (word-help) % ]
[ \ $methods swap 2array , ]
bi
] { } make ;
PRIVATE>
M: generic article-content word-with-methods ;
M: class article-content word-with-methods ;
M: word article-parent "help-parent" word-prop ;
M: word set-article-parent swap "help-parent" set-word-prop ;
@ -89,10 +110,17 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
] with-nesting
] with-style nl ;
: help ( topic -- )
: print-topic ( topic -- )
last-element off dup $title
article-content print-content nl ;
SYMBOL: help-hook
help-hook global [ [ print-topic ] or ] change-at
: help ( topic -- )
help-hook get call ;
: about ( vocab -- )
dup require
dup vocab [ ] [

View File

@ -68,7 +68,7 @@ IN: help.lint
] each ;
: check-rendering ( word element -- )
[ help ] with-string-writer drop ;
[ print-topic ] with-string-writer drop ;
: all-word-help ( words -- seq )
[ word-help ] filter ;

View File

@ -6,12 +6,12 @@ TUPLE: blahblah quux ;
[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test
[ ] [ \ quux>> help ] unit-test
[ ] [ \ >>quux help ] unit-test
[ ] [ \ blahblah? help ] unit-test
[ ] [ \ quux>> print-topic ] unit-test
[ ] [ \ >>quux print-topic ] unit-test
[ ] [ \ blahblah? print-topic ] unit-test
: fooey "fooey" throw ;
[ ] [ \ fooey help ] unit-test
[ ] [ \ fooey print-topic ] unit-test
[ ] [ gensym help ] unit-test
[ ] [ gensym print-topic ] unit-test

View File

@ -285,11 +285,16 @@ M: f ($instance)
: $see ( element -- ) first [ see ] ($see) ;
: $see-methods ( element -- ) first [ see-methods ] ($see) ;
: $synopsis ( element -- ) first [ synopsis write ] ($see) ;
: $definition ( element -- )
"Definition" $heading $see ;
: $methods ( element -- )
"Methods" $heading $see-methods ;
: $value ( object -- )
"Variable value" $heading
"Current value in global namespace:" print-element
@ -348,3 +353,6 @@ M: array elements*
] each
] curry each
] H{ } make-assoc keys ;
: <$link> ( topic -- element )
\ $link swap 2array ;

View File

@ -6,11 +6,8 @@ IN: html.templates.fhtml.tests
: test-template ( path -- ? )
"resource:basis/html/templates/fhtml/test/"
prepend
[
".fhtml" append <fhtml> [ call-template ] with-string-writer
<string-reader> lines
] keep
".html" append utf8 file-lines
[ ".fhtml" append <fhtml> [ call-template ] with-string-writer ]
[ ".html" append utf8 file-contents ] bi
[ . . ] [ = ] 2bi ;
[ t ] [ "example" test-template ] unit-test

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: calendar io io.files kernel math math.order
math.parser namespaces parser sequences strings
assocs hashtables debugger mime-types sorting logging
assocs hashtables debugger mime.types sorting logging
calendar.format accessors splitting
io.encodings.binary fry xml.entities destructors urls
html.elements html.templates.fhtml

View File

@ -3,7 +3,7 @@
USING: accessors combinators kernel system unicode.case
io.unix.files io.files.listing generalizations strings
arrays sequences io.files math.parser unix.groups unix.users
io.files.listing.private ;
io.files.listing.private unix.stat math ;
IN: io.files.listing.unix
<PRIVATE
@ -30,6 +30,18 @@ IN: io.files.listing.unix
[ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ]
} cleave 10 narray concat ;
: mode>symbol ( mode -- ch )
S_IFMT bitand
{
{ [ dup S_IFDIR = ] [ drop "/" ] }
{ [ dup S_IFIFO = ] [ drop "|" ] }
{ [ dup any-execute? ] [ drop "*" ] }
{ [ dup S_IFLNK = ] [ drop "@" ] }
{ [ dup S_IFWHT = ] [ drop "%" ] }
{ [ dup S_IFSOCK = ] [ drop "=" ] }
{ [ t ] [ drop "" ] }
} cond ;
M: unix (directory.) ( path -- lines )
[ [
[

View File

@ -6,7 +6,8 @@ math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private destructors vocabs.loader calendar.unix
unix.stat alien.c-types arrays unix.users unix.groups
environment fry io.encodings.utf8 alien.strings unix.statfs ;
environment fry io.encodings.utf8 alien.strings unix.statfs
combinators.short-circuit ;
IN: io.unix.files
M: unix cwd ( -- path )
@ -117,8 +118,8 @@ M: unix stat>file-info ( stat -- file-info )
[ stat-st_blksize >>blocksize ]
} cleave ;
M: unix stat>type ( stat -- type )
stat-st_mode S_IFMT bitand {
: n>file-type ( n -- type )
S_IFMT bitand {
{ S_IFREG [ +regular-file+ ] }
{ S_IFDIR [ +directory+ ] }
{ S_IFCHR [ +character-device+ ] }
@ -129,6 +130,9 @@ M: unix stat>type ( stat -- type )
[ drop +unknown+ ]
} case ;
M: unix stat>type ( stat -- type )
stat-st_mode n>file-type ;
! Linux has no extra fields in its stat struct
os {
{ macosx [ "io.unix.files.bsd" require ] }
@ -150,7 +154,7 @@ os {
M: unix >directory-entry ( byte-array -- directory-entry )
[ dirent-d_name utf8 alien>string ]
[ dirent-d_type ] bi directory-entry boa ;
[ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
M: unix (directory-entries) ( path -- seq )
[
@ -225,6 +229,15 @@ GENERIC: other-read? ( obj -- ? )
GENERIC: other-write? ( obj -- ? )
GENERIC: other-execute? ( obj -- ? )
: any-read? ( obj -- ? )
{ [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
: any-write? ( obj -- ? )
{ [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
: any-execute? ( obj -- ? )
{ [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
M: integer uid? ( integer -- ? ) UID mask? ;
M: integer gid? ( integer -- ? ) GID mask? ;
M: integer sticky? ( integer -- ? ) STICKY mask? ;

View File

@ -114,11 +114,6 @@ M: windows delete-directory ( path -- )
normalize-path
RemoveDirectory win32-error=0/f ;
M: windows >directory-entry ( byte-array -- directory-entry )
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
[ WIN32_FIND_DATA-dwFileAttributes ]
bi directory-entry boa ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object> tuck
FindFirstFile
@ -177,6 +172,15 @@ TUPLE: windows-file-info < file-info attributes ;
: win32-file-type ( n -- symbol )
FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
TUPLE: windows-directory-entry < directory-entry attributes ;
M: windows >directory-entry ( byte-array -- directory-entry )
[ WIN32_FIND_DATA-cFileName utf16n alien>string ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-type ]
[ WIN32_FIND_DATA-dwFileAttributes win32-file-attributes ]
tri
dupd remove windows-directory-entry boa ;
: WIN32_FIND_DATA>file-info ( WIN32_FIND_DATA -- file-info )
[ \ windows-file-info new ] dip
{

View File

@ -1,34 +1,60 @@
USING: help.markup help.syntax kernel io system prettyprint ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
{ $subsection visible-vars }
"To add or remove a single variable:"
{ $subsection show-var }
{ $subsection hide-var }
"To add and remove multiple variables:"
{ $subsection show-vars }
{ $subsection hide-vars }
"Hiding all visible variables:"
{ $subsection hide-all-vars } ;
HELP: show-var
{ $values { "var" "a variable name" } }
{ $description "Adds a variable to the watch list; its value will be printed by the listener after every expression." } ;
HELP: show-vars
{ $values { "seq" "a sequence of variable names" } }
{ $description "Adds a sequence of variables to the watch list; their values will be printed by the listener after every expression." } ;
HELP: hide-var
{ $values { "var" "a variable name" } }
{ $description "Removes a variable from the watch list." } ;
HELP: hide-vars
{ $values { "seq" "a sequence of variable names" } }
{ $description "Removes a sequence of variables from the watch list." } ;
HELP: hide-all-vars
{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener"
"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
$nl
"The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" }
"Multi-line phrases are supported:"
"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
$nl
"A very common operation is to inspect the contents of the data stack in the listener:"
{ $subsection .s }
"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "."
$nl
{ $subsection "listener-watch" }
"You can start a nested listener or exit a listener using the following words:"
{ $subsection listener }
{ $subsection bye }
"The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:"
{ $subsection listener-hook }
"Finally, the multi-line expression reading word can be used independently of the rest of the listener:"
{ $subsection read-quot } ;
ABOUT: "listener"
<PRIVATE
HELP: quit-flag
{ $var-description "Variable set to true by " { $link bye } " word; it forces the next iteration of the " { $link listener } " loop to end." } ;
HELP: listener-hook
{ $var-description "Variable holding a quotation called by the listener before reading an input expression. The UI sets this variable to a quotation which updates the stack display in a listener gadget." } ;
PRIVATE>
HELP: read-quot
{ $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } }

View File

@ -3,16 +3,10 @@
USING: arrays hashtables io kernel math math.parser memory
namespaces parser lexer sequences strings io.styles
vectors words generic system combinators continuations debugger
definitions compiler.units accessors colors ;
definitions compiler.units accessors colors prettyprint fry
sets ;
IN: listener
SYMBOL: quit-flag
SYMBOL: listener-hook
[ ] listener-hook set-global
GENERIC: stream-read-quot ( stream -- quot/f )
: parse-lines-interactive ( lines -- quot/f )
@ -38,18 +32,65 @@ M: object stream-read-quot
: read-quot ( -- quot/f ) input-stream get stream-read-quot ;
<PRIVATE
SYMBOL: quit-flag
PRIVATE>
: bye ( -- ) quit-flag on ;
: prompt. ( -- )
"( " in get " )" 3append
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
SYMBOL: visible-vars
: show-var ( var -- ) visible-vars [ swap suffix ] change ;
: show-vars ( seq -- ) visible-vars [ swap union ] change ;
: hide-var ( var -- ) visible-vars [ remove ] change ;
: hide-vars ( seq -- ) visible-vars [ swap diff ] change ;
: hide-all-vars ( -- ) visible-vars off ;
SYMBOL: error-hook
[ print-error-and-restarts ] error-hook set-global
<PRIVATE
: title. ( string -- )
H{ { foreground T{ rgba f 0.3 0.3 0.3 1 } } } format nl ;
: visible-vars. ( -- )
visible-vars get [
nl "--- Watched variables:" title.
standard-table-style [
[
[
[ [ short. ] with-cell ]
[ [ get short. ] with-cell ]
bi
] with-row
] each
] tabular-output
] unless-empty ;
SYMBOL: display-stacks?
t display-stacks? set-global
: stacks. ( -- )
display-stacks? get [
datastack [ nl "--- Data stack:" title. stack. ] unless-empty
retainstack [ nl "--- Retain stack:" title. stack. ] unless-empty
] when ;
: prompt. ( -- )
"( " in get auto-use? get [ " - auto" append ] when " )" 3append
H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ;
: listen ( -- )
listener-hook get call prompt.
visible-vars. stacks. prompt.
[ read-quot [ [ error-hook get call ] recover ] [ bye ] if* ]
[
dup lexer-error? [
@ -62,6 +103,8 @@ SYMBOL: error-hook
: until-quit ( -- )
quit-flag get [ quit-flag off ] [ listen until-quit ] if ;
PRIVATE>
: listener ( -- )
[ until-quit ] with-interactive-vocabs ;

View File

@ -132,8 +132,8 @@ $nl
"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
ARTICLE: "locals-limitations" "Limitations of locals"
"The first limitation is that the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator."
$nl
"The first limitation is also shared by " { $vocab-link "fry" } ": the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator. An error is thrown at parse time if an attempt is made to use " { $link >r } " and " { $link r> } " inside a lambda body:"
{ $subsection >r/r>-in-lambda-error }
"Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:"
{ $code
":: good-cond-usage ( a -- ... )"

View File

@ -2,7 +2,7 @@ USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint io.streams.string parser
accessors generic eval combinators combinators.short-circuit
combinators.short-circuit.smart math.order math.functions
definitions compiler.units ;
definitions compiler.units fry ;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@ -286,6 +286,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ [ a b > ] [ 5 ] }
} cond ;
\ cond-test must-infer
[ 3 ] [ 1 2 cond-test ] unit-test
[ 4 ] [ 2 2 cond-test ] unit-test
[ 5 ] [ 3 2 cond-test ] unit-test
@ -293,6 +295,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
:: 0&&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } 0&& ;
\ 0&&-test must-infer
[ f ] [ 1.5 0&&-test ] unit-test
[ f ] [ 3 0&&-test ] unit-test
[ f ] [ 8 0&&-test ] unit-test
@ -301,6 +305,8 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
:: &&-test ( a -- ? )
{ [ a integer? ] [ a even? ] [ a 10 > ] } && ;
\ &&-test must-infer
[ f ] [ 1.5 &&-test ] unit-test
[ f ] [ 3 &&-test ] unit-test
[ f ] [ 8 &&-test ] unit-test
@ -346,6 +352,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
ERROR: punned-class x ;
[ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
:: literal-identity-test ( -- a b )
{ } V{ } ;
@ -388,6 +398,20 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
[
"USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
\ funny-macro-test must-infer
[ t ] [ 3 funny-macro-test ] unit-test
[ f ] [ 2 funny-macro-test ] unit-test
! :: wlet-&&-test ( a -- ? )
! [wlet | is-integer? [ a integer? ]
! is-even? [ a even? ]

View File

@ -6,12 +6,18 @@ quotations debugger macros arrays macros splitting combinators
prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
locals.backend memoize macros.expander lexer classes ;
locals.backend memoize macros.expander lexer classes summary ;
IN: locals
! Inspired by
! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
ERROR: >r/r>-in-lambda-error ;
M: >r/r>-in-lambda-error summary
drop
"Explicit retain stack manipulation is not permitted in lambda bodies" ;
<PRIVATE
TUPLE: lambda vars body ;
@ -141,20 +147,17 @@ GENERIC: free-vars* ( form -- )
: free-vars ( form -- vars )
[ free-vars* ] { } make prune ;
: add-if-free ( object -- )
{
{ [ dup local-writer? ] [ "local-reader" word-prop , ] }
{ [ dup lexical? ] [ , ] }
{ [ dup quote? ] [ local>> , ] }
{ [ t ] [ free-vars* ] }
} cond ;
M: local-writer free-vars* "local-reader" word-prop , ;
M: lexical free-vars* , ;
M: quote free-vars* , ;
M: object free-vars* drop ;
M: quotation free-vars* [ add-if-free ] each ;
M: quotation free-vars* [ free-vars* ] each ;
M: lambda free-vars*
[ vars>> ] [ body>> ] bi free-vars swap diff % ;
M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ;
GENERIC: lambda-rewrite* ( obj -- )
@ -201,6 +204,8 @@ M: special rewrite-literal? drop t ;
M: array rewrite-literal? [ rewrite-literal? ] contains? ;
M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
M: hashtable rewrite-literal? drop t ;
M: vector rewrite-literal? drop t ;
@ -215,17 +220,20 @@ GENERIC: rewrite-element ( obj -- )
[ rewrite-element ] each ;
: rewrite-sequence ( seq -- )
[ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
[ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: quotation rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: vector rewrite-element rewrite-sequence ;
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: tuple rewrite-element
[ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ;
[ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
M: local rewrite-element , ;
@ -243,6 +251,10 @@ M: tuple local-rewrite* rewrite-element ;
M: hashtable local-rewrite* rewrite-element ;
M: word local-rewrite*
dup { >r r> } memq?
[ >r/r>-in-lambda-error ] [ call-next-method ] if ;
M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
@ -277,14 +289,18 @@ SYMBOL: in-lambda?
\ ] (parse-lambda) <lambda> ;
: parse-binding ( -- pair/f )
scan dup "|" = [
drop f
] [
scan {
{ "[" [ \ ] parse-until >quotation ] }
{ "[|" [ parse-lambda ] }
} case 2array
] if ;
scan {
{ [ dup "|" = ] [ drop f ] }
{ [ dup "!" = ] [ drop lexer get next-line parse-binding ] }
{ [ t ]
[
scan {
{ "[" [ \ ] parse-until >quotation ] }
{ "[|" [ parse-lambda ] }
} case 2array
]
}
} cond ;
: (parse-bindings) ( -- )
parse-binding [

View File

@ -37,9 +37,17 @@ M: wrapper expand-macros* wrapped>> literal ;
[ '[ _ ndrop _ nnip call ] [ ] like ] 2map , \ dispatch ,
] bi ;
: expand-macro ( quot -- )
stack [ swap with-datastack >vector ] change
stack get pop >quotation end (expand-macros) ;
: word, ( word -- ) end , ;
: expand-macro ( word quot -- )
'[
drop
stack [ _ with-datastack >vector ] change
stack get pop >quotation end (expand-macros)
] [
drop
word,
] recover ;
: expand-macro? ( word -- quot ? )
dup [ "transform-quot" word-prop ] [ "macro" word-prop ] bi or dup [
@ -47,11 +55,9 @@ M: wrapper expand-macros* wrapped>> literal ;
stack get length <=
] [ 2drop f f ] if ;
: word, ( word -- ) end , ;
M: word expand-macros*
dup expand-dispatch? [ drop expand-dispatch ] [
dup expand-macro? [ nip expand-macro ] [
dup expand-macro? [ expand-macro ] [
drop word,
] if
] if ;

View File

@ -310,8 +310,9 @@ ARTICLE: "math-bitfields" "Constructing bit fields"
"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
{ $subsection bitfield } ;
ARTICLE: "math.bitwise" "Bitwise arithmetic"
"The " { $vocab-link "math.bitwise" } " vocabulary can implements bitwise arithmetic words that are useful for efficiency, low-level programming, and interfacing with C libraries." $nl
ARTICLE: "math.bitwise" "Additional bitwise arithmetic"
"The " { $vocab-link "math.bitwise" } " vocabulary provides bitwise arithmetic words extending " { $link "bitwise-arithmetic" } ". They are useful for efficiency, low-level programming, and interfacing with C libraries."
$nl
"Setting and clearing bits:"
{ $subsection set-bit }
{ $subsection clear-bit }

View File

@ -47,3 +47,21 @@ HELP: <zero-rect>
{ $values { "rect" "a new " { $link rect } } }
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
ARTICLE: "math.geometry.rect" "Rectangles"
"The " { $vocab-link "math.geometry.rect" } " vocabulary defines a rectangle data type and operations on them."
{ $subsection rect }
"Rectangles can be taken apart:"
{ $subsection rect-loc }
{ $subsection rect-dim }
{ $subsection rect-bounds }
{ $subsection rect-extent }
"New rectangles can be created:"
{ $subsection <zero-rect> }
{ $subsection <rect> }
{ $subsection <extent-rect> }
"More utility words for working with rectangles:"
{ $subsection offset-rect }
{ $subsection rect-intersect }
{ $subsection intersects? } ;
ABOUT: "math.geometry.rect"

View File

@ -29,6 +29,8 @@ M: word integer-op-input-classes
{ fixnum- fixnum-fast }
{ fixnum* fixnum*fast }
{ fixnum-shift fixnum-shift-fast }
{ fixnum/i fixnum/i-fast }
{ fixnum/mod fixnum/mod-fast }
} at ;
: modular-variant ( op -- fast-op )

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,248 @@
USING: accessors io io.streams.string kernel mime.multipart
tools.test make multiline ;
IN: mime.multipart.tests
[ { "a" f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" "a" f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "aa" f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "aa" f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "aa" f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "aa" f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" f } ] [
[
"azzbzzczzdzz" <string-reader> "zz" <multipart-stream> 1 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" "zz" } ] [
[
"azzbzzczzdzz" <string-reader> "zzz" <multipart-stream> 1 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 1 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "az" "zb" "zz" "cz" "zd" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 2 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" "zzb" "zzc" "zzd" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 3 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "az" "zbzz" "czzd" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 4 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "azz" "bzzcz" "zd" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 5 >>n
[ , ] [ ] multipart-step-loop drop
] { } make
] unit-test
[ { "a" f f "b" f f "c" f f "d" f f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "a" f f "b" f f "c" f f "d" f f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "a" f f "b" f f "c" f f "d" f f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "a" f f "b" f f "c" f f "d" f f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "a" f f "b" f f "c" f f "d" f f } ] [
[
"azzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "a" "a" f f "b" f f "c" f f "d" f f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 1 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "aa" f f "b" f f "c" f f "d" f f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 2 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "aa" f f "b" f f "c" f f "d" f f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 3 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "aa" f f "b" f f "c" f f "d" f f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 4 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "aa" f f "b" f f "c" f f "d" f f } ] [
[
"aazzbzzczzdzz" <string-reader> "z" <multipart-stream> 5 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "a" f "b" f "c" f "d" f } ] [
[
"azzbzzczzdzz" <string-reader> "zz" <multipart-stream> 1 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" "zz" } ] [
[
"azzbzzczzdzz" <string-reader> "zzz" <multipart-stream> 1 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "a" "z" "z" "b" "z" "z" "c" "z" "z" "d" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 1 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "az" "zb" "zz" "cz" "zd" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 2 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "a" "zzb" "zzc" "zzd" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 3 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "az" "zbzz" "czzd" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 4 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test
[ { "azz" "bzzcz" "zd" f } ] [
[
"azzbzzczzdzzz" <string-reader> "zzz" <multipart-stream> 5 >>n
[ , ] [ ] multipart-loop-all
] { } make
] unit-test

View File

@ -0,0 +1,62 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators io kernel locals math multiline
sequences splitting ;
IN: mime.multipart
TUPLE: multipart-stream stream n leftover separator ;
: <multipart-stream> ( stream separator -- multipart-stream )
multipart-stream new
swap >>separator
swap >>stream
16 2^ >>n ;
<PRIVATE
: ?append ( seq1 seq2 -- newseq/seq2 )
over [ append ] [ nip ] if ;
: ?cut* ( seq n -- before after )
over length over <= [ drop f swap ] [ cut* ] if ;
: read-n ( stream -- bytes end-stream? )
[ f ] change-leftover
[ n>> ] [ stream>> ] bi stream-read [ ?append ] keep not ;
: multipart-split ( bytes separator -- before after seq=? )
2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
PRIVATE>
:: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
#! return t to loop again
bytes separator multipart-split [ dup >boolean ] dip [
! separator == input
3drop f quot call f
] [
[
! found
[ quot unless-empty ]
[
stream (>>leftover)
quot unless-empty
] if-empty f quot call f
] [
! not found
drop
end-stream? [
quot unless-empty f
] [
separator length 1- ?cut* stream (>>leftover)
quot unless-empty t
] if
] if
] if stream leftover>> end-stream? not or ;
:: multipart-step-loop ( stream quot1: ( bytes -- ) quot2: ( -- ) -- ? )
stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
swap [ drop stream quot1 quot2 multipart-step-loop ] quot2 if ;
: multipart-loop-all ( stream quot1: ( bytes -- ) quot2: ( -- ) -- )
3dup multipart-step-loop [ multipart-loop-all ] [ 3drop ] if ;

1
basis/mime/types/authors.txt Executable file
View File

@ -0,0 +1 @@
Slava Pestov

988
basis/mime/types/mime.types Normal file
View File

@ -0,0 +1,988 @@
# This is a comment. I love comments.
# This file controls what Internet media types are sent to the client for
# given file extension(s). Sending the correct media type to the client
# is important so they know how to handle the content of the file.
# Extra types can either be added here or by using an AddType directive
# in your config files. For more information about Internet media types,
# please read RFC 2045, 2046, 2047, 2048, and 2077. The Internet media type
# registry is at <http://www.iana.org/assignments/media-types/>.
# MIME type Extensions
application/activemessage
application/andrew-inset ez
application/applefile
application/atom+xml atom
application/atomcat+xml atomcat
application/atomicmail
application/atomsvc+xml atomsvc
application/auth-policy+xml
application/batch-smtp
application/beep+xml
application/cals-1840
application/ccxml+xml ccxml
application/cellml+xml
application/cnrp+xml
application/commonground
application/conference-info+xml
application/cpl+xml
application/csta+xml
application/cstadata+xml
application/cybercash
application/davmount+xml davmount
application/dca-rft
application/dec-dx
application/dialog-info+xml
application/dicom
application/dns
application/dvcs
application/ecmascript ecma
application/edi-consent
application/edi-x12
application/edifact
application/epp+xml
application/eshop
application/fastinfoset
application/fastsoap
application/fits
application/font-tdpfr pfr
application/h224
application/http
application/hyperstudio stk
application/iges
application/im-iscomposing+xml
application/index
application/index.cmd
application/index.obj
application/index.response
application/index.vnd
application/iotp
application/ipp
application/isup
application/javascript js
application/json json
application/kpml-request+xml
application/kpml-response+xml
application/mac-binhex40 hqx
application/mac-compactpro cpt
application/macwriteii
application/marc mrc
application/mathematica ma nb mb
application/mathml+xml mathml
application/mbms-associated-procedure-description+xml
application/mbms-deregister+xml
application/mbms-envelope+xml
application/mbms-msk+xml
application/mbms-msk-response+xml
application/mbms-protection-description+xml
application/mbms-reception-report+xml
application/mbms-register+xml
application/mbms-register-response+xml
application/mbms-user-service-description+xml
application/mbox mbox
application/mediaservercontrol+xml mscml
application/mikey
application/mp4 mp4s
application/mpeg4-generic
application/mpeg4-iod
application/mpeg4-iod-xmt
application/msword doc dot
application/mxf mxf
application/nasdata
application/news-message-id
application/news-transmission
application/nss
application/ocsp-request
application/ocsp-response
application/octet-stream bin dms lha lzh class so iso dmg dist distz pkg bpk dump elc scpt
application/oda oda
application/oebps-package+xml
application/ogg ogg
application/parityfec
application/pdf pdf
application/pgp-encrypted pgp
application/pgp-keys
application/pgp-signature asc sig
application/pics-rules prf
application/pidf+xml
application/pkcs10 p10
application/pkcs7-mime p7m p7c
application/pkcs7-signature p7s
application/pkix-cert cer
application/pkix-crl crl
application/pkix-pkipath pkipath
application/pkixcmp pki
application/pls+xml pls
application/poc-settings+xml
application/postscript ai eps ps
application/prs.alvestrand.titrax-sheet
application/prs.cww cww
application/prs.nprend
application/prs.plucker
application/qsig
application/rdf+xml rdf
application/reginfo+xml rif
application/relax-ng-compact-syntax rnc
application/remote-printing
application/resource-lists+xml rl
application/riscos
application/rlmi+xml
application/rls-services+xml rs
application/rsd+xml rsd
application/rss+xml rss
application/rtf rtf
application/rtx
application/samlassertion+xml
application/samlmetadata+xml
application/sbml+xml sbml
application/sdp sdp
application/set-payment
application/set-payment-initiation setpay
application/set-registration
application/set-registration-initiation setreg
application/sgml
application/sgml-open-catalog
application/shf+xml shf
application/sieve
application/simple-filter+xml
application/simple-message-summary
application/simplesymbolcontainer
application/slate
application/smil
application/smil+xml smi smil
application/soap+fastinfoset
application/soap+xml
application/spirits-event+xml
application/srgs gram
application/srgs+xml grxml
application/ssml+xml ssml
application/timestamp-query
application/timestamp-reply
application/tve-trigger
application/vemmi
application/vividence.scriptfile
application/vnd.3gpp.bsf+xml
application/vnd.3gpp.pic-bw-large plb
application/vnd.3gpp.pic-bw-small psb
application/vnd.3gpp.pic-bw-var pvb
application/vnd.3gpp.sms
application/vnd.3gpp2.bcmcsinfo+xml
application/vnd.3gpp2.sms
application/vnd.3m.post-it-notes pwn
application/vnd.accpac.simply.aso aso
application/vnd.accpac.simply.imp imp
application/vnd.acucobol acu
application/vnd.acucorp atc acutc
application/vnd.adobe.xdp+xml xdp
application/vnd.adobe.xfdf xfdf
application/vnd.aether.imp
application/vnd.amiga.ami ami
application/vnd.anser-web-certificate-issue-initiation cii
application/vnd.anser-web-funds-transfer-initiation fti
application/vnd.antix.game-component atx
application/vnd.apple.installer+xml mpkg
application/vnd.audiograph aep
application/vnd.autopackage
application/vnd.avistar+xml
application/vnd.blueice.multipass mpm
application/vnd.bmi bmi
application/vnd.businessobjects rep
application/vnd.cab-jscript
application/vnd.canon-cpdl
application/vnd.canon-lips
application/vnd.cendio.thinlinc.clientconf
application/vnd.chemdraw+xml cdxml
application/vnd.chipnuts.karaoke-mmd mmd
application/vnd.cinderella cdy
application/vnd.cirpack.isdn-ext
application/vnd.claymore cla
application/vnd.clonk.c4group c4g c4d c4f c4p c4u
application/vnd.commerce-battelle
application/vnd.commonspace csp cst
application/vnd.contact.cmsg cdbcmsg
application/vnd.cosmocaller cmc
application/vnd.crick.clicker clkx
application/vnd.crick.clicker.keyboard clkk
application/vnd.crick.clicker.palette clkp
application/vnd.crick.clicker.template clkt
application/vnd.crick.clicker.wordbank clkw
application/vnd.criticaltools.wbs+xml wbs
application/vnd.ctc-posml pml
application/vnd.cups-pdf
application/vnd.cups-postscript
application/vnd.cups-ppd ppd
application/vnd.cups-raster
application/vnd.cups-raw
application/vnd.curl curl
application/vnd.cybank
application/vnd.data-vision.rdz rdz
application/vnd.denovo.fcselayout-link fe_launch
application/vnd.dna dna
application/vnd.dolby.mlp mlp
application/vnd.dpgraph dpg
application/vnd.dreamfactory dfac
application/vnd.dvb.esgcontainer
application/vnd.dvb.ipdcesgaccess
application/vnd.dxr
application/vnd.ecdis-update
application/vnd.ecowin.chart mag
application/vnd.ecowin.filerequest
application/vnd.ecowin.fileupdate
application/vnd.ecowin.series
application/vnd.ecowin.seriesrequest
application/vnd.ecowin.seriesupdate
application/vnd.enliven nml
application/vnd.epson.esf esf
application/vnd.epson.msf msf
application/vnd.epson.quickanime qam
application/vnd.epson.salt slt
application/vnd.epson.ssf ssf
application/vnd.ericsson.quickcall
application/vnd.eszigno3+xml es3 et3
application/vnd.eudora.data
application/vnd.ezpix-album ez2
application/vnd.ezpix-package ez3
application/vnd.fdf fdf
application/vnd.ffsns
application/vnd.fints
application/vnd.flographit gph
application/vnd.fluxtime.clip ftc
application/vnd.framemaker fm frame maker
application/vnd.frogans.fnc fnc
application/vnd.frogans.ltf ltf
application/vnd.fsc.weblaunch fsc
application/vnd.fujitsu.oasys oas
application/vnd.fujitsu.oasys2 oa2
application/vnd.fujitsu.oasys3 oa3
application/vnd.fujitsu.oasysgp fg5
application/vnd.fujitsu.oasysprs bh2
application/vnd.fujixerox.art-ex
application/vnd.fujixerox.art4
application/vnd.fujixerox.hbpl
application/vnd.fujixerox.ddd ddd
application/vnd.fujixerox.docuworks xdw
application/vnd.fujixerox.docuworks.binder xbd
application/vnd.fut-misnet
application/vnd.fuzzysheet fzs
application/vnd.genomatix.tuxedo txd
application/vnd.google-earth.kml+xml kml
application/vnd.google-earth.kmz kmz
application/vnd.grafeq gqf gqs
application/vnd.gridmp
application/vnd.groove-account gac
application/vnd.groove-help ghf
application/vnd.groove-identity-message gim
application/vnd.groove-injector grv
application/vnd.groove-tool-message gtm
application/vnd.groove-tool-template tpl
application/vnd.groove-vcard vcg
application/vnd.handheld-entertainment+xml zmm
application/vnd.hbci hbci
application/vnd.hcl-bireports
application/vnd.hhe.lesson-player les
application/vnd.hp-hpgl hpgl
application/vnd.hp-hpid hpid
application/vnd.hp-hps hps
application/vnd.hp-jlyt jlt
application/vnd.hp-pcl pcl
application/vnd.hp-pclxl pclxl
application/vnd.httphone
application/vnd.hzn-3d-crossword x3d
application/vnd.ibm.afplinedata
application/vnd.ibm.electronic-media
application/vnd.ibm.minipay mpy
application/vnd.ibm.modcap afp listafp list3820
application/vnd.ibm.rights-management irm
application/vnd.ibm.secure-container sc
application/vnd.igloader igl
application/vnd.immervision-ivp ivp
application/vnd.immervision-ivu ivu
application/vnd.informedcontrol.rms+xml
application/vnd.intercon.formnet xpw xpx
application/vnd.intertrust.digibox
application/vnd.intertrust.nncp
application/vnd.intu.qbo qbo
application/vnd.intu.qfx qfx
application/vnd.ipunplugged.rcprofile rcprofile
application/vnd.irepository.package+xml irp
application/vnd.is-xpr xpr
application/vnd.jam jam
application/vnd.japannet-directory-service
application/vnd.japannet-jpnstore-wakeup
application/vnd.japannet-payment-wakeup
application/vnd.japannet-registration
application/vnd.japannet-registration-wakeup
application/vnd.japannet-setstore-wakeup
application/vnd.japannet-verification
application/vnd.japannet-verification-wakeup
application/vnd.jcp.javame.midlet-rms rms
application/vnd.jisp jisp
application/vnd.kahootz ktz ktr
application/vnd.kde.karbon karbon
application/vnd.kde.kchart chrt
application/vnd.kde.kformula kfo
application/vnd.kde.kivio flw
application/vnd.kde.kontour kon
application/vnd.kde.kpresenter kpr kpt
application/vnd.kde.kspread ksp
application/vnd.kde.kword kwd kwt
application/vnd.kenameaapp htke
application/vnd.kidspiration kia
application/vnd.kinar kne knp
application/vnd.koan skp skd skt skm
application/vnd.liberty-request+xml
application/vnd.llamagraphics.life-balance.desktop lbd
application/vnd.llamagraphics.life-balance.exchange+xml lbe
application/vnd.lotus-1-2-3 123
application/vnd.lotus-approach apr
application/vnd.lotus-freelance pre
application/vnd.lotus-notes nsf
application/vnd.lotus-organizer org
application/vnd.lotus-screencam scm
application/vnd.lotus-wordpro lwp
application/vnd.macports.portpkg portpkg
application/vnd.marlin.drm.actiontoken+xml
application/vnd.marlin.drm.conftoken+xml
application/vnd.marlin.drm.mdcf
application/vnd.mcd mcd
application/vnd.medcalcdata mc1
application/vnd.mediastation.cdkey cdkey
application/vnd.meridian-slingshot
application/vnd.mfer mwf
application/vnd.mfmp mfm
application/vnd.micrografx.flo flo
application/vnd.micrografx.igx igx
application/vnd.mif mif
application/vnd.minisoft-hp3000-save
application/vnd.mitsubishi.misty-guard.trustweb
application/vnd.mobius.daf daf
application/vnd.mobius.dis dis
application/vnd.mobius.mbk mbk
application/vnd.mobius.mqy mqy
application/vnd.mobius.msl msl
application/vnd.mobius.plc plc
application/vnd.mobius.txf txf
application/vnd.mophun.application mpn
application/vnd.mophun.certificate mpc
application/vnd.motorola.flexsuite
application/vnd.motorola.flexsuite.adsi
application/vnd.motorola.flexsuite.fis
application/vnd.motorola.flexsuite.gotap
application/vnd.motorola.flexsuite.kmr
application/vnd.motorola.flexsuite.ttc
application/vnd.motorola.flexsuite.wem
application/vnd.mozilla.xul+xml xul
application/vnd.ms-artgalry cil
application/vnd.ms-asf asf
application/vnd.ms-cab-compressed cab
application/vnd.ms-excel xls xlm xla xlc xlt xlw
application/vnd.ms-fontobject eot
application/vnd.ms-htmlhelp chm
application/vnd.ms-ims ims
application/vnd.ms-lrm lrm
application/vnd.ms-playready.initiator+xml
application/vnd.ms-powerpoint ppt pps pot
application/vnd.ms-project mpp mpt
application/vnd.ms-tnef
application/vnd.ms-wmdrm.lic-chlg-req
application/vnd.ms-wmdrm.lic-resp
application/vnd.ms-wmdrm.meter-chlg-req
application/vnd.ms-wmdrm.meter-resp
application/vnd.ms-works wps wks wcm wdb
application/vnd.ms-wpl wpl
application/vnd.ms-xpsdocument xps
application/vnd.mseq mseq
application/vnd.msign
application/vnd.music-niff
application/vnd.musician mus
application/vnd.ncd.control
application/vnd.nervana
application/vnd.netfpx
application/vnd.neurolanguage.nlu nlu
application/vnd.noblenet-directory nnd
application/vnd.noblenet-sealer nns
application/vnd.noblenet-web nnw
application/vnd.nokia.catalogs
application/vnd.nokia.conml+wbxml
application/vnd.nokia.conml+xml
application/vnd.nokia.isds-radio-presets
application/vnd.nokia.iptv.config+xml
application/vnd.nokia.landmark+wbxml
application/vnd.nokia.landmark+xml
application/vnd.nokia.landmarkcollection+xml
application/vnd.nokia.n-gage.ac+xml
application/vnd.nokia.n-gage.data ngdat
application/vnd.nokia.n-gage.symbian.install n-gage
application/vnd.nokia.ncd
application/vnd.nokia.pcd+wbxml
application/vnd.nokia.pcd+xml
application/vnd.nokia.radio-preset rpst
application/vnd.nokia.radio-presets rpss
application/vnd.novadigm.edm edm
application/vnd.novadigm.edx edx
application/vnd.novadigm.ext ext
application/vnd.oasis.opendocument.chart odc
application/vnd.oasis.opendocument.chart-template otc
application/vnd.oasis.opendocument.formula odf
application/vnd.oasis.opendocument.formula-template otf
application/vnd.oasis.opendocument.graphics odg
application/vnd.oasis.opendocument.graphics-template otg
application/vnd.oasis.opendocument.image odi
application/vnd.oasis.opendocument.image-template oti
application/vnd.oasis.opendocument.presentation odp
application/vnd.oasis.opendocument.presentation-template otp
application/vnd.oasis.opendocument.spreadsheet ods
application/vnd.oasis.opendocument.spreadsheet-template ots
application/vnd.oasis.opendocument.text odt
application/vnd.oasis.opendocument.text-master otm
application/vnd.oasis.opendocument.text-template ott
application/vnd.oasis.opendocument.text-web oth
application/vnd.obn
application/vnd.olpc-sugar xo
application/vnd.oma-scws-config
application/vnd.oma-scws-http-request
application/vnd.oma-scws-http-response
application/vnd.oma.bcast.associated-procedure-parameter+xml
application/vnd.oma.bcast.drm-trigger+xml
application/vnd.oma.bcast.imd+xml
application/vnd.oma.bcast.notification+xml
application/vnd.oma.bcast.sgboot
application/vnd.oma.bcast.sgdd+xml
application/vnd.oma.bcast.sgdu
application/vnd.oma.bcast.simple-symbol-container
application/vnd.oma.bcast.smartcard-trigger+xml
application/vnd.oma.bcast.sprov+xml
application/vnd.oma.dd2+xml dd2
application/vnd.oma.drm.risd+xml
application/vnd.oma.group-usage-list+xml
application/vnd.oma.poc.groups+xml
application/vnd.oma.xcap-directory+xml
application/vnd.omads-email+xml
application/vnd.omads-file+xml
application/vnd.omads-folder+xml
application/vnd.omaloc-supl-init
application/vnd.openofficeorg.extension oxt
application/vnd.osa.netdeploy
application/vnd.osgi.dp dp
application/vnd.otps.ct-kip+xml
application/vnd.palm prc pdb pqa oprc
application/vnd.paos.xml
application/vnd.pg.format str
application/vnd.pg.osasli ei6
application/vnd.piaccess.application-licence
application/vnd.picsel efif
application/vnd.poc.group-advertisement+xml
application/vnd.pocketlearn plf
application/vnd.powerbuilder6 pbd
application/vnd.powerbuilder6-s
application/vnd.powerbuilder7
application/vnd.powerbuilder7-s
application/vnd.powerbuilder75
application/vnd.powerbuilder75-s
application/vnd.preminet
application/vnd.previewsystems.box box
application/vnd.proteus.magazine mgz
application/vnd.publishare-delta-tree qps
application/vnd.pvi.ptid1 ptid
application/vnd.pwg-multiplexed
application/vnd.pwg-xhtml-print+xml
application/vnd.qualcomm.brew-app-res
application/vnd.quark.quarkxpress qxd qxt qwd qwt qxl qxb
application/vnd.rapid
application/vnd.recordare.musicxml mxl
application/vnd.recordare.musicxml+xml
application/vnd.renlearn.rlprint
application/vnd.rn-realmedia rm
application/vnd.ruckus.download
application/vnd.s3sms
application/vnd.scribus
application/vnd.sealed.3df
application/vnd.sealed.csf
application/vnd.sealed.doc
application/vnd.sealed.eml
application/vnd.sealed.mht
application/vnd.sealed.net
application/vnd.sealed.ppt
application/vnd.sealed.tiff
application/vnd.sealed.xls
application/vnd.sealedmedia.softseal.html
application/vnd.sealedmedia.softseal.pdf
application/vnd.seemail see
application/vnd.sema sema
application/vnd.semd semd
application/vnd.semf semf
application/vnd.shana.informed.formdata ifm
application/vnd.shana.informed.formtemplate itp
application/vnd.shana.informed.interchange iif
application/vnd.shana.informed.package ipk
application/vnd.simtech-mindmapper twd twds
application/vnd.smaf mmf
application/vnd.solent.sdkm+xml sdkm sdkd
application/vnd.spotfire.dxp dxp
application/vnd.spotfire.sfs sfs
application/vnd.sss-cod
application/vnd.sss-dtf
application/vnd.sss-ntf
application/vnd.street-stream
application/vnd.sun.wadl+xml
application/vnd.sus-calendar sus susp
application/vnd.svd svd
application/vnd.swiftview-ics
application/vnd.syncml+xml xsm
application/vnd.syncml.dm+wbxml bdm
application/vnd.syncml.dm+xml xdm
application/vnd.syncml.ds.notification
application/vnd.tao.intent-module-archive tao
application/vnd.tmobile-livetv tmo
application/vnd.trid.tpt tpt
application/vnd.triscape.mxs mxs
application/vnd.trueapp tra
application/vnd.truedoc
application/vnd.ufdl ufd ufdl
application/vnd.uiq.theme utz
application/vnd.umajin umj
application/vnd.unity unityweb
application/vnd.uoml+xml uoml
application/vnd.uplanet.alert
application/vnd.uplanet.alert-wbxml
application/vnd.uplanet.bearer-choice
application/vnd.uplanet.bearer-choice-wbxml
application/vnd.uplanet.cacheop
application/vnd.uplanet.cacheop-wbxml
application/vnd.uplanet.channel
application/vnd.uplanet.channel-wbxml
application/vnd.uplanet.list
application/vnd.uplanet.list-wbxml
application/vnd.uplanet.listcmd
application/vnd.uplanet.listcmd-wbxml
application/vnd.uplanet.signal
application/vnd.vcx vcx
application/vnd.vd-study
application/vnd.vectorworks
application/vnd.vidsoft.vidconference
application/vnd.visio vsd vst vss vsw
application/vnd.visionary vis
application/vnd.vividence.scriptfile
application/vnd.vsf vsf
application/vnd.wap.sic
application/vnd.wap.slc
application/vnd.wap.wbxml wbxml
application/vnd.wap.wmlc wmlc
application/vnd.wap.wmlscriptc wmlsc
application/vnd.webturbo wtb
application/vnd.wfa.wsc
application/vnd.wordperfect wpd
application/vnd.wqd wqd
application/vnd.wrq-hp3000-labelled
application/vnd.wt.stf stf
application/vnd.wv.csp+wbxml
application/vnd.wv.csp+xml
application/vnd.wv.ssp+xml
application/vnd.xara xar
application/vnd.xfdl xfdl
application/vnd.xmpie.cpkg
application/vnd.xmpie.dpkg
application/vnd.xmpie.plan
application/vnd.xmpie.ppkg
application/vnd.xmpie.xlim
application/vnd.yamaha.hv-dic hvd
application/vnd.yamaha.hv-script hvs
application/vnd.yamaha.hv-voice hvp
application/vnd.yamaha.smaf-audio saf
application/vnd.yamaha.smaf-phrase spf
application/vnd.yellowriver-custom-menu cmp
application/vnd.zzazz.deck+xml zaz
application/voicexml+xml vxml
application/watcherinfo+xml
application/whoispp-query
application/whoispp-response
application/winhlp hlp
application/wita
application/wordperfect5.1
application/wsdl+xml wsdl
application/wspolicy+xml wspolicy
application/x-ace-compressed ace
application/x-bcpio bcpio
application/x-bittorrent torrent
application/x-bzip bz
application/x-bzip2 bz2 boz
application/x-cdlink vcd
application/x-chat chat
application/x-chess-pgn pgn
application/x-compress
application/x-cpio cpio
application/x-csh csh
application/x-director dcr dir dxr fgd
application/x-dvi dvi
application/x-futuresplash spl
application/x-gtar gtar
application/x-gzip
application/x-hdf hdf
application/x-java-jnlp-file jnlp
application/x-latex latex
application/x-ms-wmd wmd
application/x-ms-wmz wmz
application/x-msaccess mdb
application/x-msbinder obd
application/x-mscardfile crd
application/x-msclip clp
application/x-msdownload exe dll com bat msi
application/x-msmediaview mvb m13 m14
application/x-msmetafile wmf
application/x-msmoney mny
application/x-mspublisher pub
application/x-msschedule scd
application/x-msterminal trm
application/x-mswrite wri
application/x-netcdf nc cdf
application/x-pkcs12 p12 pfx
application/x-pkcs7-certificates p7b spc
application/x-pkcs7-certreqresp p7r
application/x-rar-compressed rar
application/x-sh sh
application/x-shar shar
application/x-shockwave-flash swf
application/x-stuffit sit
application/x-stuffitx sitx
application/x-sv4cpio sv4cpio
application/x-sv4crc sv4crc
application/x-tar tar
application/x-tcl tcl
application/x-tex tex
application/x-texinfo texinfo texi
application/x-ustar ustar
application/x-wais-source src
application/x-x509-ca-cert der crt
application/x400-bp
application/xcap-att+xml
application/xcap-caps+xml
application/xcap-el+xml
application/xcap-error+xml
application/xcap-ns+xml
application/xenc+xml xenc
application/xhtml+xml xhtml xht
application/xml xml xsl
application/xml-dtd dtd
application/xml-external-parsed-entity
application/xmpp+xml
application/xop+xml xop
application/xslt+xml xslt
application/xspf+xml xspf
application/xv+xml mxml xhvml xvml xvm
application/zip zip
audio/32kadpcm
audio/3gpp
audio/3gpp2
audio/ac3
audio/amr
audio/amr-wb
audio/amr-wb+
audio/asc
audio/basic au snd
audio/bv16
audio/bv32
audio/clearmode
audio/cn
audio/dat12
audio/dls
audio/dsr-es201108
audio/dsr-es202050
audio/dsr-es202211
audio/dsr-es202212
audio/dvi4
audio/eac3
audio/evrc
audio/evrc-qcp
audio/evrc0
audio/evrc1
audio/evrcb
audio/evrcb0
audio/evrcb1
audio/g722
audio/g7221
audio/g723
audio/g726-16
audio/g726-24
audio/g726-32
audio/g726-40
audio/g728
audio/g729
audio/g7291
audio/g729d
audio/g729e
audio/gsm
audio/gsm-efr
audio/ilbc
audio/l16
audio/l20
audio/l24
audio/l8
audio/lpc
audio/midi mid midi kar rmi
audio/mobile-xmf
audio/mp4 mp4a
audio/mp4a-latm m4a m4p
audio/mpa
audio/mpa-robust
audio/mpeg mpga mp2 mp2a mp3 m2a m3a
audio/mpeg4-generic
audio/parityfec
audio/pcma
audio/pcmu
audio/prs.sid
audio/qcelp
audio/red
audio/rtp-enc-aescm128
audio/rtp-midi
audio/rtx
audio/smv
audio/smv0
audio/smv-qcp
audio/sp-midi
audio/t140c
audio/t38
audio/telephone-event
audio/tone
audio/vdvi
audio/vmr-wb
audio/vnd.3gpp.iufp
audio/vnd.4sb
audio/vnd.audiokoz
audio/vnd.celp
audio/vnd.cisco.nse
audio/vnd.cmles.radio-events
audio/vnd.cns.anp1
audio/vnd.cns.inf1
audio/vnd.digital-winds eol
audio/vnd.dlna.adts
audio/vnd.dolby.mlp
audio/vnd.everad.plj
audio/vnd.hns.audio
audio/vnd.lucent.voice lvp
audio/vnd.nokia.mobile-xmf
audio/vnd.nortel.vbk
audio/vnd.nuera.ecelp4800 ecelp4800
audio/vnd.nuera.ecelp7470 ecelp7470
audio/vnd.nuera.ecelp9600 ecelp9600
audio/vnd.octel.sbc
audio/vnd.qcelp
audio/vnd.rhetorex.32kadpcm
audio/vnd.sealedmedia.softseal.mpeg
audio/vnd.vmx.cvsd
audio/wav wav
audio/x-aiff aif aiff aifc
audio/x-mpegurl m3u
audio/x-ms-wax wax
audio/x-ms-wma wma
audio/x-pn-realaudio ram ra
audio/x-pn-realaudio-plugin rmp
audio/x-wav wav
chemical/x-cdx cdx
chemical/x-cif cif
chemical/x-cmdf cmdf
chemical/x-cml cml
chemical/x-csml csml
chemical/x-pdb pdb
chemical/x-xyz xyz
image/bmp bmp
image/cgm cgm
image/fits
image/g3fax g3
image/gif gif
image/ief ief
image/jp2 jp2
image/jpeg jpeg jpg jpe
image/jpm
image/jpx
image/naplps
image/pict pict pic pct
image/png png
image/prs.btif btif
image/prs.pti
image/svg+xml svg svgz
image/t38
image/tiff tiff tif
image/tiff-fx
image/vnd.adobe.photoshop psd
image/vnd.cns.inf2
image/vnd.djvu djvu djv
image/vnd.dwg dwg
image/vnd.dxf dxf
image/vnd.fastbidsheet fbs
image/vnd.fpx fpx
image/vnd.fst fst
image/vnd.fujixerox.edmics-mmr mmr
image/vnd.fujixerox.edmics-rlc rlc
image/vnd.globalgraphics.pgb
image/vnd.microsoft.icon ico
image/vnd.mix
image/vnd.ms-modi mdi
image/vnd.net-fpx npx
image/vnd.sealed.png
image/vnd.sealedmedia.softseal.gif
image/vnd.sealedmedia.softseal.jpg
image/vnd.svf
image/vnd.wap.wbmp wbmp
image/vnd.xiff xif
image/x-cmu-raster ras
image/x-cmx cmx
image/x-icon
image/x-macpaint pntg pnt mac
image/x-pcx pcx
image/x-pict pic pct
image/x-portable-anymap pnm
image/x-portable-bitmap pbm
image/x-portable-graymap pgm
image/x-portable-pixmap ppm
image/x-quicktime qtif qti
image/x-rgb rgb
image/x-xbitmap xbm
image/x-xpixmap xpm
image/x-xwindowdump xwd
message/cpim
message/delivery-status
message/disposition-notification
message/external-body
message/http
message/news
message/partial
message/rfc822 eml mime
message/s-http
message/sip
message/sipfrag
message/tracking-status
model/iges igs iges
model/mesh msh mesh silo
model/vnd.dwf dwf
model/vnd.flatland.3dml
model/vnd.gdl gdl
model/vnd.gs.gdl
model/vnd.gtw gtw
model/vnd.moml+xml
model/vnd.mts mts
model/vnd.parasolid.transmit.binary
model/vnd.parasolid.transmit.text
model/vnd.vtu vtu
model/vrml wrl vrml
multipart/alternative
multipart/appledouble
multipart/byteranges
multipart/digest
multipart/encrypted
multipart/form-data
multipart/header-set
multipart/mixed
multipart/parallel
multipart/related
multipart/report
multipart/signed
multipart/voice-message
text/calendar ics ifb
text/css css
text/csv csv
text/directory
text/dns
text/enriched
text/html html htm
text/parityfec
text/plain txt text conf def list log in
text/prs.fallenstein.rst
text/prs.lines.tag dsc
text/red
text/rfc822-headers
text/richtext rtx
text/rtf
text/rtp-enc-aescm128
text/rtx
text/sgml sgml sgm
text/t140
text/tab-separated-values tsv
text/troff t tr roff man me ms
text/uri-list uri uris urls
text/vnd.abc
text/vnd.curl
text/vnd.dmclientscript
text/vnd.esmertec.theme-descriptor
text/vnd.fly fly
text/vnd.fmi.flexstor flx
text/vnd.in3d.3dml 3dml
text/vnd.in3d.spot spot
text/vnd.iptc.newsml
text/vnd.iptc.nitf
text/vnd.latex-z
text/vnd.motorola.reflex
text/vnd.ms-mediapackage
text/vnd.net2phone.commcenter.command
text/vnd.sun.j2me.app-descriptor jad
text/vnd.trolltech.linguist
text/vnd.wap.si
text/vnd.wap.sl
text/vnd.wap.wml wml
text/vnd.wap.wmlscript wmls
text/x-asm s asm
text/x-c c cc cxx cpp h hh dic
text/x-fortran f for f77 f90
text/x-pascal p pas
text/x-java-source java
text/x-setext etx
text/x-uuencode uu
text/x-vcalendar vcs
text/x-vcard vcf
text/xml
text/xml-external-parsed-entity
video/3gpp 3gp
video/3gpp-tt
video/3gpp2 3g2
video/bmpeg
video/bt656
video/celb
video/dv
video/h261 h261
video/h263 h263
video/h263-1998
video/h263-2000
video/h264 h264
video/jpeg jpgv
video/jpm jpm jpgm
video/mj2 mj2 mjp2
video/mp1s
video/mp2p
video/mp2t
video/mp4 mp4 mp4v mpg4 m4v
video/mp4v-es
video/mpeg mpeg mpg mpe m1v m2v
video/mpeg4-generic
video/mpv
video/nv
video/parityfec
video/pointer
video/quicktime qt mov
video/raw
video/rtp-enc-aescm128
video/rtx
video/smpte292m
video/vc1
video/vnd.dlna.mpeg-tts
video/vnd.fvt fvt
video/vnd.hns.video
video/vnd.motorola.video
video/vnd.motorola.videop
video/vnd.mpegurl mxu m4u
video/vnd.nokia.interleaved-multimedia
video/vnd.nokia.videovoip
video/vnd.objectvideo
video/vnd.sealed.mpeg1
video/vnd.sealed.mpeg4
video/vnd.sealed.swf
video/vnd.sealedmedia.softseal.mov
video/vnd.vivo viv
video/x-dv dv dif
video/x-fli fli
video/x-ms-asf asf asx
video/x-ms-wm wm
video/x-ms-wmv wmv
video/x-ms-wmx wmx
video/x-ms-wvx wvx
video/x-msvideo avi
video/x-sgi-movie movie
x-conference/x-cooltalk ice

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs help.markup help.syntax io.streams.string sequences ;
IN: mime-types
IN: mime.types
HELP: mime-db
{ $values
@ -27,9 +27,9 @@ HELP: nonstandard-mime-types
{ "assoc" assoc } }
{ $description "A list of Factor-specific MIME types that are added to the MIME database loaded from disk." } ;
ARTICLE: "mime-types" "MIME types"
"The " { $vocab-link "mime-types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl
ARTICLE: "mime.types" "MIME types"
"The " { $vocab-link "mime.types" } " vocabulary loads a file of MIME types and provides a word to look up the MIME type based on a file extension." $nl
"Looking up a MIME type:"
{ $subsection mime-type } ;
ABOUT: "mime-types"
ABOUT: "mime.types"

View File

@ -1,5 +1,5 @@
IN: mime-types.tests
USING: mime-types tools.test ;
IN: mime.types.tests
USING: mime.types tools.test ;
[ "application/postscript" ] [ "foo.ps" mime-type ] unit-test
[ "application/octet-stream" ] [ "foo.ps.gz" mime-type ] unit-test

View File

@ -2,10 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.encodings.ascii assocs sequences splitting
kernel namespaces fry memoize ;
IN: mime-types
IN: mime.types
MEMO: mime-db ( -- seq )
"resource:basis/mime-types/mime.types" ascii file-lines
"resource:basis/mime/types/mime.types" ascii file-lines
[ "#" head? not ] filter [ " \t" split harvest ] map harvest ;
: nonstandard-mime-types ( -- assoc )

View File

@ -216,17 +216,8 @@ M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint*
dup quot>> callable? [ pprint-object ] [
"( invalid curry )" swap present-text
] if ;
M: compose pprint*
dup [ first>> callable? ] [ second>> callable? ] bi and
[ pprint-object ] [
"( invalid compose )" swap present-text
] if ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;
M: wrapper pprint*
dup wrapped>> word? [

View File

@ -17,7 +17,8 @@ ARTICLE: "prettyprint-stacks" "Prettyprinting stacks"
"Prettyprinting any stack:"
{ $subsection stack. }
"Prettyprinting any call stack:"
{ $subsection callstack. } ;
{ $subsection callstack. }
"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." ;
ARTICLE: "prettyprint-variables" "Prettyprint control variables"
"The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:"

View File

@ -323,10 +323,6 @@ M: class-see-layout class-see-layout ;
[ 2 break 2 \ + (step-into-execute) . ] (remove-breakpoints)
] unit-test
[ ] [ 1 \ + curry unparse drop ] unit-test
[ ] [ 1 \ + compose unparse drop ] unit-test
GENERIC: generic-see-test-with-f ( obj -- obj )
M: f generic-see-test-with-f ;

View File

@ -7,7 +7,7 @@ prettyprint.config sorting splitting grouping math.parser vocabs
definitions effects classes.builtin classes.tuple io.files
classes continuations hashtables classes.mixin classes.union
classes.intersection classes.predicate classes.singleton
combinators quotations sets accessors colors ;
combinators quotations sets accessors colors parser ;
IN: prettyprint
: make-pprint ( obj quot -- block in use )
@ -44,12 +44,28 @@ IN: prettyprint
] with-pprint nl
] unless-empty ;
: vocabs. ( in use -- )
: use/in. ( in use -- )
dupd remove [ { "syntax" "scratchpad" } member? not ] filter
use. in. ;
: vocab-names ( words -- vocabs )
dictionary get
[ [ words>> eq? nip ] with assoc-find 2drop ] curry map sift ;
: prelude. ( -- )
in get use get vocab-names use/in. ;
[
nl
"Restarts were invoked adding vocabularies to the search path." print
"To avoid doing this in the future, add the following USING:" print
"and IN: forms at the top of the source file:" print nl
prelude.
nl
] print-use-hook set-global
: with-use ( obj quot -- )
make-pprint vocabs. do-pprint ; inline
make-pprint use/in. do-pprint ; inline
: with-in ( obj quot -- )
make-pprint drop [ write-in bl ] when* do-pprint ; inline

View File

@ -72,7 +72,9 @@ IN: tools.completion
] if ;
: string-completions ( short strs -- seq )
[ dup ] { } map>assoc completions ;
dup zip completions ;
: limited-completions ( short candidates -- seq )
completions dup length 1000 > [ drop f ] when ;
[ completions ] [ drop ] 2bi
2dup [ length 50 > ] [ empty? ] bi* and
[ 2drop f ] [ drop 50 short head ] if ;

View File

@ -266,7 +266,7 @@ IN: tools.deploy.shaker
layouts:tag-numbers
layouts:type-numbers
lexer-factory
listener:listener-hook
print-use-hook
root-cache
vocab-roots
vocabs:dictionary

View File

@ -1 +1,2 @@
Slava Pestov
Eduardo Cavazos

View File

@ -1,7 +1,13 @@
USING: help.markup help.syntax io strings ;
IN: tools.vocabs.browser
ARTICLE: "vocab-tags" "Vocabulary tags"
{ $all-tags } ;
ARTICLE: "vocab-authors" "Vocabulary authors"
{ $all-authors } ;
ARTICLE: "vocab-index" "Vocabulary index"
{ $tags }
{ $authors }
{ $subsection "vocab-tags" }
{ $subsection "vocab-authors" }
{ $describe-vocab "" } ;

View File

@ -1,9 +1,12 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators vocabs vocabs.loader
tools.vocabs io io.files io.styles help.markup help.stylesheet
sequences assocs help.topics namespaces prettyprint words
sorting definitions arrays summary sets generic ;
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple classes.union combinators
definitions effects fry generic help help.markup
help.stylesheet help.topics io io.files io.styles kernel macros
make namespaces prettyprint sequences sets sorting summary
tools.vocabs vocabs vocabs.loader words ;
IN: tools.vocabs.browser
: vocab-status-string ( vocab -- string )
@ -18,9 +21,9 @@ IN: tools.vocabs.browser
: vocab. ( vocab -- )
[
dup [ write-status ] with-cell
dup [ ($link) ] with-cell
[ vocab-summary write ] with-cell
[ [ write-status ] with-cell ]
[ [ ($link) ] with-cell ]
[ [ vocab-summary write ] with-cell ] tri
] with-row ;
: vocab-headings. ( -- )
@ -34,35 +37,25 @@ IN: tools.vocabs.browser
[ "Children from " prepend ] [ "Children" ] if*
$heading ;
: vocabs. ( assoc -- )
: $vocabs ( assoc -- )
[
[
drop
] [
swap root-heading.
standard-table-style [
vocab-headings. [ vocab. ] each
] ($grid)
[ drop ] [
[ root-heading. ]
[
standard-table-style [
vocab-headings. [ vocab. ] each
] ($grid)
] bi*
] if-empty
] assoc-each ;
: describe-summary ( vocab -- )
vocab-summary [
"Summary" $heading print-element
] when* ;
TUPLE: vocab-tag name ;
INSTANCE: vocab-tag topic
C: <vocab-tag> vocab-tag
: tags. ( seq -- ) [ <vocab-tag> ] map $links ;
: describe-tags ( vocab -- )
vocab-tags f like [
"Tags" $heading tags.
] when* ;
: $tags ( seq -- ) [ <vocab-tag> ] map $links ;
TUPLE: vocab-author name ;
@ -70,20 +63,18 @@ INSTANCE: vocab-author topic
C: <vocab-author> vocab-author
: authors. ( seq -- ) [ <vocab-author> ] map $links ;
: describe-authors ( vocab -- )
vocab-authors f like [
"Authors" $heading authors.
] when* ;
: $authors ( seq -- ) [ <vocab-author> ] map $links ;
: describe-help ( vocab -- )
vocab-help [
"Documentation" $heading ($link)
] when* ;
[
dup vocab-help
[ "Documentation" $heading ($link) ]
[ "Summary" $heading vocab-summary print-element ]
?if
] unless-empty ;
: describe-children ( vocab -- )
vocab-name all-child-vocabs vocabs. ;
vocab-name all-child-vocabs $vocabs ;
: describe-files ( vocab -- )
vocab-files [ <pathname> ] map [
@ -95,50 +86,167 @@ C: <vocab-author> vocab-author
] with-nesting
] with-style
] ($block)
] when* ;
] unless-empty ;
: describe-tuple-classes ( classes -- )
[
"Tuple classes" $subheading
[
[ <$link> ]
[ superclass <$link> ]
[ "slots" word-prop [ name>> ] map " " join \ $snippet swap 2array ]
tri 3array
] map
{ { $strong "Class" } { $strong "Superclass" } { $strong "Slots" } } prefix
$table
] unless-empty ;
: describe-predicate-classes ( classes -- )
[
"Predicate classes" $subheading
[
[ <$link> ]
[ superclass <$link> ]
bi 2array
] map
{ { $strong "Class" } { $strong "Superclass" } } prefix
$table
] unless-empty ;
: (describe-classes) ( classes heading -- )
'[
_ $subheading
[ <$link> 1array ] map $table
] unless-empty ;
: describe-builtin-classes ( classes -- )
"Builtin classes" (describe-classes) ;
: describe-singleton-classes ( classes -- )
"Singleton classes" (describe-classes) ;
: describe-mixin-classes ( classes -- )
"Mixin classes" (describe-classes) ;
: describe-union-classes ( classes -- )
"Union classes" (describe-classes) ;
: describe-intersection-classes ( classes -- )
"Intersection classes" (describe-classes) ;
: describe-classes ( classes -- )
[ builtin-class? ] partition
[ tuple-class? ] partition
[ singleton-class? ] partition
[ predicate-class? ] partition
[ mixin-class? ] partition
[ union-class? ] partition
[ intersection-class? ] filter
{
[ describe-builtin-classes ]
[ describe-tuple-classes ]
[ describe-singleton-classes ]
[ describe-predicate-classes ]
[ describe-mixin-classes ]
[ describe-union-classes ]
[ describe-intersection-classes ]
} spread ;
: word-syntax ( word -- string/f )
\ $syntax swap word-help elements dup length 1 =
[ first second ] [ drop f ] if ;
: describe-parsing ( words -- )
[
"Parsing words" $subheading
[
[ <$link> ]
[ word-syntax dup [ \ $snippet swap 2array ] when ]
bi 2array
] map
{ { $strong "Word" } { $strong "Syntax" } } prefix
$table
] unless-empty ;
: (describe-words) ( words heading -- )
'[
_ $subheading
[
[ <$link> ]
[ stack-effect dup [ effect>string \ $snippet swap 2array ] when ]
bi 2array
] map
{ { $strong "Word" } { $strong "Stack effect" } } prefix
$table
] unless-empty ;
: describe-generics ( words -- )
"Generic words" (describe-words) ;
: describe-macros ( words -- )
"Macro words" (describe-words) ;
: describe-primitives ( words -- )
"Primitives" (describe-words) ;
: describe-compounds ( words -- )
"Ordinary words" (describe-words) ;
: describe-predicates ( words -- )
"Class predicate words" (describe-words) ;
: describe-symbols ( words -- )
[
"Symbol words" $subheading
[ <$link> 1array ] map $table
] unless-empty ;
: describe-words ( vocab -- )
words [
"Words" $heading
natural-sort $links
natural-sort
[ [ class? ] filter describe-classes ]
[
[ [ class? ] [ symbol? ] bi and not ] filter
[ parsing-word? ] partition
[ generic? ] partition
[ macro? ] partition
[ symbol? ] partition
[ primitive? ] partition
[ predicate? ] partition swap
{
[ describe-parsing ]
[ describe-generics ]
[ describe-macros ]
[ describe-symbols ]
[ describe-primitives ]
[ describe-compounds ]
[ describe-predicates ]
} spread
] bi
] unless-empty ;
: vocab-xref ( vocab quot -- vocabs )
>r dup vocab-name swap words [ generic? not ] filter r> map
[ [ word? ] filter [ vocabulary>> ] map ] gather natural-sort
remove sift ; inline
: words. ( vocab -- )
last-element off
vocab-name describe-words ;
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
: describe-uses ( vocab -- )
vocab-uses [
"Uses" $heading
$vocab-links
] unless-empty ;
: describe-usage ( vocab -- )
vocab-usage [
"Used by" $heading
$vocab-links
] unless-empty ;
: describe-metadata ( vocab -- )
[
[ vocab-tags [ "Tags:" swap \ $tags prefix 2array , ] unless-empty ]
[ vocab-authors [ "Authors:" swap \ $authors prefix 2array , ] unless-empty ]
bi
] { } make
[ "Meta-data" $heading $table ] unless-empty ;
: $describe-vocab ( element -- )
first
dup describe-children
dup find-vocab-root [
dup describe-summary
dup describe-tags
dup describe-authors
dup describe-files
] when
dup vocab [
dup describe-help
dup describe-words
dup describe-uses
dup describe-usage
] when drop ;
first {
[ describe-help ]
[ describe-metadata ]
[ describe-words ]
[ describe-files ]
[ describe-children ]
} cleave ;
: keyed-vocabs ( str quot -- seq )
all-vocabs [
@ -154,16 +262,16 @@ C: <vocab-author> vocab-author
[ vocab-authors ] keyed-vocabs ;
: $tagged-vocabs ( element -- )
first tagged vocabs. ;
first tagged $vocabs ;
: $authored-vocabs ( element -- )
first authored vocabs. ;
first authored $vocabs ;
: $tags ( element -- )
drop "Tags" $heading all-tags tags. ;
: $all-tags ( element -- )
drop "Tags" $heading all-tags $tags ;
: $authors ( element -- )
drop "Authors" $heading all-authors authors. ;
: $all-authors ( element -- )
drop "Authors" $heading all-authors $authors ;
INSTANCE: vocab topic

View File

@ -4,9 +4,31 @@ USING: kernel io io.styles io.files io.encodings.utf8
vocabs.loader vocabs sequences namespaces make math.parser
arrays hashtables assocs memoize summary sorting splitting
combinators source-files debugger continuations compiler.errors
init checksums checksums.crc32 sets accessors ;
init checksums checksums.crc32 sets accessors generic
definitions words ;
IN: tools.vocabs
: vocab-xref ( vocab quot -- vocabs )
[ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
[
[ [ word? ] [ generic? not ] bi and ] filter [
dup method-body?
[ "method-generic" word-prop ] when
vocabulary>>
] map
] gather natural-sort remove sift ; inline
: vocabs. ( seq -- )
[ dup >vocab-link write-object nl ] each ;
: vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ;
: vocab-uses. ( vocab -- ) vocab-uses vocabs. ;
: vocab-usage ( vocab -- vocabs ) [ usage ] vocab-xref ;
: vocab-usage. ( vocab -- ) vocab-usage vocabs. ;
: vocab-tests-file ( vocab -- path )
dup "-tests.factor" vocab-dir+ vocab-append-path dup
[ dup exists? [ drop f ] unless ] [ drop f ] if ;

View File

@ -15,9 +15,7 @@ C: <handle> handle
SINGLETON: cocoa-ui-backend
M: cocoa-ui-backend do-events ( -- )
[
[ NSApp [ do-event ] curry loop ui-wait ] ui-try
] with-autorelease-pool ;
[ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
TUPLE: pasteboard handle ;

View File

@ -18,8 +18,8 @@ IN: ui.cocoa.views
{
{ S+ HEX: 20000 }
{ C+ HEX: 40000 }
{ A+ HEX: 80000 }
{ M+ HEX: 100000 }
{ A+ HEX: 100000 }
{ M+ HEX: 80000 }
} ;
: key-codes
@ -59,29 +59,26 @@ IN: ui.cocoa.views
: key-event>gesture ( event -- modifiers keycode action? )
dup event-modifiers swap key-code ;
: send-key-event ( view event quot -- ? )
>r key-event>gesture r> call swap window-focus
send-gesture ; inline
: send-user-input ( view string -- )
CF>string swap window-focus user-input ;
: send-key-event ( view gesture -- )
swap window-focus propagate-gesture ;
: interpret-key-event ( view event -- )
NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
: send-key-down-event ( view event -- )
2dup [ <key-down> ] send-key-event
[ interpret-key-event ] [ 2drop ] if ;
[ key-event>gesture <key-down> send-key-event ]
[ interpret-key-event ]
2bi ;
: send-key-up-event ( view event -- )
[ <key-up> ] send-key-event drop ;
key-event>gesture <key-up> send-key-event ;
: mouse-event>gesture ( event -- modifiers button )
dup event-modifiers swap button ;
: send-button-down$ ( view event -- )
[ mouse-event>gesture <button-down> ] 2keep
mouse-location rot window send-button-down ;
[ mouse-event>gesture <button-down> ]
[ mouse-location rot window send-button-down ] 2bi ;
: send-button-up$ ( view event -- )
[ mouse-event>gesture <button-up> ] 2keep
@ -138,83 +135,83 @@ CLASS: {
}
{ "mouseEntered:" "void" { "id" "SEL" "id" }
[ [ nip send-mouse-moved ] ui-try ]
[ nip send-mouse-moved ]
}
{ "mouseExited:" "void" { "id" "SEL" "id" }
[ [ 3drop forget-rollover ] ui-try ]
[ 3drop forget-rollover ]
}
{ "mouseMoved:" "void" { "id" "SEL" "id" }
[ [ nip send-mouse-moved ] ui-try ]
[ nip send-mouse-moved ]
}
{ "mouseDragged:" "void" { "id" "SEL" "id" }
[ [ nip send-mouse-moved ] ui-try ]
[ nip send-mouse-moved ]
}
{ "rightMouseDragged:" "void" { "id" "SEL" "id" }
[ [ nip send-mouse-moved ] ui-try ]
[ nip send-mouse-moved ]
}
{ "otherMouseDragged:" "void" { "id" "SEL" "id" }
[ [ nip send-mouse-moved ] ui-try ]
[ nip send-mouse-moved ]
}
{ "mouseDown:" "void" { "id" "SEL" "id" }
[ [ nip send-button-down$ ] ui-try ]
[ nip send-button-down$ ]
}
{ "mouseUp:" "void" { "id" "SEL" "id" }
[ [ nip send-button-up$ ] ui-try ]
[ nip send-button-up$ ]
}
{ "rightMouseDown:" "void" { "id" "SEL" "id" }
[ [ nip send-button-down$ ] ui-try ]
[ nip send-button-down$ ]
}
{ "rightMouseUp:" "void" { "id" "SEL" "id" }
[ [ nip send-button-up$ ] ui-try ]
[ nip send-button-up$ ]
}
{ "otherMouseDown:" "void" { "id" "SEL" "id" }
[ [ nip send-button-down$ ] ui-try ]
[ nip send-button-down$ ]
}
{ "otherMouseUp:" "void" { "id" "SEL" "id" }
[ [ nip send-button-up$ ] ui-try ]
[ nip send-button-up$ ]
}
{ "scrollWheel:" "void" { "id" "SEL" "id" }
[ [ nip send-wheel$ ] ui-try ]
[ nip send-wheel$ ]
}
{ "keyDown:" "void" { "id" "SEL" "id" }
[ [ nip send-key-down-event ] ui-try ]
[ nip send-key-down-event ]
}
{ "keyUp:" "void" { "id" "SEL" "id" }
[ [ nip send-key-up-event ] ui-try ]
[ nip send-key-up-event ]
}
{ "cut:" "id" { "id" "SEL" "id" }
[ [ nip T{ cut-action } send-action$ ] ui-try ]
[ nip T{ cut-action } send-action$ ]
}
{ "copy:" "id" { "id" "SEL" "id" }
[ [ nip T{ copy-action } send-action$ ] ui-try ]
[ nip T{ copy-action } send-action$ ]
}
{ "paste:" "id" { "id" "SEL" "id" }
[ [ nip T{ paste-action } send-action$ ] ui-try ]
[ nip T{ paste-action } send-action$ ]
}
{ "delete:" "id" { "id" "SEL" "id" }
[ [ nip T{ delete-action } send-action$ ] ui-try ]
[ nip T{ delete-action } send-action$ ]
}
{ "selectAll:" "id" { "id" "SEL" "id" }
[ [ nip T{ select-all-action } send-action$ ] ui-try ]
[ nip T{ select-all-action } send-action$ ]
}
! Multi-touch gestures: this is undocumented.
@ -290,7 +287,7 @@ CLASS: {
! Text input
{ "insertText:" "void" { "id" "SEL" "id" }
[ [ nip send-user-input ] ui-try ]
[ nip CF>string swap window-focus user-input ]
}
{ "hasMarkedText" "char" { "id" "SEL" }
@ -335,11 +332,11 @@ CLASS: {
! Initialization
{ "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
[
[
2drop dup view-dim swap window (>>dim) yield
] ui-try
]
[ 2drop dup view-dim swap window (>>dim) yield ]
}
{ "doCommandBySelector:" "void" { "id" "SEL" "SEL" }
[ 3drop ]
}
{ "initWithFrame:pixelFormat:" "id" { "id" "SEL" "NSRect" "id" }

View File

@ -8,7 +8,7 @@ IN: ui.commands
[ gesture>string , ]
[
[ command-name , ]
[ command-word \ $link swap 2array , ]
[ command-word <$link> , ]
[ command-description , ]
tri
] bi*

View File

@ -2,11 +2,11 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math models namespaces sequences
strings quotations assocs combinators classes colors
classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render math.geometry.rect locals alien.c-types ;
classes.tuple locals alien.c-types fry opengl opengl.gl
math.vectors ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render
math.geometry.rect ;
IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ;
@ -28,7 +28,7 @@ TUPLE: button < border pressed? selected? quot ;
relayout-1 ;
: if-clicked ( button quot -- )
>r dup button-update dup button-rollover? r> [ drop ] if ;
[ dup button-update dup button-rollover? ] dip [ drop ] if ;
: button-clicked ( button -- ) dup quot>> if-clicked ;
@ -71,6 +71,7 @@ M: button-paint draw-boundary
: roll-button-theme ( button -- button )
f black <solid> dup f <button-paint> >>boundary
f f pressed-gradient f <button-paint> >>interior
align-left ; inline
: <roll-button> ( label quot -- button )
@ -111,10 +112,10 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ;
: checkmark-points ( dim -- points )
{
[ { 0 0 } v* ]
[ { 1 1 } v* ]
[ { 0 1 } v* ]
[ { 1 0 } v* ]
[ { 0 0 } v* { 0.5 0.5 } v+ ]
[ { 1 1 } v* { 0.5 0.5 } v+ ]
[ { 1 0 } v* { -0.3 0.5 } v+ ]
[ { 0 1 } v* { -0.3 0.5 } v+ ]
} cleave 4array ;
: checkmark-vertices ( dim -- vertices )
@ -220,9 +221,8 @@ M: radio-control model-changed
over value>> = >>selected?
relayout-1 ;
: <radio-controls> ( parent model assoc quot -- parent )
#! quot has stack effect ( value model label -- )
swapd [ swapd call add-gadget ] 2curry assoc-each ; inline
: <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
'[ _ swap _ call add-gadget ] assoc-each ; inline
: radio-button-theme ( gadget -- gadget )
{ 5 5 } >>gap
@ -233,8 +233,7 @@ M: radio-control model-changed
: <radio-buttons> ( model assoc -- gadget )
<filled-pile>
-rot
[ <radio-button> ] <radio-controls>
spin [ <radio-button> ] <radio-controls>
{ 5 5 } >>gap ;
: <toggle-button> ( value model label -- gadget )
@ -242,20 +241,19 @@ M: radio-control model-changed
: <toggle-buttons> ( model assoc -- gadget )
<shelf>
-rot
[ <toggle-button> ] <radio-controls> ;
spin [ <toggle-button> ] <radio-controls> ;
: command-button-quot ( target command -- quot )
[ invoke-command drop ] 2curry ;
'[ _ _ invoke-command drop ] ;
: <command-button> ( target gesture command -- button )
[ command-string ] keep
swapd
command-button-quot
<bevel-button> ;
[ command-string swap ] keep command-button-quot <bevel-button> ;
: <toolbar> ( target -- toolbar )
<shelf>
swap
"toolbar" over class command-map commands>> swap
[ -rot <command-button> add-gadget ] curry assoc-each ;
'[ [ _ ] 2dip <command-button> add-gadget ] assoc-each ;
: add-toolbar ( track -- track )
dup <toolbar> f track-add ;

View File

@ -2,17 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents io kernel math models
namespaces make opengl opengl.gl sequences strings io.styles
math.vectors sorting colors combinators assocs math.order
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
math.geometry.rect ;
math.vectors sorting colors combinators assocs math.order fry
calendar alarms ui.clipboards ui.commands ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers
ui.render ui.gestures math.geometry.rect ;
IN: ui.gadgets.editors
TUPLE: editor < gadget
font color caret-color selection-color
caret mark
focused? ;
focused? blink blink-alarm ;
: <loc> ( -- loc ) { 0 0 } <model> ;
@ -45,6 +45,28 @@ focused? ;
dup deactivate-model
swap model>> remove-loc ;
: blink-caret ( editor -- )
[ not ] change-blink relayout-1 ;
SYMBOL: blink-interval
750 milliseconds blink-interval set-global
: start-blinking ( editor -- )
t >>blink
dup '[ _ blink-caret ] blink-interval get every >>blink-alarm drop ;
: stop-blinking ( editor -- )
[ [ cancel-alarm ] when* f ] change-blink-alarm drop ;
: restart-blinking ( editor -- )
dup focused?>> [
[ stop-blinking ]
[ start-blinking ]
[ relayout-1 ]
tri
] [ drop ] if ;
M: editor graft*
dup
dup caret>> activate-editor-model
@ -52,6 +74,7 @@ M: editor graft*
M: editor ungraft*
dup
dup stop-blinking
dup caret>> deactivate-editor-model
dup mark>> deactivate-editor-model ;
@ -64,14 +87,14 @@ M: editor ungraft*
caret>> set-model ;
: change-caret ( editor quot -- )
over >r >r dup editor-caret* swap model>> r> call r>
[ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi
set-caret ; inline
: mark>caret ( editor -- )
dup editor-caret* swap mark>> set-model ;
[ editor-caret* ] [ mark>> ] bi set-model ;
: change-caret&mark ( editor quot -- )
over >r change-caret r> mark>caret ; inline
[ change-caret ] [ drop mark>caret ] 2bi ; inline
: editor-line ( n editor -- str ) control-value nth ;
@ -85,8 +108,8 @@ M: editor ungraft*
: point>loc ( point editor -- loc )
[
>r first2 r> tuck y>line dup ,
>r dup editor-font* r>
[ first2 ] dip tuck y>line dup ,
[ dup editor-font* ] dip
rot editor-line x>offset ,
] { } make ;
@ -94,11 +117,17 @@ M: editor ungraft*
[ hand-rel ] keep point>loc ;
: click-loc ( editor model -- )
>r clicked-loc r> set-model ;
[ clicked-loc ] dip set-model ;
: focus-editor ( editor -- ) t >>focused? relayout-1 ;
: focus-editor ( editor -- )
dup start-blinking
t >>focused?
relayout-1 ;
: unfocus-editor ( editor -- ) f >>focused? relayout-1 ;
: unfocus-editor ( editor -- )
dup stop-blinking
f >>focused?
relayout-1 ;
: (offset>x) ( font col# str -- x )
swap head-slice string-width ;
@ -106,7 +135,7 @@ M: editor ungraft*
: offset>x ( col# line# editor -- x )
[ editor-line ] keep editor-font* -rot (offset>x) ;
: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ;
: loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ;
: line>y ( lines# editor -- y )
line-height * ;
@ -120,12 +149,13 @@ M: editor ungraft*
: scroll>caret ( editor -- )
dup graft-state>> second [
dup caret-loc over caret-dim <rect>
over scroll>rect
] when drop ;
[
[ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
] keep scroll>rect
] [ drop ] if ;
: draw-caret ( -- )
editor get focused?>> [
editor get [ focused?>> ] [ blink>> ] bi and [
editor get
[ caret-color>> gl-color ]
[
@ -142,7 +172,7 @@ M: editor ungraft*
line-translation gl-translate ;
: draw-line ( editor str -- )
>r font>> r> { 0 0 } draw-string ;
[ font>> ] dip { 0 0 } draw-string ;
: first-visible-line ( editor -- n )
clip get rect-loc second origin get second -
@ -168,7 +198,7 @@ M: editor ungraft*
rot control-value <slice> ;
: with-editor-translation ( n quot -- )
>r line-translation origin get v+ r> with-translation ;
[ line-translation origin get v+ ] dip with-translation ;
inline
: draw-lines ( -- )
@ -198,7 +228,7 @@ M: editor ungraft*
editor get selection-start/end
over first [
2dup [
>r 2dup r> draw-selected-line
[ 2dup ] dip draw-selected-line
1 translate-lines
] each-line 2drop
] with-editor-translation ;
@ -216,7 +246,7 @@ M: editor pref-dim*
drop relayout ;
: caret/mark-changed ( model editor -- )
nip [ relayout-1 ] [ scroll>caret ] bi ;
nip [ restart-blinking ] [ scroll>caret ] bi ;
M: editor model-changed
{
@ -246,7 +276,9 @@ M: editor user-input*
M: editor gadget-text* editor-string % ;
: extend-selection ( editor -- )
dup request-focus dup caret>> click-loc ;
dup request-focus
dup restart-blinking
dup caret>> click-loc ;
: mouse-elt ( -- element )
hand-click# get {
@ -258,14 +290,15 @@ M: editor gadget-text* editor-string % ;
editor-mark* before? ;
: drag-selection-caret ( loc editor element -- loc )
>r [ drag-direction? ] 2keep
model>>
r> prev/next-elt ? ;
[
[ drag-direction? ] 2keep model>>
] dip prev/next-elt ? ;
: drag-selection-mark ( loc editor element -- loc )
>r [ drag-direction? not ] 2keep
nip dup editor-mark* swap model>>
r> prev/next-elt ? ;
[
[ drag-direction? not ] keep
[ editor-mark* ] [ model>> ] bi
] dip prev/next-elt ? ;
: drag-caret&mark ( editor -- caret mark )
dup clicked-loc swap mouse-elt
@ -284,15 +317,16 @@ M: editor gadget-text* editor-string % ;
over gadget-selection? [
drop nip remove-selection
] [
over >r >r dup editor-caret* swap model>>
r> call r> model>> remove-doc-range
[ [ [ editor-caret* ] [ model>> ] bi ] dip call ]
[ drop model>> ]
2bi remove-doc-range
] if ; inline
: editor-delete ( editor elt -- )
swap [ over >r rot next-elt r> swap ] delete/backspace ;
swap [ over [ rot next-elt ] dip swap ] delete/backspace ;
: editor-backspace ( editor elt -- )
swap [ over >r rot prev-elt r> ] delete/backspace ;
swap [ over [ rot prev-elt ] dip ] delete/backspace ;
: editor-select-prev ( editor elt -- )
swap [ rot prev-elt ] change-caret ;
@ -310,9 +344,8 @@ M: editor gadget-text* editor-string % ;
tuck caret>> set-model mark>> set-model ;
: select-elt ( editor elt -- )
over >r
>r dup editor-caret* swap model>> r> prev/next-elt
r> editor-select ;
[ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
editor-select ;
: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
@ -323,7 +356,7 @@ M: editor gadget-text* editor-string % ;
[ drop dup extend-selection dup mark>> click-loc ]
[ select-elt ] if ;
: insert-newline ( editor -- ) "\n" swap user-input ;
: insert-newline ( editor -- ) "\n" swap user-input* drop ;
: delete-next-character ( editor -- )
T{ char-elt } editor-delete ;
@ -452,7 +485,7 @@ editor "caret-motion" f {
T{ doc-elt } editor-select-next ;
editor "selection" f {
{ T{ button-down f { S+ } } extend-selection }
{ T{ button-down f { S+ } 1 } extend-selection }
{ T{ drag } drag-selection }
{ T{ gain-focus } focus-editor }
{ T{ lose-focus } unfocus-editor }

View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel math namespaces sequences words
splitting grouping math.vectors ui.gadgets.grids ui.gadgets
@ -11,16 +11,16 @@ TUPLE: frame < grid ;
: <frame-grid> ( -- grid ) 9 [ <gadget> ] replicate 3 group ;
: @center 1 1 ;
: @left 0 1 ;
: @right 2 1 ;
: @top 1 0 ;
: @bottom 1 2 ;
: @center 1 1 ; inline
: @left 0 1 ; inline
: @right 2 1 ; inline
: @top 1 0 ; inline
: @bottom 1 2 ; inline
: @top-left 0 0 ;
: @top-right 2 0 ;
: @bottom-left 0 2 ;
: @bottom-right 2 2 ;
: @top-left 0 0 ; inline
: @top-right 2 0 ; inline
: @bottom-left 0 2 ; inline
: @bottom-right 2 2 ; inline
: new-frame ( class -- frame )
<frame-grid> swap new-grid ; inline
@ -28,13 +28,12 @@ TUPLE: frame < grid ;
: <frame> ( -- frame )
frame new-frame ;
: (fill-center) ( vec n -- )
over first pick third v+ [v-] 1 rot set-nth ;
: (fill-center) ( n vec -- )
[ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
: fill-center ( horiz vert dim -- )
tuck (fill-center) (fill-center) ;
: fill-center ( dim horiz vert -- )
[ over ] dip [ (fill-center) ] 2bi@ ;
M: frame layout*
dup compute-grid
[ rot rect-dim fill-center ] 3keep
grid-layout ;
[ [ rect-dim ] 2dip fill-center ] [ grid-layout ] 3bi ;

View File

@ -10,11 +10,9 @@ SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
TUPLE: gadget < rect
pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state graft-node
interior boundary
model ;
TUPLE: gadget < rect pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state graft-node
interior boundary model ;
M: gadget equal? 2drop f ;

View File

@ -0,0 +1,9 @@
USING: accessors tools.test ui.gadgets ui.gadgets.labels ;
IN: ui.gadgets.labels.tests
[ { 119 14 } ] [
<gadget> { 100 14 } >>dim
<gadget> { 14 14 } >>dim
label-on-right { 5 5 } >>gap
pref-dim
] unit-test

View File

@ -40,7 +40,7 @@ IN: ui.gadgets.panes.tests
[ t ] [ [ [ 1 2 3 ] pprint ] test-gadget-text ] unit-test
[ t ] [ [ \ + describe ] test-gadget-text ] unit-test
[ t ] [ [ \ = see ] test-gadget-text ] unit-test
[ t ] [ [ \ = help ] test-gadget-text ] unit-test
[ t ] [ [ \ = print-topic ] test-gadget-text ] unit-test
[ t ] [
[
@ -84,16 +84,16 @@ ARTICLE: "test-article-1" "This is a test article"
[ t ] [ [ "test-article-1" $title ] test-gadget-text ] unit-test
[ t ] [ [ "test-article-1" help ] test-gadget-text ] unit-test
[ t ] [ [ "test-article-1" print-topic ] test-gadget-text ] unit-test
ARTICLE: "test-article-2" "This is a test article"
"Hello world, how are you today."
{ $table { "a" "b" } { "c" "d" } } ;
[ t ] [ [ "test-article-2" help ] test-gadget-text ] unit-test
[ t ] [ [ "test-article-2" print-topic ] test-gadget-text ] unit-test
<pane> [ \ = see ] with-pane
<pane> [ \ = help ] with-pane
<pane> [ \ = print-topic ] with-pane
[ ] [
\ = <model> [ see ] <pane-control> [ ] with-grafted-gadget

View File

@ -10,7 +10,6 @@ io.streams.nested assocs ui.gadgets.presentations
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
classes.tuple models continuations destructors accessors
math.geometry.rect ;
IN: ui.gadgets.panes
TUPLE: pane < pack
@ -363,7 +362,11 @@ M: f sloppy-pick-up*
dup hand-rel over sloppy-pick-up >>caret
dup relayout-1 ;
: begin-selection ( pane -- ) move-caret f >>mark drop ;
: begin-selection ( pane -- )
f >>selecting?
move-caret
f >>mark
drop ;
: extend-selection ( pane -- )
hand-moved? [
@ -389,6 +392,7 @@ M: f sloppy-pick-up*
] if ;
: select-to-caret ( pane -- )
t >>selecting?
dup mark>> [ caret>mark ] unless
move-caret
dup request-focus
@ -397,7 +401,7 @@ M: f sloppy-pick-up*
pane H{
{ T{ button-down } [ begin-selection ] }
{ T{ button-down f { S+ } 1 } [ select-to-caret ] }
{ T{ button-up f { S+ } 1 } [ drop ] }
{ T{ button-up f { S+ } 1 } [ end-selection ] }
{ T{ button-up } [ end-selection ] }
{ T{ drag } [ extend-selection ] }
{ T{ copy-action } [ com-copy ] }

View File

@ -2,7 +2,8 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test
kernel models models.compose models.range ui.gadgets.viewports
ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
ui.gadgets.sliders math math.vectors arrays sequences
tools.test.ui math.geometry.rect accessors ;
tools.test.ui math.geometry.rect accessors ui.gadgets.buttons
ui.gadgets.packs ;
IN: ui.gadgets.scrollers.tests
[ ] [
@ -74,7 +75,7 @@ dup layout
"g2" get scroll>gadget
"s" get layout
"s" get scroller-value
] map [ { 3 0 } = ] all?
] map [ { 2 0 } = ] all?
] unit-test
[ ] [ "Hi" <label> dup "l" set <scroller> "s" set ] unit-test
@ -86,4 +87,22 @@ dup layout
[ t ] [ "s" get @right grid-child slider? ] unit-test
[ f ] [ "s" get @right grid-child find-scroller* ] unit-test
[ ] [
"Click Me" [ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
[ <pile> swap add-gadget <scroller> ] keep
dup quot>> call
layout
] unit-test
[ t ] [
<gadget> { 200 200 } >>dim
[ [ scroll>gadget ] [ unparent ] bi ] <bevel-button>
dup
<pile> swap add-gadget <scroller> { 100 100 } >>dim dup layout
swap dup quot>> call
dup layout
model>> dependencies>> [ range-max value>> ] map
viewport-gap 2 v*n =
] unit-test
\ <scroller> must-infer

View File

@ -3,9 +3,8 @@
USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models models.range models.compose
combinators math.vectors classes.tuple math.geometry.rect
combinators.short-circuit ;
models models.range models.compose combinators math.vectors
classes.tuple math.geometry.rect combinators.short-circuit ;
IN: ui.gadgets.scrollers
TUPLE: scroller < frame viewport x y follows ;
@ -22,9 +21,10 @@ TUPLE: scroller < frame viewport x y follows ;
: scroll-down-line ( scroller -- ) y>> 1 swap slide-by-line ;
: do-mouse-scroll ( scroller -- )
scroll-direction get-global first2
pick y>> slide-by-line
swap x>> slide-by-line ;
scroll-direction get-global
[ first swap x>> slide-by-line ]
[ second swap y>> slide-by-line ]
2bi ;
scroller H{
{ T{ mouse-scroll } [ do-mouse-scroll ] }
@ -43,30 +43,29 @@ scroller H{
dup model>> dependencies>> second <y-slider> >>y dup y>> @right grid-add
tuck model>> <viewport> >>viewport
dup viewport>> @center grid-add ;
dup viewport>> @center grid-add ; inline
: <scroller> ( gadget -- scroller ) scroller new-scroller ;
: scroll ( value scroller -- )
[
dup viewport>> rect-dim { 0 0 }
rot viewport>> viewport-dim 4array flip
viewport>> [ rect-dim { 0 0 } ] [ viewport-dim ] bi
4array flip
] keep
2dup control-value = [ 2drop ] [ set-control-value ] if ;
: rect-min ( rect1 rect2 -- rect )
>r [ rect-loc ] keep r> [ rect-dim ] bi@ vmin <rect> ;
: rect-min ( rect dim -- rect' )
[ [ loc>> ] [ dim>> ] bi ] dip vmin <rect> ;
: (scroll>rect) ( rect scroller -- )
[
scroller-value vneg offset-rect
viewport-gap offset-rect
] keep
[ viewport>> rect-min ] keep
[
viewport>> 2rect-extent
>r >r v- { 0 0 } vmin r> r> v- { 0 0 } vmax v+
] keep dup scroller-value rot v+ swap scroll ;
[ [ loc>> { 1 1 } v- ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
{
[ scroller-value vneg offset-rect viewport-gap offset-rect ]
[ viewport>> dim>> rect-min ]
[ viewport>> 2rect-extent [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] 2bi* v+ ]
[ scroller-value v+ ]
[ scroll ]
} cleave ;
: relative-scroll-rect ( rect gadget scroller -- newrect )
viewport>> gadget-child relative-loc offset-rect ;
@ -81,14 +80,17 @@ scroller H{
[ relative-scroll-rect ] keep
swap >>follows
relayout
] [
3drop
] if ;
] [ 3drop ] if ;
: (update-scroller) ( scroller -- )
[ scroller-value ] keep scroll ;
: (scroll>gadget) ( gadget scroller -- )
>r { 0 0 } over pref-dim <rect> swap r>
[ relative-scroll-rect ] keep
(scroll>rect) ;
2dup swap child? [
[ [ pref-dim { 0 0 } swap <rect> ] keep ] dip
[ relative-scroll-rect ] keep
(scroll>rect)
] [ f >>follows (update-scroller) drop ] if ;
: scroll>gadget ( gadget -- )
dup find-scroller* dup [
@ -99,7 +101,7 @@ scroller H{
] if ;
: (scroll>bottom) ( scroller -- )
dup viewport>> viewport-dim { 0 1 } v* swap scroll ;
[ viewport>> viewport-dim { 0 1 } v* ] keep scroll ;
: scroll>bottom ( gadget -- )
find-scroller [ t >>follows relayout-1 ] when* ;
@ -115,24 +117,26 @@ M: gadget update-scroller swap (scroll>gadget) ;
M: rect update-scroller swap (scroll>rect) ;
M: f update-scroller drop dup scroller-value swap scroll ;
M: f update-scroller drop (update-scroller) ;
M: scroller layout*
dup call-next-method
dup follows>>
2dup update-scroller
>>follows drop ;
[ call-next-method ] [
dup follows>>
[ update-scroller ] [ >>follows drop ] 2bi
] bi ;
M: scroller focusable-child*
viewport>> ;
M: scroller model-changed
nip f >>follows drop ;
f >>follows 2drop ;
TUPLE: limited-scroller < scroller fixed-dim ;
TUPLE: limited-scroller < scroller
{ min-dim initial: { 0 0 } }
{ max-dim initial: { 1/0. 1/0. } } ;
: <limited-scroller> ( gadget dim -- scroller )
>r limited-scroller new-scroller r> >>fixed-dim ;
: <limited-scroller> ( gadget -- scroller )
limited-scroller new-scroller ;
M: limited-scroller pref-dim*
fixed-dim>> ;
[ call-next-method ] [ min-dim>> vmax ] [ max-dim>> vmin ] tri ;

View File

@ -26,10 +26,10 @@ TUPLE: slot-editor < track ref text ;
GENERIC: finish-editing ( slot-editor ref -- )
M: key-ref finish-editing
drop T{ update-object } swap send-gesture drop ;
drop T{ update-object } swap propagate-gesture ;
M: value-ref finish-editing
drop T{ update-slot } swap send-gesture drop ;
drop T{ update-slot } swap propagate-gesture ;
: slot-editor-value ( slot-editor -- object )
text>> control-value parse-fresh ;
@ -55,14 +55,14 @@ M: value-ref finish-editing
: delete ( slot-editor -- )
dup ref>> delete-ref
T{ update-object } swap send-gesture drop ;
T{ update-object } swap propagate-gesture ;
\ delete H{
{ +description+ "Delete the slot and close the slot editor." }
} define-command
: close ( slot-editor -- )
T{ update-slot } swap send-gesture drop ;
T{ update-slot } swap propagate-gesture ;
\ close H{
{ +description+ "Close the slot editor without saving changes." }
@ -71,7 +71,7 @@ M: value-ref finish-editing
: <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track
swap >>ref
dup <toolbar> f track-add
add-toolbar
<source-editor> >>text
dup text>> <scroller> 1 track-add
dup revert ;
@ -92,7 +92,7 @@ TUPLE: editable-slot < track printer ref ;
: <edit-button> ( -- gadget )
"..."
[ T{ edit-slot } swap send-gesture drop ]
[ T{ edit-slot } swap propagate-gesture ]
<roll-button> ;
: display-slot ( gadget editable-slot -- )

View File

@ -14,3 +14,10 @@ IN: ui.gadgets.tracks.tests
<gadget> { 100 100 } >>dim 1 track-add
pref-dim
] unit-test
[ { 10 10 } ] [
{ 0 1 } <track>
<gadget> { 10 10 } >>dim 1 track-add
<gadget> { 10 10 } >>dim 0 track-add
pref-dim
] unit-test

View File

@ -1,8 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math namespaces
sequences words math.vectors ui.gadgets ui.gadgets.packs
math.geometry.rect fry ;
USING: accessors io kernel namespaces fry
math math.vectors math.geometry.rect math.order
sequences words ui.gadgets ui.gadgets.packs ;
IN: ui.gadgets.tracks
@ -35,13 +35,17 @@ TUPLE: track < pack sizes ;
M: track layout* ( track -- ) dup track-layout pack-layout ;
: track-pref-dims-1 ( track -- dim ) children>> pref-dims max-dim ;
: track-pref-dims-1 ( track -- dim )
children>> pref-dims max-dim ;
: track-pref-dims-2 ( track -- dim )
[ children>> pref-dims ] [ normalized-sizes ] bi
[ [ v/n ] when* ] 2map
max-dim
[ >fixnum ] map ;
[
[ children>> pref-dims ] [ normalized-sizes ] bi
[ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map
max-dim [ >fixnum ] map
]
[ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi
v+ ;
M: track pref-dim* ( gadget -- dim )
[ track-pref-dims-1 ]

View File

@ -21,9 +21,11 @@ TUPLE: viewport < gadget ;
swap add-gadget ;
M: viewport layout*
dup rect-dim viewport-gap 2 v*n v-
over gadget-child pref-dim vmax
swap gadget-child (>>dim) ;
[
[ rect-dim viewport-gap 2 v*n v- ]
[ gadget-child pref-dim ]
bi vmax
] [ gadget-child ] bi (>>dim) ;
M: viewport focusable-child*
gadget-child ;

View File

@ -30,7 +30,7 @@ ERROR: no-world-found ;
: (request-focus) ( child world ? -- )
pick parent>> pick eq? [
>r >r dup parent>> dup r> r>
[ dup parent>> dup ] 2dip
[ (request-focus) ] keep
] unless focus-child ;
@ -80,7 +80,7 @@ SYMBOL: ui-error-hook
: ui-error ( error -- )
ui-error-hook get [ call ] [ print-error ] if* ;
[ rethrow ] ui-error-hook set-global
ui-error-hook global [ [ rethrow ] or ] change-at
: draw-world ( world -- )
dup draw-world? [
@ -103,10 +103,29 @@ world H{
{ T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] }
{ T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
{ T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
{ T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
{ T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
{ T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
{ T{ button-up f { M+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
} set-gestures
PREDICATE: specific-button-up < button-up #>> ;
PREDICATE: specific-button-down < button-down #>> ;
PREDICATE: specific-drag < drag #>> ;
: generalize-gesture ( gesture -- )
clone f >># button-gesture ;
M: world handle-gesture ( gesture gadget -- ? )
2dup call-next-method [
{
{ [ over specific-button-up? ] [ drop generalize-gesture f ] }
{ [ over specific-button-down? ] [ drop generalize-gesture f ] }
{ [ over specific-drag? ] [ drop generalize-gesture f ] }
[ 2drop t ]
} cond
] [ 2drop f ] if ;
: close-global ( world global -- )
dup get-global find-world rot eq?
[ f swap set-global ] [ drop ] if ;

View File

@ -15,14 +15,14 @@ $nl
"The default implementation looks at the " { $snippet "\"gestures\"" } " word property of each superclass of the gadget's class." }
{ $notes "Methods should be defined on this word if you desire to handle an arbitrary set of gestures. To define handlers for a fixed set, it is easier to use " { $link set-gestures } "." } ;
{ send-gesture handle-gesture set-gestures } related-words
{ propagate-gesture handle-gesture set-gestures } related-words
HELP: send-gesture
{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } }
{ $description "Calls " { $link send-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
HELP: propagate-gesture
{ $values { "gesture" "a gesture" } { "gadget" gadget } }
{ $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } "." } ;
HELP: user-input
{ $values { "str" string } { "gadget" gadget } }
{ $values { "string" string } { "gadget" gadget } }
{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
HELP: motion
@ -90,10 +90,6 @@ HELP: select-all-action
{ $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
{ $examples { $code "T{ select-all-action }" } } ;
HELP: generalize-gesture
{ $values { "gesture" "a gesture" } { "newgesture" "a new gesture" } }
{ $description "Turns a " { $link button-down } ", " { $link button-up } " or " { $link drag } " action naming a specific mouse button into one which can apply regardless of which mouse button was pressed." } ;
HELP: C+
{ $description "Control key modifier." } ;

View File

@ -2,12 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math models namespaces
make sequences words strings system hashtables math.parser
math.vectors classes.tuple classes ui.gadgets boxes calendar
alarms symbols combinators sets columns ;
math.vectors classes.tuple classes boxes calendar
alarms symbols combinators sets columns fry deques ui.gadgets ;
IN: ui.gestures
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
GENERIC: handle-gesture ( gesture gadget -- ? )
M: object handle-gesture
@ -15,13 +13,42 @@ M: object handle-gesture
[ "gestures" word-prop ] map
assoc-stack dup [ call f ] [ 2drop t ] if ;
: send-gesture ( gesture gadget -- ? )
[ dupd handle-gesture ] each-parent nip ;
: set-gestures ( class hash -- ) "gestures" set-word-prop ;
: user-input ( str gadget -- )
over empty?
[ [ dupd user-input* ] each-parent ] unless
2drop ;
: gesture-queue ( -- deque ) \ gesture-queue get ;
GENERIC: send-queued-gesture ( request -- )
TUPLE: send-gesture gesture gadget ;
M: send-gesture send-queued-gesture
[ gesture>> ] [ gadget>> ] bi handle-gesture drop ;
: queue-gesture ( ... class -- )
boa gesture-queue push-front notify-ui-thread ; inline
: send-gesture ( gesture gadget -- )
\ send-gesture queue-gesture ;
: each-gesture ( gesture seq -- ) [ send-gesture ] with each ;
TUPLE: propagate-gesture gesture gadget ;
M: propagate-gesture send-queued-gesture
[ gesture>> ] [ gadget>> ] bi
[ handle-gesture ] with each-parent drop ;
: propagate-gesture ( gesture gadget -- )
\ propagate-gesture queue-gesture ;
TUPLE: user-input string gadget ;
M: user-input send-queued-gesture
[ string>> ] [ gadget>> ] bi
[ user-input* ] with each-parent drop ;
: user-input ( string gadget -- )
'[ _ \ user-input queue-gesture ] unless-empty ;
! Gesture objects
TUPLE: motion ; C: <motion> motion
@ -46,11 +73,8 @@ TUPLE: right-action ; C: <right-action> right-action
TUPLE: up-action ; C: <up-action> up-action
TUPLE: down-action ; C: <down-action> down-action
TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
: generalize-gesture ( gesture -- newgesture )
clone f >># ;
TUPLE: zoom-in-action ; C: <zoom-in-action> zoom-in-action
TUPLE: zoom-out-action ; C: <zoom-out-action> zoom-out-action
! Modifiers
SYMBOLS: C+ A+ M+ S+ ;
@ -58,7 +82,7 @@ SYMBOLS: C+ A+ M+ S+ ;
TUPLE: key-down mods sym ;
: <key-gesture> ( mods sym action? class -- mods' sym' )
>r [ S+ rot remove swap ] unless r> boa ; inline
[ [ [ S+ swap remove f like ] dip ] unless ] dip boa ; inline
: <key-down> ( mods sym action? -- key-down )
key-down <key-gesture> ;
@ -100,11 +124,7 @@ SYMBOL: double-click-timeout
hand-loc get hand-click-loc get = not ;
: button-gesture ( gesture -- )
hand-clicked get-global 2dup send-gesture [
>r generalize-gesture r> send-gesture drop
] [
2drop
] if ;
hand-clicked get-global propagate-gesture ;
: drag-gesture ( -- )
hand-buttons get-global
@ -130,14 +150,11 @@ SYMBOL: drag-timer
: fire-motion ( -- )
hand-buttons get-global empty? [
T{ motion } hand-gadget get-global send-gesture drop
T{ motion } hand-gadget get-global propagate-gesture
] [
drag-gesture
] if ;
: each-gesture ( gesture seq -- )
[ handle-gesture drop ] with each ;
: hand-gestures ( new old -- )
drop-prefix <reversed>
T{ mouse-leave } swap each-gesture
@ -145,15 +162,15 @@ SYMBOL: drag-timer
: forget-rollover ( -- )
f hand-world set-global
hand-gadget get-global >r
f hand-gadget set-global
f r> parents hand-gestures ;
hand-gadget get-global
[ f hand-gadget set-global f ] dip
parents hand-gestures ;
: send-lose-focus ( gadget -- )
T{ lose-focus } swap handle-gesture drop ;
T{ lose-focus } swap send-gesture ;
: send-gain-focus ( gadget -- )
T{ gain-focus } swap handle-gesture drop ;
T{ gain-focus } swap send-gesture ;
: focus-child ( child gadget ? -- )
[
@ -219,9 +236,11 @@ SYMBOL: drag-timer
: move-hand ( loc world -- )
dup hand-world set-global
under-hand >r over hand-loc set-global
pick-up hand-gadget set-global
under-hand r> hand-gestures ;
under-hand [
over hand-loc set-global
pick-up hand-gadget set-global
under-hand
] dip hand-gestures ;
: send-button-down ( gesture loc world -- )
move-hand
@ -240,14 +259,13 @@ SYMBOL: drag-timer
: send-wheel ( direction loc world -- )
move-hand
scroll-direction set-global
T{ mouse-scroll } hand-gadget get-global send-gesture
drop ;
T{ mouse-scroll } hand-gadget get-global propagate-gesture ;
: world-focus ( world -- gadget )
dup focus>> [ world-focus ] [ ] ?if ;
: send-action ( world gesture -- )
swap world-focus send-gesture drop ;
swap world-focus propagate-gesture ;
GENERIC: gesture>string ( gesture -- string/f )

View File

@ -4,17 +4,17 @@ USING: debugger ui.tools.workspace help help.topics kernel
models models.history ui.commands ui.gadgets ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
ui.gadgets.buttons compiler.units assocs words vocabs
accessors ;
accessors fry combinators.short-circuit ;
IN: ui.tools.browser
TUPLE: browser-gadget < track pane history ;
: show-help ( link help -- )
dup history>> add-history
>r >link r> history>> set-model ;
history>> dup add-history
[ >link ] dip set-model ;
: <help-pane> ( browser-gadget -- gadget )
history>> [ [ help ] curry try ] <pane-control> ;
history>> [ '[ _ print-topic ] try ] <pane-control> ;
: init-history ( browser-gadget -- )
"handbook" >link <history> >>history drop ;
@ -22,7 +22,7 @@ TUPLE: browser-gadget < track pane history ;
: <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track
dup init-history
dup <toolbar> f track-add
add-toolbar
dup <help-pane> >>pane
dup pane>> <scroller> 1 track-add ;
@ -38,10 +38,11 @@ M: browser-gadget ungraft*
[ call-next-method ] [ remove-definition-observer ] bi ;
: showing-definition? ( defspec assoc -- ? )
[ key? ] 2keep
[ >r dup word-link? [ name>> ] when r> key? ] 2keep
>r dup vocab-link? [ vocab ] when r> key?
or or ;
{
[ key? ]
[ [ dup word-link? [ name>> ] when ] dip key? ]
[ [ dup vocab-link? [ vocab ] when ] dip key? ]
} 2|| ;
M: browser-gadget definitions-changed ( assoc browser -- )
history>>
@ -66,10 +67,10 @@ M: browser-gadget definitions-changed ( assoc browser -- )
\ browser-help H{ { +nullary+ t } } define-command
browser-gadget "toolbar" f {
{ T{ key-down f { A+ } "b" } com-back }
{ T{ key-down f { A+ } "f" } com-forward }
{ T{ key-down f { A+ } "h" } com-documentation }
{ T{ key-down f { A+ } "v" } com-vocabularies }
{ T{ key-down f { A+ } "LEFT" } com-back }
{ T{ key-down f { A+ } "RIGHT" } com-forward }
{ f com-documentation }
{ f com-vocabularies }
{ T{ key-down f f "F1" } browser-help }
} define-command-map

View File

@ -8,7 +8,7 @@ HELP: <debugger>
"Creates a gadget displaying a description of the error, along with buttons to print the contents of the stacks in the listener, and a list of restarts."
} ;
{ <debugger> debugger-window ui-try } related-words
{ <debugger> debugger-window } related-words
HELP: debugger-window
{ $values { "error" "an error" } }

View File

@ -25,7 +25,7 @@ TUPLE: debugger < track restarts ;
: <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track
dup <toolbar> f track-add
add-toolbar
-rot <restart-list> >>restarts
dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
@ -35,7 +35,15 @@ M: debugger focusable-child* restarts>> ;
#! No restarts for the debugger window
f [ drop ] <debugger> "Error" open-window ;
[ debugger-window ] ui-error-hook set-global
GENERIC: error-in-debugger? ( error -- ? )
M: world-error error-in-debugger? world>> gadget-child debugger? ;
M: object error-in-debugger? drop f ;
[
dup error-in-debugger? [ rethrow ] [ debugger-window ] if
] ui-error-hook set-global
M: world-error error.
"An error occurred while drawing the world " write

View File

@ -96,9 +96,12 @@ TUPLE: deploy-gadget < pack vocab settings ;
: com-close ( gadget -- )
close-window ;
deploy-gadget "misc" "Miscellaneous commands" {
{ T{ key-down f f "ESC" } com-close }
} define-command-map
deploy-gadget "toolbar" f {
{ f com-close }
{ f com-help }
{ T{ key-down f f "F1" } com-help }
{ f com-revert }
{ f com-save }
{ T{ key-down f f "RET" } com-deploy }

View File

@ -17,7 +17,7 @@ TUPLE: inspector-gadget < track object pane ;
: <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track
dup <toolbar> f track-add
add-toolbar
<pane> >>pane
dup pane>> <scroller> 1 track-add ;

View File

@ -164,7 +164,7 @@ M: interactor dispose drop ;
: handle-interactive ( lines interactor -- quot/f ? )
tuck try-parse {
{ [ dup quotation? ] [ nip t ] }
{ [ dup not ] [ drop "\n" swap user-input f f ] }
{ [ dup not ] [ drop "\n" swap user-input* drop f f ] }
[ handle-parse-error f f ]
} cond ;
@ -178,10 +178,6 @@ M: interactor stream-read-quot
]
} cond ;
M: interactor pref-dim*
[ line-height 4 * 0 swap 2array ] [ call-next-method ] bi
vmax ;
interactor "interactor" f {
{ T{ key-down f f "RET" } evaluate-input }
{ T{ key-down f { C+ } "k" } clear-input }

View File

@ -1,20 +1,17 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: inspector ui.tools.interactor ui.tools.inspector
ui.tools.workspace help.markup io io.styles
kernel models namespaces parser quotations sequences ui.commands
ui.gadgets ui.gadgets.editors ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
ui.gadgets.tracks ui.gestures ui.operations vocabs words
prettyprint listener debugger threads boxes concurrency.flags
math arrays generic accessors combinators assocs ;
USING: inspector help help.markup io io.styles kernel models
namespaces parser quotations sequences vocabs words prettyprint
listener debugger threads boxes concurrency.flags math arrays
generic accessors combinators assocs fry ui.commands ui.gadgets
ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
ui.tools.browser ui.tools.interactor ui.tools.inspector
ui.tools.workspace ;
IN: ui.tools.listener
TUPLE: listener-gadget < track input output stack ;
: listener-output, ( listener -- listener )
<scrolling-pane> >>output
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
TUPLE: listener-gadget < track input output ;
: listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ;
@ -22,16 +19,10 @@ TUPLE: listener-gadget < track input output stack ;
: <listener-input> ( listener -- gadget )
output>> <pane-stream> <interactor> ;
: listener-input, ( listener -- listener )
dup <listener-input> >>input
dup input>>
{ 0 100 } <limited-scroller>
"Input" <labelled-gadget>
f track-add ;
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
"handbook" ($link) "." print nl ;
"handbook" ($link) ". To see a list of keyboard shortcuts," print
"press F1." print nl ;
M: listener-gadget focusable-child*
input>> ;
@ -58,7 +49,7 @@ M: listener-gadget tool-scroller
: call-listener ( quot -- )
[ workspace-busy? not ] get-workspace* listener>>
[ dup wait-for-listener (call-listener) ] 2curry
'[ _ _ dup wait-for-listener (call-listener) ]
"Listener call" spawn drop ;
M: listener-command invoke-command ( target command -- )
@ -74,7 +65,7 @@ M: listener-operation invoke-command ( target command -- )
: listener-run-files ( seq -- )
[
[ [ run-file ] each ] curry call-listener
'[ _ [ run-file ] each ] call-listener
] unless-empty ;
: com-end ( listener -- )
@ -110,7 +101,7 @@ M: engine-word word-completion-string
: insert-word ( word -- )
get-workspace listener>> input>>
[ >r word-completion-string r> user-input ]
[ >r word-completion-string r> user-input* drop ]
[ interactor-use use-if-necessary ]
2bi ;
@ -120,20 +111,8 @@ M: engine-word word-completion-string
[ select-all ]
2bi ;
TUPLE: stack-display < track ;
: <stack-display> ( workspace -- gadget )
listener>>
{ 0 1 } stack-display new-track
over <toolbar> f track-add
swap stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add ;
M: stack-display tool-scroller
find-workspace listener>> tool-scroller ;
: ui-listener-hook ( listener -- )
>r datastack r> stack>> set-model ;
: ui-help-hook ( topic -- )
browser-gadget call-tool ;
: ui-error-hook ( error listener -- )
find-workspace debugger-popup ;
@ -144,17 +123,20 @@ M: stack-display tool-scroller
: listener-thread ( listener -- )
dup listener-streams [
[ [ ui-listener-hook ] curry listener-hook set ]
[ [ ui-error-hook ] curry error-hook set ]
[ [ ui-inspector-hook ] curry inspector-hook set ] tri
[ ui-help-hook ] help-hook set
[ '[ _ ui-error-hook ] error-hook set ]
[ '[ _ ui-inspector-hook ] inspector-hook set ] bi
welcome.
listener
] with-streams* ;
: start-listener-thread ( listener -- )
[
[ input>> register-self ] [ listener-thread ] bi
] curry "Listener" spawn drop ;
'[
_
[ input>> register-self ]
[ listener-thread ]
bi
] "Listener" spawn drop ;
: restart-listener ( listener -- )
#! Returns when listener is ready to receive input.
@ -166,25 +148,41 @@ M: stack-display tool-scroller
[ wait-for-listener ]
} cleave ;
: init-listener ( listener -- )
f <model> >>stack drop ;
: init-listener ( listener -- listener )
<scrolling-pane> >>output
dup <listener-input> >>input ;
: <listener-scroller> ( listener -- scroller )
<filled-pile>
over output>> add-gadget
swap input>> add-gadget
<scroller> ;
: <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track
dup init-listener
listener-output,
listener-input, ;
add-toolbar
init-listener
dup <listener-scroller> 1 track-add ;
: listener-help ( -- ) "ui-listener" help-window ;
\ listener-help H{ { +nullary+ t } } define-command
: com-auto-use ( -- )
auto-use? [ not ] change ;
\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command
listener-gadget "misc" "Miscellaneous commands" {
{ T{ key-down f f "F1" } listener-help }
} define-command-map
listener-gadget "toolbar" f {
{ f restart-listener }
{ T{ key-down f { A+ } "c" } clear-output }
{ T{ key-down f { A+ } "C" } clear-stack }
{ T{ key-down f { A+ } "u" } com-auto-use }
{ T{ key-down f { A+ } "k" } clear-output }
{ T{ key-down f { A+ } "K" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
{ T{ key-down f f "F1" } listener-help }
} define-command-map
M: listener-gadget handle-gesture ( gesture gadget -- ? )

View File

@ -9,7 +9,7 @@ TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track
dup <toolbar> f track-add
add-toolbar
<pane> >>pane
dup pane>> <scroller> 1 track-add ;

View File

@ -1,14 +1,14 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs ui.tools.interactor ui.tools.listener
ui.tools.workspace help help.topics io.files io.styles kernel
models models.delay models.filter namespaces prettyprint
USING: accessors assocs help help.topics io.files io.styles
kernel models models.delay models.filter namespaces prettyprint
quotations sequences sorting source-files definitions strings
tools.completion tools.crossref classes.tuple ui.commands
ui.gadgets ui.gadgets.editors ui.gadgets.lists
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
;
tools.completion tools.crossref classes.tuple vocabs words
vocabs.loader tools.vocabs unicode.case calendar locals
ui.tools.interactor ui.tools.listener ui.tools.workspace
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
ui.gestures ui.operations ui ;
IN: ui.tools.search
TUPLE: live-search < track field list ;
@ -23,7 +23,7 @@ TUPLE: live-search < track field list ;
M: live-search handle-gesture ( gesture live-search -- ? )
tuck search-gesture dup [
over find-workspace hide-popup
>r search-value r> invoke-command f
[ search-value ] dip invoke-command f
] [
2drop t
] if ;
@ -47,27 +47,29 @@ search-field H{
{ T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
} set-gestures
: <search-model> ( live-search producer -- live-search filter )
>r dup field>> model>> ! live-search model :: producer
ui-running? [ 1/5 seconds <delay> ] when
[ "\n" join ] r> append <filter> ;
: <search-model> ( live-search producer -- filter )
[
field>> model>>
ui-running? [ 1/5 seconds <delay> ] when
] dip [ "\n" join ] prepend <filter> ;
: <search-list> ( live-search seq limited? presenter -- live-search list )
>r
[ limited-completions ] [ completions ] ? curry
<search-model>
>r [ find-workspace hide-popup ] r> r>
swap <list> ;
: init-search-model ( live-search seq limited? -- live-search )
[ 2drop ]
[ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
>>model ; inline
: <live-search> ( string seq limited? presenter -- gadget )
: <search-list> ( presenter live-search -- list )
[ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
:: <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track
<search-field> >>field
dup field>> f track-add
-roll <search-list> >>list
seq limited? init-search-model
presenter over <search-list> >>list
dup field>> 1 <border> { 1 1 } >>fill f track-add
dup list>> <scroller> 1 track-add
swap
over field>> set-editor-string
dup field>> end-of-document ;
string over field>> set-editor-string
dup field>> end-of-document ;
M: live-search focusable-child* field>> ;
@ -80,26 +82,27 @@ M: live-search pref-dim* drop { 400 200 } ;
[ dup synopsis >lower ] { } map>assoc sort-values ;
: <definition-search> ( string words limited? -- gadget )
>r definition-candidates r> [ synopsis ] <live-search> ;
[ definition-candidates ] dip [ synopsis ] <live-search> ;
: word-candidates ( words -- candidates )
[ dup name>> >lower ] { } map>assoc ;
: <word-search> ( string words limited? -- gadget )
>r word-candidates r> [ synopsis ] <live-search> ;
[ word-candidates ] dip [ synopsis ] <live-search> ;
: com-words ( workspace -- )
dup current-word all-words t <word-search>
"Word search" show-titled-popup ;
: show-vocab-words ( workspace vocab -- )
"" over words natural-sort f <word-search>
"Words in " rot vocab-name append show-titled-popup ;
[ "" swap words natural-sort f <word-search> ]
[ "Words in " swap vocab-name append ]
bi show-titled-popup ;
: show-word-usage ( workspace word -- )
"" over smart-usage f <definition-search>
"Words and methods using " rot name>> append
show-titled-popup ;
[ "" swap smart-usage f <definition-search> ]
[ "Words and methods using " swap name>> append ]
bi show-titled-popup ;
: help-candidates ( seq -- candidates )
[ dup >link swap article-title >lower ] { } map>assoc
@ -127,8 +130,9 @@ M: live-search pref-dim* drop { 400 200 } ;
"Source file search" show-titled-popup ;
: show-vocab-files ( workspace vocab -- )
"" over vocab-files <source-file-search>
"Source files in " rot vocab-name append show-titled-popup ;
[ "" swap vocab-files <source-file-search> ]
[ "Source files in " swap vocab-name append ]
bi show-titled-popup ;
: vocab-candidates ( -- candidates )
all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;

View File

@ -32,7 +32,7 @@ ARTICLE: "ui-listener" "UI listener"
{ $heading "Editing commands" }
"The text editing commands are standard; see " { $link "gadgets-editors" } "."
{ $heading "Implementation" }
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), and an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "." ;
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } ")." ;
ARTICLE: "ui-inspector" "UI inspector"
"The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."

View File

@ -19,8 +19,7 @@ IN: ui.tools
<toggle-buttons> ;
: <workspace-book> ( workspace -- gadget )
dup
<stack-display>
<gadget>
<browser-gadget>
<inspector-gadget>
<profiler-gadget>
@ -34,14 +33,14 @@ IN: ui.tools
dup <workspace-book> >>book
dup <workspace-tabs> f track-add
dup book>> 1/5 track-add
dup listener>> 4/5 track-add
dup <toolbar> f track-add ;
dup book>> 0 track-add
dup listener>> 1 track-add
add-toolbar ;
: resize-workspace ( workspace -- )
dup sizes>> over control-value zero? [
1/5 over set-second
4/5 swap set-third
dup sizes>> over control-value 0 = [
0 over set-second
1 swap set-third
] [
2/3 over set-second
1/3 swap set-third
@ -55,13 +54,15 @@ M: workspace model-changed
[ workspace-window ] ui-hook set-global
: com-listener ( workspace -- ) stack-display select-tool ;
: select-tool ( workspace n -- ) swap book>> model>> set-model ;
: com-browser ( workspace -- ) browser-gadget select-tool ;
: com-listener ( workspace -- ) 0 select-tool ;
: com-inspector ( workspace -- ) inspector-gadget select-tool ;
: com-browser ( workspace -- ) 1 select-tool ;
: com-profiler ( workspace -- ) profiler-gadget select-tool ;
: com-inspector ( workspace -- ) 2 select-tool ;
: com-profiler ( workspace -- ) 3 select-tool ;
workspace "tool-switching" f {
{ T{ key-down f { A+ } "1" } com-listener }

View File

@ -36,14 +36,17 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
dup model>> <callstack-display> 2/3 track-add
dup <toolbar> f track-add ;
add-toolbar ;
: <namestack-display> ( model -- gadget )
[ [ name>> namestack. ] when* ]
<pane-control> ;
: <variables-gadget> ( model -- gadget )
<namestack-display> { 400 400 } <limited-scroller> ;
<namestack-display>
<limited-scroller>
{ 400 400 } >>min-dim
{ 400 400 } >>max-dim ;
: variables ( traceback -- )
model>> <variables-gadget>

View File

@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
swap >>status
dup continuation>> <traceback-gadget> >>traceback
dup <toolbar> f track-add
add-toolbar
dup status>> self <thread-status> f track-add
dup traceback>> 1 track-add ;
dup traceback>> 1 track-add ;
: walker-help ( -- ) "ui-walker" help-window ;

View File

@ -1,12 +1,12 @@
! Copyright (C) 2006, 2007 Slava Pestov.
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes continuations help help.topics kernel models
sequences ui ui.backend ui.tools.debugger ui.gadgets
ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks
ui.gadgets.worlds ui.gadgets.presentations ui.gadgets.status-bar
ui.commands ui.gestures assocs arrays namespaces accessors ;
sequences assocs arrays namespaces accessors math.vectors ui
ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
ui.gadgets.presentations ui.gadgets.status-bar ui.commands
ui.gestures ;
IN: ui.tools.workspace
TUPLE: workspace < track book listener popup ;
@ -32,8 +32,6 @@ M: gadget tool-scroller drop f ;
[ find-tool swap ] keep book>> model>>
set-model ;
: select-tool ( workspace class -- ) swap show-tool drop ;
: get-workspace* ( quot -- workspace )
[ >r dup workspace? r> [ drop f ] if ] curry find-window
[ dup raise-window gadget-child ]
@ -47,12 +45,15 @@ M: gadget tool-scroller drop f ;
: get-tool ( class -- gadget )
get-workspace find-tool nip ;
: <help-pane> ( topic -- pane )
<pane> [ [ help ] with-pane ] keep ;
: help-window ( topic -- )
[
<pane> [ [ help ] with-pane ] keep
{ 550 700 } <limited-scroller>
] keep
article-title open-window ;
<help-pane> <limited-scroller>
{ 550 700 } >>max-dim
] [ article-title ] bi
open-window ;
: hide-popup ( workspace -- )
dup popup>> track-remove
@ -78,7 +79,7 @@ SYMBOL: workspace-dim
{ 600 700 } workspace-dim set-global
M: workspace pref-dim* drop workspace-dim get ;
M: workspace pref-dim* call-next-method workspace-dim get vmax ;
M: workspace focusable-child*
dup popup>> [ ] [ listener>> ] ?if ;

View File

@ -47,11 +47,6 @@ HELP: (open-window)
{ $description "Opens a native window containing the given world. This grafts the world by calling " { $link graft } ". Each world can only be displayed in one top-level window at a time." }
{ $notes "This word should not be called directly by user code. Instead, use " { $link open-window } "." } ;
HELP: ui-try
{ $values { "quot" quotation } }
{ $description "Calls the quotation. If it throws an error, opens a window with the error and restores the data stack." }
{ $notes "This is essentially a graphical variant of " { $link try } "." } ;
ARTICLE: "ui-glossary" "UI glossary"
{ $table
{ "color specifier"
@ -105,24 +100,7 @@ ARTICLE: "gadgets" "Pre-made UI gadgets"
ARTICLE: "ui-geometry" "Gadget geometry"
"The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
{ $subsection rect }
"Rectangles can be taken apart:"
{ $subsection rect-loc }
{ $subsection rect-dim }
{ $subsection rect-bounds }
{ $subsection rect-extent }
"New rectangles can be created:"
{ $subsection <zero-rect> }
{ $subsection <rect> }
{ $subsection <extent-rect> }
"More utility words for working with rectangles:"
{ $subsection offset-rect }
{ $subsection rect-intersect }
{ $subsection intersects? }
! "A gadget's bounding box is always relative to its parent. "
! { $subsection gadget-parent }
{ $subsection "math.geometry.rect" }
"Word for converting from a child gadget's co-ordinate system to a parent's:"
{ $subsection relative-loc }
{ $subsection screen-loc }

5
basis/ui/ui-tests.factor Normal file
View File

@ -0,0 +1,5 @@
IN: ui.tests
USING: ui tools.test ;
\ event-loop must-infer
\ open-window must-infer

Some files were not shown because too many files have changed in this diff Show More