UI improvements, new apropos tool
slava
parent
6c3a2e86b2
commit
e0a875bc6b
|
|
@ -8,10 +8,10 @@ objc-NSNotificationCenter objc-NSObject objc-NSView threads ;
|
|||
: with-autorelease-pool ( quot -- )
|
||||
NSAutoreleasePool [new] slip [release] ; inline
|
||||
|
||||
: NSApp NSApplication [sharedApplication] ;
|
||||
|
||||
: with-cocoa ( quot -- )
|
||||
[
|
||||
NSApplication [sharedApplication] drop call
|
||||
] with-autorelease-pool ;
|
||||
[ NSApp drop call ] with-autorelease-pool ;
|
||||
|
||||
: <NSString> <CFString> [autorelease] ;
|
||||
|
||||
|
|
@ -30,9 +30,8 @@ objc-NSNotificationCenter objc-NSObject objc-NSView threads ;
|
|||
dup do-event [ do-events ] [ drop ] if ;
|
||||
|
||||
: event-loop ( -- )
|
||||
[
|
||||
NSApplication [sharedApplication] do-events ui-step
|
||||
] with-autorelease-pool event-loop ;
|
||||
[ NSApp do-events ui-step ] with-autorelease-pool
|
||||
event-loop ;
|
||||
|
||||
: add-observer ( observer selector name object -- )
|
||||
>r >r >r >r NSNotificationCenter [defaultCenter] r> r>
|
||||
|
|
@ -42,8 +41,7 @@ objc-NSNotificationCenter objc-NSObject objc-NSView threads ;
|
|||
>r NSNotificationCenter [defaultCenter] r>
|
||||
[removeObserver:] ;
|
||||
|
||||
: finish-launching ( -- )
|
||||
NSApplication [sharedApplication] [finishLaunching] ;
|
||||
: finish-launching ( -- ) NSApp [finishLaunching] ;
|
||||
|
||||
IN: errors
|
||||
|
||||
|
|
|
|||
|
|
@ -6,11 +6,11 @@ USING: hashtables kernel namespaces objc objc-NSObject ;
|
|||
|
||||
SYMBOL: callbacks
|
||||
|
||||
H{ } clone callbacks set
|
||||
H{ } clone callbacks set-global
|
||||
|
||||
"NSObject" "FactorCallback" {
|
||||
{ "perform:" "void" { "id" "SEL" "id" }
|
||||
[ nip swap callbacks get hash call ]
|
||||
[ 2drop callbacks get hash call ]
|
||||
}
|
||||
|
||||
{ "dealloc" "void" { "id" "SEL" }
|
||||
|
|
|
|||
|
|
@ -1,28 +1,24 @@
|
|||
USING: kernel sequences objc cocoa objc-NSObject
|
||||
objc-NSApplication objc-NSWindow objc-NSMenu objc-NSMenuItem
|
||||
objc-FactorCallback gadgets gadgets-layouts gadgets-listener
|
||||
words compiler strings ;
|
||||
|
||||
! for words used by menu bar actions (copied from launchpad.factor)
|
||||
USING: gadgets gadgets-browser gadgets-listener help inspector
|
||||
io kernel memory namespaces sequences gadgets-launchpad ;
|
||||
|
||||
IN: cocoa
|
||||
|
||||
: NSApp NSApplication [sharedApplication] ;
|
||||
USING: cocoa compiler gadgets gadgets-launchpad gadgets-layouts
|
||||
gadgets-listener kernel memory objc objc-FactorCallback
|
||||
objc-NSApplication objc-NSMenu objc-NSMenuItem objc-NSObject
|
||||
objc-NSWindow sequences strings words ;
|
||||
IN: gadgets-cocoa
|
||||
|
||||
! -------------------------------------------------------------------------
|
||||
|
||||
GENERIC: to-target-and-action ( selector-string-or-quotation -- target action )
|
||||
GENERIC: to-target-and-action ( spec -- target action )
|
||||
|
||||
M: string to-target-and-action sel_registerName f swap ;
|
||||
M: f to-target-and-action f ;
|
||||
M: quotation to-target-and-action \ drop add* <FactorCallback> "perform:" sel_registerName ;
|
||||
M: string to-target-and-action sel_registerName f swap ;
|
||||
M: word to-target-and-action
|
||||
unit <FactorCallback> "perform:" sel_registerName ;
|
||||
|
||||
: <NSMenu> ( title -- )
|
||||
NSMenu [alloc]
|
||||
swap <NSString> [initWithTitle:]
|
||||
[autorelease] ;
|
||||
|
||||
: <NSMenu> NSMenu [alloc] swap <NSString> [initWithTitle:] [autorelease] ;
|
||||
|
||||
: set-main-menu NSApp swap [setMainMenu:] ;
|
||||
: set-main-menu ( menu -- ) NSApp swap [setMainMenu:] ;
|
||||
|
||||
: <NSMenuItem> ( title action equivalent -- item )
|
||||
>r >r >r
|
||||
|
|
@ -32,7 +28,7 @@ M: quotation to-target-and-action \ drop add* <FactorCallback> "perform:" sel_re
|
|||
r> <NSString>
|
||||
[initWithTitle:action:keyEquivalent:] [autorelease] ;
|
||||
|
||||
: make-menu-item-2 ( title selector-string-or-quotation equivalent -- item )
|
||||
: make-menu-item-2 ( title spec -- item )
|
||||
swap to-target-and-action swap >r swap <NSMenuItem> dup r> [setTarget:] ;
|
||||
|
||||
: submenu-to-item ( menu -- item )
|
||||
|
|
@ -96,23 +92,24 @@ DEFER: described-menu
|
|||
! Preferences goes here
|
||||
{ {
|
||||
"Services"
|
||||
} [ dup NSApp swap [setServicesMenu:] ] }
|
||||
} [ NSApp over [setServicesMenu:] ] }
|
||||
{ }
|
||||
{ "Hide Factor" "hide:" "h" }
|
||||
{ "Hide Others" "hideOtherApplications:" "h" [ and-option-equivalent-modifier ] }
|
||||
{ "Show All" "unhideAllApplications:" "" }
|
||||
{ }
|
||||
{ "Save Image" [ save ] "s" }
|
||||
{ "Save Image" save "s" }
|
||||
{ }
|
||||
{ "Quit" "terminate:" "q" }
|
||||
} [ dup NSApp swap [setAppleMenu:] ] }
|
||||
} [ NSApp over [setAppleMenu:] ] }
|
||||
{ {
|
||||
! Tools is standing in for the File menu
|
||||
"Tools"
|
||||
{ "Listener" [ listener-window ] "n" }
|
||||
{ "Vocabulary List" [ [ vocabs. ] "Vocabularies" pane-window ] "y" }
|
||||
{ "Globals" [ global browser-window ] "u" }
|
||||
{ "Memory" [ [ heap-stats. terpri room. ] "Memory" pane-window ] "u" }
|
||||
{ "Listener" listener-window "n" }
|
||||
{ "Apropos" apropos-window "r" }
|
||||
{ "Vocabularies" vocabs-window "y" }
|
||||
{ "Globals" global-window "u" }
|
||||
{ "Memory" memory-window "m" }
|
||||
} }
|
||||
{ {
|
||||
"Edit"
|
||||
|
|
@ -136,11 +133,10 @@ DEFER: described-menu
|
|||
{ "Minimize All" "miniaturizeAll:" "m" [ and-alternate and-option-equivalent-modifier ] }
|
||||
{ }
|
||||
{ "Bring All to Front" "arrangeInFront:" "" }
|
||||
} [ dup NSApp swap [setWindowsMenu:] ] }
|
||||
} [ NSApp over [setWindowsMenu:] ] }
|
||||
{ {
|
||||
"Help"
|
||||
{ "Factor Documentation" [ handbook-window ] "?" }
|
||||
{ "Help Index" [ [ articles. ] "Help index" pane-window ] "" }
|
||||
{ "Vocabularies" [ [ vocabs. ] "Vocabularies" pane-window ] "" }
|
||||
{ "Factor Documentation" handbook-window "?" }
|
||||
{ "Help Index" articles-window "" }
|
||||
} }
|
||||
} described-menu set-main-menu ;
|
||||
|
|
|
|||
|
|
@ -45,10 +45,10 @@ H{ } clone views set-global
|
|||
|
||||
: modifiers
|
||||
{
|
||||
{ "SHIFT" HEX: 10000 }
|
||||
{ "CTRL" HEX: 40000 }
|
||||
{ "ALT" HEX: 80000 }
|
||||
{ "META" HEX: 100000 }
|
||||
{ S+ HEX: 10000 }
|
||||
{ C+ HEX: 40000 }
|
||||
{ A+ HEX: 80000 }
|
||||
{ M+ HEX: 100000 }
|
||||
} ;
|
||||
|
||||
: key-codes
|
||||
|
|
@ -70,7 +70,8 @@ H{ } clone views set-global
|
|||
[ ] [ [charactersIgnoringModifiers] CF>string ] ?if ;
|
||||
|
||||
: event>gesture ( event -- gesture )
|
||||
dup [modifierFlags] modifiers modifier swap key-code add ;
|
||||
dup [modifierFlags] modifiers modifier swap key-code
|
||||
<key-down> ;
|
||||
|
||||
: send-key-event ( view event -- )
|
||||
>r view world-focus r> dup event>gesture pick handle-gesture
|
||||
|
|
@ -187,9 +188,9 @@ H{ } clone views set-global
|
|||
"NSObject" "FactorUIWindowDelegate" {
|
||||
{ "windowWillUseStandardFrame:defaultFrame:" "NSRect" { "id" "SEL" "id" "NSRect" }
|
||||
[
|
||||
drop 2nip ( self sel window default-frame -- window )
|
||||
dup window-content-rect NSRect-x-far-y ( window -- window x y )
|
||||
pick window-root-gadget-pref-dim first2 ( window x y -- window x y w h )
|
||||
drop 2nip
|
||||
dup window-content-rect NSRect-x-far-y
|
||||
pick window-root-gadget-pref-dim first2
|
||||
<far-y-NSRect>
|
||||
frame-rect-for-window-content-rect
|
||||
]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,34 @@
|
|||
IN: gadgets-apropos
|
||||
USING: gadgets gadgets-editors gadgets-labels gadgets-layouts
|
||||
gadgets-panes gadgets-scrolling generic kernel inspector ;
|
||||
|
||||
TUPLE: apropos-gadget pane input ;
|
||||
|
||||
: apropos-pane ( gadget -- pane )
|
||||
[ apropos-gadget? ] find-parent apropos-gadget-pane ;
|
||||
|
||||
: add-apropos-gadget-pane ( pane gadget -- )
|
||||
2dup set-apropos-gadget-pane
|
||||
>r <scroller> r> @center frame-add ;
|
||||
|
||||
: add-apropos-gadget-input ( input gadget -- )
|
||||
2dup set-apropos-gadget-input @top frame-add ;
|
||||
|
||||
: <prompt> ( quot -- editor )
|
||||
"" <editor> [
|
||||
swap T{ key-down f f "RETURN" } set-action
|
||||
] keep ;
|
||||
|
||||
: show-apropos ( editor -- )
|
||||
dup commit-editor-text
|
||||
swap apropos-pane [ apropos ] with-pane ;
|
||||
|
||||
C: apropos-gadget ( -- )
|
||||
<frame> over set-delegate
|
||||
<pane> over add-apropos-gadget-pane
|
||||
[ show-apropos ] <prompt> over add-apropos-gadget-input ;
|
||||
|
||||
M: apropos-gadget pref-dim* drop { 350 200 0 } ;
|
||||
|
||||
M: apropos-gadget focusable-child* ( pane -- editor )
|
||||
apropos-gadget-input ;
|
||||
|
|
@ -98,7 +98,7 @@ TUPLE: browser-button object ;
|
|||
: browser-button-gestures ( gadget -- )
|
||||
[
|
||||
[ browser-button-object browser-window ] if-clicked
|
||||
] [ button-up 3 ] set-action ;
|
||||
] T{ button-up f 3 } set-action ;
|
||||
|
||||
C: browser-button ( gadget object -- button )
|
||||
[ set-browser-button-object ] keep
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ generic io kernel math namespaces sequences styles threads ;
|
|||
|
||||
TUPLE: button rollover? pressed? quot ;
|
||||
|
||||
: button-down? ( -- ? )
|
||||
: buttons-down? ( -- ? )
|
||||
hand-buttons get-global empty? not ;
|
||||
|
||||
: mouse-over? ( gadget -- ? )
|
||||
|
|
@ -17,7 +17,7 @@ TUPLE: button rollover? pressed? quot ;
|
|||
|
||||
: button-update ( button -- )
|
||||
dup mouse-over? over set-button-rollover?
|
||||
dup mouse-clicked? button-down? and
|
||||
dup mouse-clicked? buttons-down? and
|
||||
over button-rollover? and over set-button-pressed?
|
||||
relayout-1 ;
|
||||
|
||||
|
|
@ -29,10 +29,10 @@ TUPLE: button rollover? pressed? quot ;
|
|||
|
||||
: button-gestures ( button quot -- )
|
||||
over set-button-quot
|
||||
dup [ button-clicked ] [ button-up ] set-action
|
||||
dup [ button-update ] [ button-down ] set-action
|
||||
dup [ button-update ] [ mouse-leave ] set-action
|
||||
[ button-update ] [ mouse-enter ] set-action ;
|
||||
dup [ button-clicked ] T{ button-up } set-action
|
||||
dup [ button-update ] T{ button-down } set-action
|
||||
dup [ button-update ] T{ mouse-leave } set-action
|
||||
[ button-update ] T{ mouse-enter } set-action ;
|
||||
|
||||
C: button ( gadget quot -- button )
|
||||
rot <default-border> over set-gadget-delegate
|
||||
|
|
@ -54,8 +54,8 @@ C: button ( gadget quot -- button )
|
|||
dup button-update remove-timer ;
|
||||
|
||||
: repeat-actions ( button -- )
|
||||
dup [ repeat-button-down ] [ button-down ] set-action
|
||||
[ repeat-button-up ] [ button-up ] set-action ;
|
||||
dup [ repeat-button-down ] T{ button-down } set-action
|
||||
[ repeat-button-up ] T{ button-up } set-action ;
|
||||
|
||||
: <repeat-button> ( gadget quot -- button )
|
||||
#! Button that calls the quotation every 100ms as long as
|
||||
|
|
|
|||
|
|
@ -46,6 +46,10 @@ TUPLE: editor line caret font color ;
|
|||
: set-editor-text ( text editor -- )
|
||||
[ set-line-text ] with-editor ;
|
||||
|
||||
: commit-editor-text ( editor -- line )
|
||||
#! Add current line to the history, and clear the editor.
|
||||
[ commit-history line-text get line-clear ] with-editor ;
|
||||
|
||||
: focus-editor ( editor -- )
|
||||
dup editor-caret swap add-caret ;
|
||||
|
||||
|
|
@ -96,23 +100,23 @@ TUPLE: editor line caret font color ;
|
|||
|
||||
: editor-actions ( editor -- )
|
||||
H{
|
||||
{ [ gain-focus ] [ focus-editor ] }
|
||||
{ [ lose-focus ] [ unfocus-editor ] }
|
||||
{ [ button-down ] [ click-editor ] }
|
||||
{ [ "BACKSPACE" ] [ [ T{ char-elt } delete-prev-elt ] with-editor ] }
|
||||
{ [ "DELETE" ] [ [ T{ char-elt } delete-next-elt ] with-editor ] }
|
||||
{ [ "CTRL" "BACKSPACE" ] [ [ T{ word-elt } delete-prev-elt ] with-editor ] }
|
||||
{ [ "CTRL" "DELETE" ] [ [ T{ word-elt } delete-next-elt ] with-editor ] }
|
||||
{ [ "ALT" "BACKSPACE" ] [ [ T{ document-elt } delete-prev-elt ] with-editor ] }
|
||||
{ [ "ALT" "DELETE" ] [ [ T{ document-elt } delete-next-elt ] with-editor ] }
|
||||
{ [ "LEFT" ] [ [ T{ char-elt } prev-elt ] with-editor ] }
|
||||
{ [ "RIGHT" ] [ [ T{ char-elt } next-elt ] with-editor ] }
|
||||
{ [ "CTRL" "LEFT" ] [ [ T{ word-elt } prev-elt ] with-editor ] }
|
||||
{ [ "CTRL" "RIGHT" ] [ [ T{ word-elt } next-elt ] with-editor ] }
|
||||
{ [ "HOME" ] [ [ T{ document-elt } prev-elt ] with-editor ] }
|
||||
{ [ "END" ] [ [ T{ document-elt } next-elt ] with-editor ] }
|
||||
{ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] }
|
||||
{ [ "TAB" ] [ do-completion ] }
|
||||
{ T{ gain-focus } [ focus-editor ] }
|
||||
{ T{ lose-focus } [ unfocus-editor ] }
|
||||
{ T{ button-down } [ click-editor ] }
|
||||
{ T{ key-down f f "BACKSPACE" } [ [ T{ char-elt } delete-prev-elt ] with-editor ] }
|
||||
{ T{ key-down f f "DELETE" } [ [ T{ char-elt } delete-next-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "BACKSPACE" } [ [ T{ word-elt } delete-prev-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "DELETE" } [ [ T{ word-elt } delete-next-elt ] with-editor ] }
|
||||
{ T{ key-down f { A+ } "BACKSPACE" } [ [ T{ document-elt } delete-prev-elt ] with-editor ] }
|
||||
{ T{ key-down f { A+ } "DELETE" } [ [ T{ document-elt } delete-next-elt ] with-editor ] }
|
||||
{ T{ key-down f f "LEFT" } [ [ T{ char-elt } prev-elt ] with-editor ] }
|
||||
{ T{ key-down f f "RIGHT" } [ [ T{ char-elt } next-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "LEFT" } [ [ T{ word-elt } prev-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "RIGHT" } [ [ T{ word-elt } next-elt ] with-editor ] }
|
||||
{ T{ key-down f f "HOME" } [ [ T{ document-elt } prev-elt ] with-editor ] }
|
||||
{ T{ key-down f f "END" } [ [ T{ document-elt } next-elt ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "k" } [ [ line-clear ] with-editor ] }
|
||||
{ T{ key-down f f "TAB" } [ do-completion ] }
|
||||
} add-actions ;
|
||||
|
||||
C: editor ( text -- )
|
||||
|
|
|
|||
|
|
@ -30,18 +30,32 @@ namespaces queues sequences threads ;
|
|||
: user-input ( str gadget -- )
|
||||
[ dupd user-input* ] each-parent 2drop ;
|
||||
|
||||
! Mouse gestures are arrays where the first element is one of:
|
||||
SYMBOL: motion
|
||||
SYMBOL: drag
|
||||
SYMBOL: button-up
|
||||
SYMBOL: button-down
|
||||
SYMBOL: wheel-up
|
||||
SYMBOL: wheel-down
|
||||
SYMBOL: mouse-enter
|
||||
SYMBOL: mouse-leave
|
||||
! Gesture objects
|
||||
TUPLE: motion ;
|
||||
TUPLE: drag # ;
|
||||
TUPLE: button-up # ;
|
||||
TUPLE: button-down # ;
|
||||
TUPLE: wheel-up ;
|
||||
TUPLE: wheel-down ;
|
||||
TUPLE: mouse-enter ;
|
||||
TUPLE: mouse-leave ;
|
||||
TUPLE: lose-focus ;
|
||||
TUPLE: gain-focus ;
|
||||
|
||||
SYMBOL: lose-focus
|
||||
SYMBOL: gain-focus
|
||||
GENERIC: with-button ( button# tuple -- tuple )
|
||||
|
||||
M: drag with-button drop <drag> ;
|
||||
M: button-up with-button drop <button-up> ;
|
||||
M: button-down with-button drop <button-down> ;
|
||||
|
||||
! Modifiers
|
||||
SYMBOL: C+
|
||||
SYMBOL: A+
|
||||
SYMBOL: M+
|
||||
SYMBOL: S+
|
||||
|
||||
TUPLE: key-down mods sym ;
|
||||
TUPLE: key-up mods sym ;
|
||||
|
||||
! Hand state
|
||||
|
||||
|
|
@ -61,20 +75,21 @@ V{ } clone hand-buttons set-global
|
|||
|
||||
: button-gesture ( button gesture -- )
|
||||
#! Send a gesture like [ button-down 2 ]; if nobody
|
||||
#! handles it, send [ button-down ].
|
||||
swap hand-clicked get-global 3dup >r add r> handle-gesture
|
||||
[ nip handle-gesture drop ] [ 3drop ] if ;
|
||||
#! handles it, send T{ button-down }.
|
||||
hand-clicked get-global
|
||||
3dup >r with-button r> handle-gesture
|
||||
[ handle-gesture 2drop ] [ 3drop ] if ;
|
||||
|
||||
: drag-gesture ( -- )
|
||||
#! Send a gesture like [ drag 2 ]; if nobody handles it,
|
||||
#! send [ drag ].
|
||||
hand-buttons get-global first [ drag ] button-gesture ;
|
||||
#! send T{ drag }.
|
||||
hand-buttons get-global first T{ drag } button-gesture ;
|
||||
|
||||
: fire-motion ( -- )
|
||||
#! Fire a motion gesture to the gadget underneath the hand,
|
||||
#! and if a mouse button is down, fire a drag gesture to the
|
||||
#! gadget that was clicked.
|
||||
[ motion ] hand-gadget get-global handle-gesture drop
|
||||
T{ motion } hand-gadget get-global handle-gesture drop
|
||||
hand-buttons get-global empty? [ drag-gesture ] unless ;
|
||||
|
||||
: each-gesture ( gesture seq -- )
|
||||
|
|
@ -82,14 +97,14 @@ V{ } clone hand-buttons set-global
|
|||
|
||||
: hand-gestures ( new old -- )
|
||||
drop-prefix <reversed>
|
||||
[ mouse-leave ] swap each-gesture
|
||||
T{ mouse-leave } swap each-gesture
|
||||
fire-motion
|
||||
[ mouse-enter ] swap each-gesture ;
|
||||
T{ mouse-enter } swap each-gesture ;
|
||||
|
||||
: focus-gestures ( new old -- )
|
||||
drop-prefix <reversed>
|
||||
[ lose-focus ] swap each-gesture
|
||||
[ gain-focus ] swap each-gesture ;
|
||||
T{ lose-focus } swap each-gesture
|
||||
T{ gain-focus } swap each-gesture ;
|
||||
|
||||
: request-focus* ( gadget world -- )
|
||||
dup focused-ancestors >r
|
||||
|
|
@ -101,7 +116,7 @@ V{ } clone hand-buttons set-global
|
|||
|
||||
: modifier ( mod modifiers -- seq )
|
||||
[ second swap bitand 0 > ] subset-with
|
||||
[ first ] map ;
|
||||
[ first ] map f like ;
|
||||
|
||||
: drag-loc ( -- loc )
|
||||
hand-loc get-global hand-click-loc get-global v- ;
|
||||
|
|
@ -139,14 +154,14 @@ V{ } clone hand-buttons set-global
|
|||
: send-button-down ( button# loc world -- )
|
||||
update-clicked
|
||||
dup hand-buttons get-global push
|
||||
[ button-down ] button-gesture ;
|
||||
T{ button-down } button-gesture ;
|
||||
|
||||
: send-button-up ( button# loc world -- )
|
||||
move-hand
|
||||
dup hand-buttons get-global delete
|
||||
[ button-up ] button-gesture ;
|
||||
T{ button-up } button-gesture ;
|
||||
|
||||
: send-wheel ( up/down loc world -- )
|
||||
move-hand
|
||||
[ wheel-up ] [ wheel-down ] ?
|
||||
T{ wheel-up } T{ wheel-down } ?
|
||||
hand-gadget get-global handle-gesture drop ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
IN: gadgets-launchpad
|
||||
USING: gadgets gadgets-browser gadgets-borders gadgets-buttons
|
||||
gadgets-labels gadgets-layouts gadgets-listener gadgets-panes
|
||||
gadgets-scrolling gadgets-theme help inspector io kernel memory
|
||||
namespaces sequences ;
|
||||
USING: gadgets gadgets-apropos gadgets-browser gadgets-borders
|
||||
gadgets-buttons gadgets-labels gadgets-layouts gadgets-listener
|
||||
gadgets-panes gadgets-scrolling gadgets-theme help inspector io
|
||||
kernel memory namespaces sequences ;
|
||||
|
||||
: <launchpad> ( menu -- )
|
||||
[ first2 >r <label> [ drop ] r> append <bevel-button> ] map
|
||||
|
|
@ -15,14 +15,30 @@ namespaces sequences ;
|
|||
: handbook-window ( -- )
|
||||
T{ link f "handbook" } browser-window ;
|
||||
|
||||
: memory-window ( -- )
|
||||
[ heap-stats. terpri room. ] "Memory" pane-window ;
|
||||
|
||||
: articles-window ( -- )
|
||||
[ articles. ] "Help index" pane-window ;
|
||||
|
||||
: apropos-window ( -- )
|
||||
<apropos-gadget> "Apropos" open-window ;
|
||||
|
||||
: vocabs-window ( -- )
|
||||
[ vocabs. ] "Vocabularies" pane-window ;
|
||||
|
||||
: global-window ( -- )
|
||||
global browser-window ;
|
||||
|
||||
: default-launchpad
|
||||
{
|
||||
{ "Listener" [ listener-window ] }
|
||||
{ "Documentation" [ handbook-window ] }
|
||||
{ "Help index" [ [ articles. ] "Help index" pane-window ] }
|
||||
{ "Vocabularies" [ [ vocabs. ] "Vocabularies" pane-window ] }
|
||||
{ "Globals" [ global browser-window ] }
|
||||
{ "Memory" [ [ heap-stats. terpri room. ] "Memory" pane-window ] }
|
||||
{ "Help index" [ articles-window ] }
|
||||
{ "Apropos" [ apropos-window ] }
|
||||
{ "Vocabularies" [ vocabs-window ] }
|
||||
{ "Globals" [ global-window ] }
|
||||
{ "Memory" [ memory-window ] }
|
||||
{ "Save image" [ save ] }
|
||||
{ "Exit" [ 0 exit ] }
|
||||
} <launchpad> ;
|
||||
|
|
|
|||
|
|
@ -43,10 +43,6 @@ SYMBOL: structured-input
|
|||
"\"structured-input\" \"gadgets-panes\" lookup get-global call"
|
||||
r> pane-eval ;
|
||||
|
||||
: editor-commit ( editor -- line )
|
||||
#! Add current line to the history, and clear the editor.
|
||||
[ commit-history line-text get line-clear ] with-editor ;
|
||||
|
||||
: replace-input ( string pane -- )
|
||||
pane-input set-editor-text ;
|
||||
|
||||
|
|
@ -59,18 +55,19 @@ SYMBOL: structured-input
|
|||
] with-stream* ;
|
||||
|
||||
: pane-commit ( pane -- )
|
||||
dup pane-input editor-commit swap 2dup print-input pane-eval ;
|
||||
dup pane-input commit-editor-text
|
||||
swap 2dup print-input pane-eval ;
|
||||
|
||||
: pane-clear ( pane -- )
|
||||
dup pane-output clear-incremental pane-current clear-gadget ;
|
||||
|
||||
: pane-actions ( line -- )
|
||||
H{
|
||||
{ [ button-down ] [ pane-input click-editor ] }
|
||||
{ [ "RETURN" ] [ pane-commit ] }
|
||||
{ [ "UP" ] [ pane-input [ history-prev ] with-editor ] }
|
||||
{ [ "DOWN" ] [ pane-input [ history-next ] with-editor ] }
|
||||
{ [ "CTRL" "l" ] [ pane-clear ] }
|
||||
{ T{ button-down } [ pane-input click-editor ] }
|
||||
{ T{ key-down f f "RETURN" } [ pane-commit ] }
|
||||
{ T{ key-down f f "UP" } [ pane-input [ history-prev ] with-editor ] }
|
||||
{ T{ key-down f f "DOWN" } [ pane-input [ history-next ] with-editor ] }
|
||||
{ T{ key-down f { C+ } "l" } [ pane-clear ] }
|
||||
} add-actions ;
|
||||
|
||||
C: pane ( -- pane )
|
||||
|
|
|
|||
|
|
@ -88,9 +88,9 @@ M: viewport focusable-child* ( viewport -- gadget )
|
|||
: scroll-down-line scroller-y 1 swap slide-by-line ;
|
||||
|
||||
: scroller-actions ( scroller -- )
|
||||
dup [ scroll-up-line ] [ wheel-up ] set-action
|
||||
dup [ scroll-down-line ] [ wheel-down ] set-action
|
||||
[ scroller-viewport relayout-1 ] [ slider-changed ] set-action ;
|
||||
dup [ scroll-up-line ] T{ wheel-up } set-action
|
||||
dup [ scroll-down-line ] T{ wheel-down } set-action
|
||||
[ scroller-viewport relayout-1 ] T{ slider-changed } set-action ;
|
||||
|
||||
C: scroller ( gadget -- scroller )
|
||||
#! Wrap a scrolling pane around the gadget.
|
||||
|
|
|
|||
|
|
@ -34,14 +34,14 @@ TUPLE: slider elevator thumb value saved max page ;
|
|||
dup slider-elevator relayout-1
|
||||
dup slider-max over slider-page max swap set-slider-max ;
|
||||
|
||||
SYMBOL: slider-changed
|
||||
TUPLE: slider-changed ;
|
||||
|
||||
: set-slider-value* ( value slider -- )
|
||||
[ fix-slider-value ] keep 2dup slider-value = [
|
||||
2drop
|
||||
] [
|
||||
[ set-slider-value ] keep [ fix-slider ] keep
|
||||
[ slider-changed ] swap handle-gesture drop
|
||||
T{ slider-changed } swap handle-gesture drop
|
||||
] if ;
|
||||
|
||||
: begin-drag ( thumb -- )
|
||||
|
|
@ -53,9 +53,9 @@ SYMBOL: slider-changed
|
|||
set-slider-value* ;
|
||||
|
||||
: thumb-actions ( thumb -- )
|
||||
dup [ drop ] [ button-up ] set-action
|
||||
dup [ begin-drag ] [ button-down ] set-action
|
||||
[ do-drag ] [ drag ] set-action ;
|
||||
dup [ drop ] T{ button-up } set-action
|
||||
dup [ begin-drag ] T{ button-down } set-action
|
||||
[ do-drag ] T{ drag } set-action ;
|
||||
|
||||
: <thumb> ( vector -- thumb )
|
||||
<gadget> [ set-gadget-orientation ] keep
|
||||
|
|
@ -77,7 +77,7 @@ SYMBOL: slider-changed
|
|||
swap slide-by-page ;
|
||||
|
||||
: elevator-actions ( elevator -- )
|
||||
[ elevator-click ] [ button-down ] set-action ;
|
||||
[ elevator-click ] T{ button-down } set-action ;
|
||||
|
||||
C: elevator ( vector -- elevator )
|
||||
dup delegate>gadget [ set-gadget-orientation ] keep
|
||||
|
|
|
|||
|
|
@ -21,9 +21,9 @@ TUPLE: splitter split ;
|
|||
0 max 1 min over set-splitter-split relayout-1 ;
|
||||
|
||||
: divider-actions ( thumb -- )
|
||||
dup [ drop ] [ button-down ] set-action
|
||||
dup [ drop ] [ button-up ] set-action
|
||||
[ gadget-parent divider-motion ] [ drag ] set-action ;
|
||||
dup [ drop ] T{ button-down } set-action
|
||||
dup [ drop ] T{ button-up } set-action
|
||||
[ gadget-parent divider-motion ] T{ drag } set-action ;
|
||||
|
||||
C: divider ( -- divider )
|
||||
dup delegate>gadget
|
||||
|
|
|
|||
|
|
@ -38,9 +38,9 @@ M: world motion-event ( event world -- )
|
|||
|
||||
: modifiers
|
||||
{
|
||||
{ "SHIFT" HEX: 1 }
|
||||
{ "CTRL" HEX: 4 }
|
||||
{ "ALT" HEX: 8 }
|
||||
{ S+ HEX: 1 }
|
||||
{ C+ HEX: 4 }
|
||||
{ A+ HEX: 8 }
|
||||
} ;
|
||||
|
||||
: key-codes
|
||||
|
|
@ -77,7 +77,7 @@ M: world motion-event ( event world -- )
|
|||
|
||||
: event>gesture ( event -- gesture )
|
||||
dup XKeyEvent-state modifiers modifier
|
||||
swap key-code [ add ] [ drop f ] if* ;
|
||||
swap key-code [ <key-down> ] [ drop f ] if* ;
|
||||
|
||||
M: world key-down-event ( event world -- )
|
||||
world-focus over event>gesture [
|
||||
|
|
|
|||
Loading…
Reference in New Issue