Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
eec1e868b0
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -30,7 +30,6 @@ HELP: hide-vars
|
|||
{ $description "Removes a sequence of variables from the watch list." } ;
|
||||
|
||||
HELP: hide-all-vars
|
||||
{ $values { "seq" "a sequence of variable names" } }
|
||||
{ $description "Removes all variables from the watch list." } ;
|
||||
|
||||
ARTICLE: "listener" "The listener"
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -356,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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -103,10 +103,27 @@ 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 -- ? )
|
||||
{
|
||||
{ [ 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 -- )
|
||||
dup get-global find-world rot eq?
|
||||
[ f swap set-global ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
HELP: propagate-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 } "." } ;
|
||||
{ $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
|
||||
{ $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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -67,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
|
||||
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
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 ;
|
||||
|
|
@ -13,20 +13,12 @@ IN: ui.tools.listener
|
|||
|
||||
TUPLE: listener-gadget < track input output ;
|
||||
|
||||
: listener-output, ( listener -- listener )
|
||||
<scrolling-pane>
|
||||
[ >>output ] [ <scroller> 1 track-add ] bi ;
|
||||
|
||||
: listener-streams ( listener -- input output )
|
||||
[ input>> ] [ output>> <pane-stream> ] bi ;
|
||||
|
||||
: <listener-input> ( listener -- gadget )
|
||||
output>> <pane-stream> <interactor> ;
|
||||
|
||||
: listener-input, ( listener -- listener )
|
||||
dup <listener-input>
|
||||
[ >>input ] [ 1 <border> { 1 1 } >>fill f track-add ] bi ;
|
||||
|
||||
: welcome. ( -- )
|
||||
"If this is your first time with Factor, please read the " print
|
||||
"handbook" ($link) ". To see a list of keyboard shortcuts," print
|
||||
|
|
@ -109,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 ;
|
||||
|
||||
|
|
@ -156,11 +148,21 @@ M: engine-word word-completion-string
|
|||
[ wait-for-listener ]
|
||||
} 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 )
|
||||
{ 0 1 } listener-gadget new-track
|
||||
add-toolbar
|
||||
listener-output,
|
||||
listener-input, ;
|
||||
init-listener
|
||||
dup <listener-scroller> 1 track-add ;
|
||||
|
||||
: listener-help ( -- ) "ui-listener" help-window ;
|
||||
|
||||
|
|
@ -177,9 +179,9 @@ listener-gadget "misc" "Miscellaneous commands" {
|
|||
|
||||
listener-gadget "toolbar" f {
|
||||
{ f restart-listener }
|
||||
{ T{ key-down f { A+ } "a" } com-auto-use }
|
||||
{ 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 }
|
||||
} define-command-map
|
||||
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
IN: ui.tests
|
||||
USING: ui tools.test ;
|
||||
|
||||
\ event-loop must-infer
|
||||
\ open-window must-infer
|
||||
|
|
@ -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.
|
||||
USING: arrays assocs io kernel math models namespaces make
|
||||
prettyprint dlists deques sequences threads sequences words
|
||||
|
|
@ -87,6 +87,7 @@ SYMBOL: ui-hook
|
|||
: init-ui ( -- )
|
||||
<dlist> \ graft-queue set-global
|
||||
<dlist> \ layout-queue set-global
|
||||
<dlist> \ gesture-queue set-global
|
||||
V{ } clone windows set-global ;
|
||||
|
||||
: restore-gadget-later ( gadget -- )
|
||||
|
|
@ -138,14 +139,22 @@ SYMBOL: ui-hook
|
|||
: notify-queued ( -- )
|
||||
graft-queue [ notify ] slurp-deque ;
|
||||
|
||||
: send-queued-gestures ( -- )
|
||||
gesture-queue [ send-queued-gesture ] slurp-deque ;
|
||||
|
||||
: 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 ( -- )
|
||||
10 sleep ;
|
||||
|
||||
: ui-try ( quot -- ) [ ui-error ] recover ;
|
||||
|
||||
SYMBOL: ui-thread
|
||||
|
||||
: ui-running ( quot -- )
|
||||
|
|
@ -156,11 +165,9 @@ SYMBOL: ui-thread
|
|||
\ ui-running get-global ;
|
||||
|
||||
: update-ui-loop ( -- )
|
||||
ui-running? ui-thread get-global self eq? and [
|
||||
ui-notify-flag get lower-flag
|
||||
[ update-ui ] ui-try
|
||||
update-ui-loop
|
||||
] when ;
|
||||
[ ui-running? ui-thread get-global self eq? and ]
|
||||
[ ui-notify-flag get lower-flag update-ui ]
|
||||
[ ] while ;
|
||||
|
||||
: start-ui-thread ( -- )
|
||||
[ self ui-thread set-global update-ui-loop ]
|
||||
|
|
|
|||
|
|
@ -194,7 +194,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
|
|||
:: handle-wm-keydown ( hWnd uMsg wParam lParam -- )
|
||||
wParam exclude-key-wm-keydown? [
|
||||
wParam keystroke>gesture <key-down>
|
||||
hWnd window-focus send-gesture drop
|
||||
hWnd window-focus propagate-gesture
|
||||
] unless ;
|
||||
|
||||
:: 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 -- )
|
||||
wParam keystroke>gesture <key-up>
|
||||
hWnd window-focus send-gesture drop ;
|
||||
hWnd window-focus propagate-gesture ;
|
||||
|
||||
:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
|
||||
? hwnd window (>>active?)
|
||||
|
|
@ -381,11 +381,9 @@ SYMBOL: trace-messages?
|
|||
! return 0 if you handle the message, else just let DefWindowProc return its val
|
||||
: ui-wndproc ( -- object )
|
||||
"uint" { "void*" "uint" "long" "long" } "stdcall" [
|
||||
[
|
||||
pick
|
||||
trace-messages? get-global [ dup windows-message-name name>> print flush ] when
|
||||
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
|
||||
] ui-try
|
||||
pick
|
||||
trace-messages? get-global [ dup windows-message-name name>> print flush ] when
|
||||
wm-handlers get-global at* [ call ] [ drop DefWindowProc ] if
|
||||
] alien-callback ;
|
||||
|
||||
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ x11.events x11.xim x11.glx x11.clipboard x11.constants
|
|||
x11.windows io.encodings.string io.encodings.ascii
|
||||
io.encodings.utf8 combinators debugger command-line qualified
|
||||
math.vectors classes.tuple opengl.gl threads math.geometry.rect
|
||||
environment ;
|
||||
environment ascii ;
|
||||
IN: ui.x11
|
||||
|
||||
SINGLETON: x11-ui-backend
|
||||
|
|
@ -67,20 +67,32 @@ M: world configure-event
|
|||
: event-modifiers ( event -- seq )
|
||||
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 )
|
||||
dupd
|
||||
handle>> xic>> lookup-string
|
||||
>r swap event-modifiers r> key-code <key-down> ;
|
||||
|
||||
M: world key-down-event
|
||||
[ key-down-event>gesture ] keep world-focus
|
||||
[ send-gesture ] keep swap [ user-input ] [ 2drop ] if ;
|
||||
[ key-down-event>gesture ] keep
|
||||
world-focus
|
||||
[ propagate-gesture drop ]
|
||||
[ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
|
||||
3bi ;
|
||||
|
||||
: key-up-event>gesture ( event -- gesture )
|
||||
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
|
||||
|
||||
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 )
|
||||
dup event-modifiers over XButtonEvent-button
|
||||
|
|
@ -185,7 +197,7 @@ M: world client-event
|
|||
|
||||
M: x11-ui-backend do-events
|
||||
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 )
|
||||
atom>> swap
|
||||
|
|
|
|||
|
|
@ -9,6 +9,6 @@ USING: math kernel alien ;
|
|||
] alien-callback
|
||||
"int" { "int" } "cdecl" alien-indirect ;
|
||||
|
||||
: fib-main ( -- ) 25 fib drop ;
|
||||
: fib-main ( -- ) 34 fib drop ;
|
||||
|
||||
MAIN: fib-main
|
||||
|
|
|
|||
|
|
@ -224,13 +224,13 @@ SYMBOL: dlist
|
|||
|
||||
: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
|
||||
|
||||
: cfdg-window* ( -- )
|
||||
: cfdg-window* ( -- slate )
|
||||
C[ display ] <slate>
|
||||
{ 500 500 } >>pdim
|
||||
C[ delete-dlist ] >>ungraft
|
||||
dup "CFDG" open-window ;
|
||||
|
||||
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
|
||||
: cfdg-window ( -- slate ) [ cfdg-window* ] with-ui ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
196
misc/factor.el
196
misc/factor.el
|
|
@ -35,6 +35,7 @@
|
|||
|
||||
(require 'font-lock)
|
||||
(require 'comint)
|
||||
(require 'view)
|
||||
|
||||
;;; Customization:
|
||||
|
||||
|
|
@ -64,6 +65,30 @@ value from the existing code in the buffer."
|
|||
:type '(file :must-match t)
|
||||
: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
|
||||
"Display the REPL buffer before compiling files."
|
||||
:type 'boolean
|
||||
|
|
@ -74,6 +99,11 @@ value from the existing code in the buffer."
|
|||
:type 'hook
|
||||
:group 'factor)
|
||||
|
||||
(defcustom factor-help-mode-hook nil
|
||||
"Hook run by `factor-help-mode'."
|
||||
:type 'hook
|
||||
:group 'factor)
|
||||
|
||||
(defgroup factor-faces nil
|
||||
"Faces used in Factor mode"
|
||||
:group 'factor
|
||||
|
|
@ -125,6 +155,10 @@ value from the existing code in the buffer."
|
|||
"Face for parsing words."
|
||||
: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:
|
||||
|
||||
|
|
@ -429,18 +463,6 @@ value from the existing code in the buffer."
|
|||
(factor-send-region (search-backward ":")
|
||||
(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 ()
|
||||
(interactive)
|
||||
(comint-send-string "*factor*" "\\ ")
|
||||
|
|
@ -459,17 +481,6 @@ value from the existing code in the buffer."
|
|||
(defvar factor-mode-map (make-sparse-keymap)
|
||||
"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:
|
||||
|
||||
|
|
@ -494,23 +505,118 @@ value from the existing code in the buffer."
|
|||
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
|
||||
|
||||
|
||||
;;; Factor listener mode
|
||||
;;; Factor listener mode:
|
||||
|
||||
;;;###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
|
||||
(defun run-factor ()
|
||||
"Start a factor listener inside emacs, or switch to it if it
|
||||
already exists."
|
||||
(defalias 'switch-to-factor 'run-factor)
|
||||
;;;###autoload
|
||||
(defun run-factor (&optional arg)
|
||||
"Show the factor-listener buffer, starting the process if needed."
|
||||
(interactive)
|
||||
(switch-to-buffer
|
||||
(make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil
|
||||
(concat "-i=" (expand-file-name factor-image))
|
||||
"-run=listener"))
|
||||
(factor-listener-mode))
|
||||
(let ((buf (process-buffer (factor--listener-process)))
|
||||
(pop-up-windows factor-listener-window-allow-split))
|
||||
(if factor-listener-use-other-window
|
||||
(pop-to-buffer buf)
|
||||
(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 ()
|
||||
"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"))
|
||||
|
||||
|
||||
;;; 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)
|
||||
;;; factor.el ends here
|
||||
|
|
|
|||
36
vm/run.c
36
vm/run.c
|
|
@ -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 */
|
||||
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_top = (F_STACK_FRAME *)-1;
|
||||
|
|
@ -54,9 +79,6 @@ void nest_stacks(void)
|
|||
new_stacks->current_callback_save = userenv[CURRENT_CALLBACK_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;
|
||||
stack_chain = new_stacks;
|
||||
|
||||
|
|
@ -67,9 +89,6 @@ void nest_stacks(void)
|
|||
/* called when leaving a compiled callback */
|
||||
void unnest_stacks(void)
|
||||
{
|
||||
dealloc_segment(stack_chain->datastack_region);
|
||||
dealloc_segment(stack_chain->retainstack_region);
|
||||
|
||||
ds = stack_chain->datastack_save;
|
||||
rs = stack_chain->retainstack_save;
|
||||
|
||||
|
|
@ -79,7 +98,7 @@ void unnest_stacks(void)
|
|||
|
||||
F_CONTEXT *old_stacks = stack_chain;
|
||||
stack_chain = old_stacks->next;
|
||||
free(old_stacks);
|
||||
dealloc_context(old_stacks);
|
||||
}
|
||||
|
||||
/* called on startup */
|
||||
|
|
@ -88,6 +107,7 @@ void init_stacks(CELL ds_size_, CELL rs_size_)
|
|||
ds_size = ds_size_;
|
||||
rs_size = rs_size_;
|
||||
stack_chain = NULL;
|
||||
unused_contexts = NULL;
|
||||
}
|
||||
|
||||
bool stack_to_array(CELL bottom, CELL top)
|
||||
|
|
|
|||
Loading…
Reference in New Issue