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

db4
Doug Coleman 2008-11-22 02:19:14 -06:00
commit eec1e868b0
30 changed files with 465 additions and 243 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -30,7 +30,6 @@ HELP: hide-vars
{ $description "Removes a sequence of variables from the watch list." } ; { $description "Removes a sequence of variables from the watch list." } ;
HELP: hide-all-vars HELP: hide-all-vars
{ $values { "seq" "a sequence of variable names" } }
{ $description "Removes all variables from the watch list." } ; { $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener" ARTICLE: "listener" "The listener"

View File

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

View File

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

View File

@ -356,7 +356,7 @@ M: editor gadget-text* editor-string % ;
[ drop dup extend-selection dup mark>> click-loc ] [ drop dup extend-selection dup mark>> click-loc ]
[ select-elt ] if ; [ select-elt ] if ;
: insert-newline ( editor -- ) "\n" swap user-input ; : insert-newline ( editor -- ) "\n" swap user-input* drop ;
: delete-next-character ( editor -- ) : delete-next-character ( editor -- )
T{ char-elt } editor-delete ; T{ char-elt } editor-delete ;

View File

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

View File

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

View File

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

View File

@ -103,10 +103,27 @@ world H{
{ T{ key-down f { C+ } "a" } [ T{ select-all-action } send-action ] } { 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 { 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 { 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 { 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 { 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 } 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 -- ? )
{
{ [ over specific-button-up? ] [ drop generalize-gesture t ] }
{ [ over specific-button-down? ] [ drop generalize-gesture t ] }
{ [ over specific-drag? ] [ drop generalize-gesture t ] }
[ call-next-method ]
} cond ;
: close-global ( world global -- ) : close-global ( world global -- )
dup get-global find-world rot eq? dup get-global find-world rot eq?
[ f swap set-global ] [ drop ] if ; [ 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." } "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 } "." } ; { $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 HELP: propagate-gesture
{ $values { "gesture" "a gesture" } { "gadget" gadget } { "?" "a boolean" } } { $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 } "." } ; { $description "Calls " { $link handle-gesture } " on every parent of " { $snippet "gadget" } ". Outputs " { $link f } " if some parent handled the gesture, else outputs " { $link t } "." } ;
HELP: user-input HELP: user-input
{ $values { "str" string } { "gadget" gadget } } { $values { "string" string } { "gadget" gadget } }
{ $description "Calls " { $link user-input* } " on every parent of the gadget." } ; { $description "Calls " { $link user-input* } " on every parent of the gadget." } ;
HELP: motion 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." } { $class-description "Gesture sent when the " { $emphasis "select all" } " standard window system action is invoked." }
{ $examples { $code "T{ select-all-action }" } } ; { $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+ HELP: C+
{ $description "Control key modifier." } ; { $description "Control key modifier." } ;

View File

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

View File

@ -67,10 +67,10 @@ M: browser-gadget definitions-changed ( assoc browser -- )
\ browser-help H{ { +nullary+ t } } define-command \ browser-help H{ { +nullary+ t } } define-command
browser-gadget "toolbar" f { browser-gadget "toolbar" f {
{ T{ key-down f { A+ } "b" } com-back } { T{ key-down f { A+ } "LEFT" } com-back }
{ T{ key-down f { A+ } "f" } com-forward } { T{ key-down f { A+ } "RIGHT" } com-forward }
{ T{ key-down f { A+ } "h" } com-documentation } { f com-documentation }
{ T{ key-down f { A+ } "v" } com-vocabularies } { f com-vocabularies }
{ T{ key-down f f "F1" } browser-help } { T{ key-down f f "F1" } browser-help }
} define-command-map } 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." "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 HELP: debugger-window
{ $values { "error" "an error" } } { $values { "error" "an error" } }

View File

@ -164,7 +164,7 @@ M: interactor dispose drop ;
: handle-interactive ( lines interactor -- quot/f ? ) : handle-interactive ( lines interactor -- quot/f ? )
tuck try-parse { tuck try-parse {
{ [ dup quotation? ] [ nip t ] } { [ 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 ] [ handle-parse-error f f ]
} cond ; } cond ;

View File

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: inspector help help.markup io io.styles USING: inspector help help.markup io io.styles kernel models
kernel models namespaces parser quotations sequences vocabs words namespaces parser quotations sequences vocabs words prettyprint
prettyprint listener debugger threads boxes concurrency.flags listener debugger threads boxes concurrency.flags math arrays
math arrays generic accessors combinators assocs fry ui.commands generic accessors combinators assocs fry ui.commands ui.gadgets
ui.gadgets ui.gadgets.editors ui.gadgets.labelled ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations
ui.tools.browser ui.tools.interactor ui.tools.inspector ui.tools.browser ui.tools.interactor ui.tools.inspector
ui.tools.workspace ; ui.tools.workspace ;
@ -13,20 +13,12 @@ IN: ui.tools.listener
TUPLE: listener-gadget < track input output ; TUPLE: listener-gadget < track input output ;
: listener-output, ( listener -- listener )
<scrolling-pane>
[ >>output ] [ <scroller> 1 track-add ] bi ;
: listener-streams ( listener -- input output ) : listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ; [ input>> ] [ output>> <pane-stream> ] bi ;
: <listener-input> ( listener -- gadget ) : <listener-input> ( listener -- gadget )
output>> <pane-stream> <interactor> ; output>> <pane-stream> <interactor> ;
: listener-input, ( listener -- listener )
dup <listener-input>
[ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
: welcome. ( -- ) : welcome. ( -- )
"If this is your first time with Factor, please read the " print "If this is your first time with Factor, please read the " print
"handbook" ($link) ". To see a list of keyboard shortcuts," print "handbook" ($link) ". To see a list of keyboard shortcuts," print
@ -109,7 +101,7 @@ M: engine-word word-completion-string
: insert-word ( word -- ) : insert-word ( word -- )
get-workspace listener>> input>> get-workspace listener>> input>>
[ >r word-completion-string r> user-input ] [ >r word-completion-string r> user-input* drop ]
[ interactor-use use-if-necessary ] [ interactor-use use-if-necessary ]
2bi ; 2bi ;
@ -156,11 +148,21 @@ M: engine-word word-completion-string
[ wait-for-listener ] [ wait-for-listener ]
} cleave ; } cleave ;
: 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 ) : <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track { 0 1 } listener-gadget new-track
add-toolbar add-toolbar
listener-output, init-listener
listener-input, ; dup <listener-scroller> 1 track-add ;
: listener-help ( -- ) "ui-listener" help-window ; : listener-help ( -- ) "ui-listener" help-window ;
@ -177,9 +179,9 @@ listener-gadget "misc" "Miscellaneous commands" {
listener-gadget "toolbar" f { listener-gadget "toolbar" f {
{ f restart-listener } { f restart-listener }
{ T{ key-down f { A+ } "a" } com-auto-use } { T{ key-down f { A+ } "u" } com-auto-use }
{ T{ key-down f { A+ } "c" } clear-output } { T{ key-down f { A+ } "k" } clear-output }
{ T{ key-down f { A+ } "C" } clear-stack } { T{ key-down f { A+ } "K" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end } { T{ key-down f { C+ } "d" } com-end }
} define-command-map } define-command-map

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." } { $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 } "." } ; { $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" ARTICLE: "ui-glossary" "UI glossary"
{ $table { $table
{ "color specifier" { "color specifier"

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

View File

@ -1,4 +1,4 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs io kernel math models namespaces make USING: arrays assocs io kernel math models namespaces make
prettyprint dlists deques sequences threads sequences words prettyprint dlists deques sequences threads sequences words
@ -87,6 +87,7 @@ SYMBOL: ui-hook
: init-ui ( -- ) : init-ui ( -- )
<dlist> \ graft-queue set-global <dlist> \ graft-queue set-global
<dlist> \ layout-queue set-global <dlist> \ layout-queue set-global
<dlist> \ gesture-queue set-global
V{ } clone windows set-global ; V{ } clone windows set-global ;
: restore-gadget-later ( gadget -- ) : restore-gadget-later ( gadget -- )
@ -138,14 +139,22 @@ SYMBOL: ui-hook
: notify-queued ( -- ) : notify-queued ( -- )
graft-queue [ notify ] slurp-deque ; graft-queue [ notify ] slurp-deque ;
: send-queued-gestures ( -- )
gesture-queue [ send-queued-gesture ] slurp-deque ;
: update-ui ( -- ) : update-ui ( -- )
[ notify-queued layout-queued redraw-worlds ] assert-depth ; [
[
notify-queued
layout-queued
redraw-worlds
send-queued-gestures
] assert-depth
] [ ui-error ] recover ;
: ui-wait ( -- ) : ui-wait ( -- )
10 sleep ; 10 sleep ;
: ui-try ( quot -- ) [ ui-error ] recover ;
SYMBOL: ui-thread SYMBOL: ui-thread
: ui-running ( quot -- ) : ui-running ( quot -- )
@ -156,11 +165,9 @@ SYMBOL: ui-thread
\ ui-running get-global ; \ ui-running get-global ;
: update-ui-loop ( -- ) : update-ui-loop ( -- )
ui-running? ui-thread get-global self eq? and [ [ ui-running? ui-thread get-global self eq? and ]
ui-notify-flag get lower-flag [ ui-notify-flag get lower-flag update-ui ]
[ update-ui ] ui-try [ ] while ;
update-ui-loop
] when ;
: start-ui-thread ( -- ) : start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ] [ self ui-thread set-global update-ui-loop ]

View File

@ -194,7 +194,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
:: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) :: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
wParam exclude-key-wm-keydown? [ wParam exclude-key-wm-keydown? [
wParam keystroke>gesture <key-down> wParam keystroke>gesture <key-down>
hWnd window-focus send-gesture drop hWnd window-focus propagate-gesture
] unless ; ] unless ;
:: handle-wm-char ( hWnd uMsg wParam lParam -- ) :: handle-wm-char ( hWnd uMsg wParam lParam -- )
@ -205,7 +205,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
:: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) :: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
wParam keystroke>gesture <key-up> wParam keystroke>gesture <key-up>
hWnd window-focus send-gesture drop ; hWnd window-focus propagate-gesture ;
:: set-window-active ( hwnd uMsg wParam lParam ? -- n ) :: set-window-active ( hwnd uMsg wParam lParam ? -- n )
? hwnd window (>>active?) ? hwnd window (>>active?)
@ -381,11 +381,9 @@ SYMBOL: trace-messages?
! return 0 if you handle the message, else just let DefWindowProc return its val ! return 0 if you handle the message, else just let DefWindowProc return its val
: ui-wndproc ( -- object ) : ui-wndproc ( -- object )
"uint" { "void*" "uint" "long" "long" } "stdcall" [ "uint" { "void*" "uint" "long" "long" } "stdcall" [
[ pick
pick trace-messages? get-global [ dup windows-message-name name>> print flush ] when
trace-messages? get-global [ dup windows-message-name name>> print flush ] when wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
] ui-try
] alien-callback ; ] alien-callback ;
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ; : peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;

View File

@ -7,7 +7,7 @@ x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified io.encodings.utf8 combinators debugger command-line qualified
math.vectors classes.tuple opengl.gl threads math.geometry.rect math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ; environment ascii ;
IN: ui.x11 IN: ui.x11
SINGLETON: x11-ui-backend SINGLETON: x11-ui-backend
@ -67,20 +67,32 @@ M: world configure-event
: event-modifiers ( event -- seq ) : event-modifiers ( event -- seq )
XKeyEvent-state modifiers modifier ; XKeyEvent-state modifiers modifier ;
: valid-input? ( string gesture -- ? )
over empty? [ 2drop f ] [
mods>> { f { S+ } } member? [
[ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
] [
[ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
] if
] if ;
: key-down-event>gesture ( event world -- string gesture ) : key-down-event>gesture ( event world -- string gesture )
dupd dupd
handle>> xic>> lookup-string handle>> xic>> lookup-string
>r swap event-modifiers r> key-code <key-down> ; >r swap event-modifiers r> key-code <key-down> ;
M: world key-down-event M: world key-down-event
[ key-down-event>gesture ] keep world-focus [ key-down-event>gesture ] keep
[ send-gesture ] keep swap [ user-input ] [ 2drop ] if ; world-focus
[ propagate-gesture drop ]
[ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
3bi ;
: key-up-event>gesture ( event -- gesture ) : key-up-event>gesture ( event -- gesture )
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ; dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
M: world key-up-event M: world key-up-event
>r key-up-event>gesture r> world-focus send-gesture drop ; >r key-up-event>gesture r> world-focus propagate-gesture ;
: mouse-event>gesture ( event -- modifiers button loc ) : mouse-event>gesture ( event -- modifiers button loc )
dup event-modifiers over XButtonEvent-button dup event-modifiers over XButtonEvent-button
@ -185,7 +197,7 @@ M: world client-event
M: x11-ui-backend do-events M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup wait-event dup XAnyEvent-window window dup
[ [ [ 2dup handle-event ] ui-try ] assert-depth ] when 2drop ; [ handle-event ] [ 2drop ] if ;
: x-clipboard@ ( gadget clipboard -- prop win ) : x-clipboard@ ( gadget clipboard -- prop win )
atom>> swap atom>> swap

View File

@ -9,6 +9,6 @@ USING: math kernel alien ;
] alien-callback ] alien-callback
"int" { "int" } "cdecl" alien-indirect ; "int" { "int" } "cdecl" alien-indirect ;
: fib-main ( -- ) 25 fib drop ; : fib-main ( -- ) 34 fib drop ;
MAIN: fib-main MAIN: fib-main

View File

@ -224,13 +224,13 @@ SYMBOL: dlist
: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ; : delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
: cfdg-window* ( -- ) : cfdg-window* ( -- slate )
C[ display ] <slate> C[ display ] <slate>
{ 500 500 } >>pdim { 500 500 } >>pdim
C[ delete-dlist ] >>ungraft C[ delete-dlist ] >>ungraft
dup "CFDG" open-window ; dup "CFDG" open-window ;
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ; : cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -0,0 +1,26 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors ui ui.gadgets ui.gadgets.buttons ui.render ;
IN: ui.gadgets.broken
! An intentionally broken gadget -- used to test UI error handling,
! make sure that one bad gadget doesn't bring the whole system down
: <bad-button> ( -- button )
"Click me if you dare"
[ "Haha" throw ]
<bevel-button> ;
TUPLE: bad-gadget < gadget ;
M: bad-gadget draw-gadget* "Lulz" throw ;
M: bad-gadget pref-dim* drop { 100 100 } ;
: <bad-gadget> ( -- gadget ) bad-gadget new-gadget ;
: bad-gadget-test ( -- )
<bad-button> "Test 1" open-window
<bad-gadget> "Test 2" open-window ;
MAIN: bad-gadget-test

View File

@ -35,6 +35,7 @@
(require 'font-lock) (require 'font-lock)
(require 'comint) (require 'comint)
(require 'view)
;;; Customization: ;;; Customization:
@ -64,6 +65,30 @@ value from the existing code in the buffer."
:type '(file :must-match t) :type '(file :must-match t)
:group 'factor) :group 'factor)
(defcustom factor-use-doc-window t
"When on, use a separate window to display help information.
Disable to see that information in the factor-listener comint
window."
:type 'boolean
:group 'factor)
(defcustom factor-listener-use-other-window t
"Use a window other than the current buffer's when switching to
the factor-listener buffer."
:type 'boolean
:group 'factor)
(defcustom factor-listener-window-allow-split t
"Allow window splitting when switching to the factor-listener
buffer."
:type 'boolean
:group 'factor)
(defcustom factor-help-always-ask t
"When enabled, always ask for confirmation in help prompts."
:type 'boolean
:group 'factor)
(defcustom factor-display-compilation-output t (defcustom factor-display-compilation-output t
"Display the REPL buffer before compiling files." "Display the REPL buffer before compiling files."
:type 'boolean :type 'boolean
@ -74,6 +99,11 @@ value from the existing code in the buffer."
:type 'hook :type 'hook
:group 'factor) :group 'factor)
(defcustom factor-help-mode-hook nil
"Hook run by `factor-help-mode'."
:type 'hook
:group 'factor)
(defgroup factor-faces nil (defgroup factor-faces nil
"Faces used in Factor mode" "Faces used in Factor mode"
:group 'factor :group 'factor
@ -125,6 +155,10 @@ value from the existing code in the buffer."
"Face for parsing words." "Face for parsing words."
:group 'factor-faces) :group 'factor-faces)
(defface factor-font-lock-help-mode-headlines '((t (:bold t :weight bold)))
"Face for headlines in help buffers."
:group 'factor-faces)
;;; Factor mode font lock: ;;; Factor mode font lock:
@ -429,18 +463,6 @@ value from the existing code in the buffer."
(factor-send-region (search-backward ":") (factor-send-region (search-backward ":")
(search-forward ";"))) (search-forward ";")))
(defun factor-see ()
(interactive)
(comint-send-string "*factor*" "\\ ")
(comint-send-string "*factor*" (thing-at-point 'sexp))
(comint-send-string "*factor*" " see\n"))
(defun factor-help ()
(interactive)
(comint-send-string "*factor*" "\\ ")
(comint-send-string "*factor*" (thing-at-point 'sexp))
(comint-send-string "*factor*" " help\n"))
(defun factor-edit () (defun factor-edit ()
(interactive) (interactive)
(comint-send-string "*factor*" "\\ ") (comint-send-string "*factor*" "\\ ")
@ -459,17 +481,6 @@ value from the existing code in the buffer."
(defvar factor-mode-map (make-sparse-keymap) (defvar factor-mode-map (make-sparse-keymap)
"Key map used by Factor mode.") "Key map used by Factor mode.")
(define-key factor-mode-map "\C-c\C-f" 'factor-run-file)
(define-key factor-mode-map "\C-c\C-r" 'factor-send-region)
(define-key factor-mode-map "\C-c\C-d" 'factor-send-definition)
(define-key factor-mode-map "\C-c\C-s" 'factor-see)
(define-key factor-mode-map "\C-ce" 'factor-edit)
(define-key factor-mode-map "\C-c\C-h" 'factor-help)
(define-key factor-mode-map "\C-cc" 'comment-region)
(define-key factor-mode-map [return] 'newline-and-indent)
(define-key factor-mode-map [tab] 'indent-for-tab-command)
;; Factor mode: ;; Factor mode:
@ -494,23 +505,118 @@ value from the existing code in the buffer."
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode)) (add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
;;; Factor listener mode ;;; Factor listener mode:
;;;###autoload ;;;###autoload
(define-derived-mode factor-listener-mode comint-mode "Factor Listener") (define-derived-mode factor-listener-mode comint-mode "Factor Listener"
"Major mode for interacting with an inferior Factor listener process.
\\{factor-listener-mode-map}"
(set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
(define-key factor-listener-mode-map [f8] 'factor-refresh-all) (defvar factor--listener-buffer nil
"The buffer in which the Factor listener is running.")
(defun factor--listener-start-process ()
"Start an inferior Factor listener process, using
`factor-binary' and `factor-image'."
(setq factor--listener-buffer
(apply 'make-comint "factor" (expand-file-name factor-binary) nil
`("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
(with-current-buffer factor--listener-buffer
(factor-listener-mode)))
(defun factor--listener-process ()
(or (and (buffer-live-p factor--listener-buffer)
(get-buffer-process factor--listener-buffer))
(progn (factor--listener-start-process)
(factor--listener-process))))
;;;###autoload ;;;###autoload
(defun run-factor () (defalias 'switch-to-factor 'run-factor)
"Start a factor listener inside emacs, or switch to it if it ;;;###autoload
already exists." (defun run-factor (&optional arg)
"Show the factor-listener buffer, starting the process if needed."
(interactive) (interactive)
(switch-to-buffer (let ((buf (process-buffer (factor--listener-process)))
(make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil (pop-up-windows factor-listener-window-allow-split))
(concat "-i=" (expand-file-name factor-image)) (if factor-listener-use-other-window
"-run=listener")) (pop-to-buffer buf)
(factor-listener-mode)) (switch-to-buffer buf))))
;;;; Factor help mode:
(defvar factor-help-mode-map (make-sparse-keymap)
"Keymap for Factor help mode.")
(defconst factor--help-headlines
(regexp-opt '("Parent topics:"
"Inputs and outputs"
"Word description"
"Generic word contract"
"Vocabulary"
"Definition")
t))
(defconst factor--help-headlines-regexp (format "^%s" factor--help-headlines))
(defconst factor--help-font-lock-keywords
`((,factor--help-headlines-regexp . 'factor-font-lock-help-mode-headlines)
,@factor-font-lock-keywords))
(defun factor-help-mode ()
"Major mode for displaying Factor help messages.
\\{factor-help-mode-map}"
(interactive)
(kill-all-local-variables)
(use-local-map factor-help-mode-map)
(setq mode-name "Factor Help")
(setq major-mode 'factor-help-mode)
(set (make-local-variable 'font-lock-defaults)
'(factor--help-font-lock-keywords t nil nil nil))
(set (make-local-variable 'comint-redirect-subvert-readonly) t)
(set (make-local-variable 'view-no-disable-on-exit) t)
(view-mode)
(setq view-exit-action
(lambda (buffer)
;; Use `with-current-buffer' to make sure that `bury-buffer'
;; also removes BUFFER from the selected window.
(with-current-buffer buffer
(bury-buffer))))
(run-mode-hooks 'factor-help-mode-hook))
(defun factor--listener-help-buffer ()
(set-buffer (get-buffer-create "*factor-help*"))
(let ((inhibit-read-only t))
(delete-region (point-min) (point-max)))
(factor-help-mode)
(current-buffer))
(defvar factor--help-history nil)
(defun factor--listener-show-help (&optional see)
(let* ((def (thing-at-point 'sexp))
(prompt (format "%s (%s): " (if see "See" "Help") def))
(ask (or (not (eq major-mode 'factor-mode))
(not def)
factor-help-always-ask))
(cmd (format "\\ %s %s"
(if ask (read-string prompt nil 'factor--help-history def) def)
(if see "see" "help")))
(hb (factor--listener-help-buffer))
(proc (factor--listener-process)))
(comint-redirect-send-command-to-process cmd hb proc nil)
(pop-to-buffer hb)))
(defun factor-see ()
(interactive)
(factor--listener-show-help t))
(defun factor-help ()
(interactive)
(factor--listener-show-help))
(defun factor-refresh-all () (defun factor-refresh-all ()
"Reload source files and documentation for all loaded "Reload source files and documentation for all loaded
@ -519,6 +625,28 @@ vocabularies which have been modified on disk."
(comint-send-string "*factor*" "refresh-all\n")) (comint-send-string "*factor*" "refresh-all\n"))
;;; Key bindings:
(defmacro factor--define-key (key cmd)
`(progn
(define-key factor-mode-map [(control ?c) ,key] ,cmd)
(define-key factor-mode-map [(control ?c) (control ,key)] ,cmd)))
(factor--define-key ?f 'factor-run-file)
(factor--define-key ?r 'factor-send-region)
(factor--define-key ?d 'factor-send-definition)
(factor--define-key ?s 'factor-see)
(factor--define-key ?e 'factor-edit)
(factor--define-key ?z 'switch-to-factor)
(factor--define-key ?c 'comment-region)
(define-key factor-mode-map "\C-ch" 'factor-help)
(define-key factor-mode-map "\C-m" 'newline-and-indent)
(define-key factor-mode-map [tab] 'indent-for-tab-command)
(define-key factor-listener-mode-map [f8] 'factor-refresh-all)
(provide 'factor) (provide 'factor)
;;; factor.el ends here ;;; factor.el ends here

View File

@ -29,10 +29,35 @@ void save_stacks(void)
} }
} }
F_CONTEXT *alloc_context(void)
{
F_CONTEXT *context;
if(unused_contexts)
{
context = unused_contexts;
unused_contexts = unused_contexts->next;
}
else
{
context = safe_malloc(sizeof(F_CONTEXT));
context->datastack_region = alloc_segment(ds_size);
context->retainstack_region = alloc_segment(rs_size);
}
return context;
}
void dealloc_context(F_CONTEXT *context)
{
context->next = unused_contexts;
unused_contexts = context;
}
/* called on entry into a compiled callback */ /* called on entry into a compiled callback */
void nest_stacks(void) void nest_stacks(void)
{ {
F_CONTEXT *new_stacks = safe_malloc(sizeof(F_CONTEXT)); F_CONTEXT *new_stacks = alloc_context();
new_stacks->callstack_bottom = (F_STACK_FRAME *)-1; new_stacks->callstack_bottom = (F_STACK_FRAME *)-1;
new_stacks->callstack_top = (F_STACK_FRAME *)-1; new_stacks->callstack_top = (F_STACK_FRAME *)-1;
@ -54,9 +79,6 @@ void nest_stacks(void)
new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV]; new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_ENV];
new_stacks->catchstack_save = userenv[CATCHSTACK_ENV]; new_stacks->catchstack_save = userenv[CATCHSTACK_ENV];
new_stacks->datastack_region = alloc_segment(ds_size);
new_stacks->retainstack_region = alloc_segment(rs_size);
new_stacks->next = stack_chain; new_stacks->next = stack_chain;
stack_chain = new_stacks; stack_chain = new_stacks;
@ -67,9 +89,6 @@ void nest_stacks(void)
/* called when leaving a compiled callback */ /* called when leaving a compiled callback */
void unnest_stacks(void) void unnest_stacks(void)
{ {
dealloc_segment(stack_chain->datastack_region);
dealloc_segment(stack_chain->retainstack_region);
ds = stack_chain->datastack_save; ds = stack_chain->datastack_save;
rs = stack_chain->retainstack_save; rs = stack_chain->retainstack_save;
@ -79,7 +98,7 @@ void unnest_stacks(void)
F_CONTEXT *old_stacks = stack_chain; F_CONTEXT *old_stacks = stack_chain;
stack_chain = old_stacks->next; stack_chain = old_stacks->next;
free(old_stacks); dealloc_context(old_stacks);
} }
/* called on startup */ /* called on startup */
@ -88,6 +107,7 @@ void init_stacks(CELL ds_size_, CELL rs_size_)
ds_size = ds_size_; ds_size = ds_size_;
rs_size = rs_size_; rs_size = rs_size_;
stack_chain = NULL; stack_chain = NULL;
unused_contexts = NULL;
} }
bool stack_to_array(CELL bottom, CELL top) bool stack_to_array(CELL bottom, CELL top)

View File

@ -211,6 +211,8 @@ typedef struct _F_CONTEXT {
DLLEXPORT F_CONTEXT *stack_chain; DLLEXPORT F_CONTEXT *stack_chain;
F_CONTEXT *unused_contexts;
CELL ds_size, rs_size; CELL ds_size, rs_size;
#define ds_bot (stack_chain->datastack_region->start) #define ds_bot (stack_chain->datastack_region->start)