Split up ui.factor, and other cleanups
slava
parent
3ac7498862
commit
84da85924c
9
TODO.txt
9
TODO.txt
|
|
@ -1,9 +1,9 @@
|
|||
+ 0.87:
|
||||
|
||||
- parse errors should be shown in a popup
|
||||
- menu Command: quots look dumb
|
||||
- no need for modify-listener-operation!
|
||||
- command buttons: indicate shortcuts
|
||||
- menu Command: quots look dumb
|
||||
- no need for modify-listener-operation!
|
||||
- command buttons: indicate shortcuts
|
||||
- hide popup after a restart
|
||||
- http://paste.lisp.org/display/30426
|
||||
- update ui docs
|
||||
|
||||
|
|
@ -49,6 +49,7 @@
|
|||
|
||||
+ ui:
|
||||
|
||||
- copying pane output
|
||||
- how do we refer to command shortcuts in the docs?
|
||||
- editor:
|
||||
- autoscroll
|
||||
|
|
|
|||
|
|
@ -99,3 +99,16 @@ SYMBOL: operations
|
|||
|
||||
: modify-commands ( operations quot -- operations )
|
||||
swap [ modify-command ] map-with ;
|
||||
|
||||
: command-description ( command -- element )
|
||||
dup command-name swap command-gesture gesture>string
|
||||
2array ;
|
||||
|
||||
: commands. ( commands -- )
|
||||
[ command-gesture key-down? ] subset
|
||||
[ command-description ] map
|
||||
{ { $strong "Command" } { $strong "Shortcut" } } add*
|
||||
$table ;
|
||||
|
||||
: $commands ( elt -- )
|
||||
first2 swap commands hash commands. ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,14 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets-debugger
|
||||
USING: errors sequences gadgets gadgets-buttons gadgets-listener
|
||||
gadgets-panes gadgets-lists gadgets-scrolling gadgets-theme
|
||||
kernel models arrays namespaces ;
|
||||
IN: gadgets-listener
|
||||
DEFER: call-listener
|
||||
|
||||
IN: gadgets
|
||||
USING: arrays errors gadgets gadgets-buttons
|
||||
gadgets-labels gadgets-panes gadgets-presentations
|
||||
gadgets-scrolling gadgets-theme gadgets-viewports gadgets-lists
|
||||
generic hashtables io kernel math models namespaces prettyprint
|
||||
queues sequences test threads help sequences words timers ;
|
||||
|
||||
: <debugger-button>
|
||||
[ call-listener drop ] curry <bevel-button> ;
|
||||
|
|
@ -44,3 +49,9 @@ debugger "toolbar" {
|
|||
} [
|
||||
first3 [ call-listener drop ] curry 3array
|
||||
] map define-commands
|
||||
|
||||
: debugger-window ( error restarts -- )
|
||||
restarts get <debugger> "Error" open-titled-window ;
|
||||
|
||||
: ui-try ( quot -- )
|
||||
[ debugger-window ] recover ;
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
IN: gadgets
|
||||
USING: arrays errors gadgets gadgets-buttons
|
||||
gadgets-labels gadgets-theme gadgets-panes gadgets-scrolling
|
||||
generic hashtables io kernel math models namespaces prettyprint
|
||||
queues sequences test threads help sequences words timers ;
|
||||
|
||||
TUPLE: labelled-gadget content ;
|
||||
|
||||
C: labelled-gadget ( gadget title -- gadget )
|
||||
{
|
||||
{ [ <label> dup reverse-video-theme ] f f @top }
|
||||
{ f set-labelled-gadget-content f @center }
|
||||
} make-frame* ;
|
||||
|
||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||
|
||||
: <labelled-pane> ( model quot title -- gadget )
|
||||
>r <pane-control> t over set-pane-scrolls? <scroller> r>
|
||||
<labelled-gadget> ;
|
||||
|
||||
: <close-box> ( quot -- button/f )
|
||||
gray close-box <polygon-gadget> swap <bevel-button> ;
|
||||
|
||||
: <title-label> <label> dup title-theme ;
|
||||
|
||||
: <title-bar> ( title quot -- gadget )
|
||||
[
|
||||
{
|
||||
{ [ <close-box> ] f f @left }
|
||||
{ [ <title-label> ] f f @center }
|
||||
} make-frame
|
||||
] [
|
||||
<title-label>
|
||||
] if* ;
|
||||
|
||||
TUPLE: closable-gadget content ;
|
||||
|
||||
C: closable-gadget ( gadget title quot -- gadget )
|
||||
{
|
||||
{ [ <title-bar> ] f f @top }
|
||||
{ f set-closable-gadget-content f @center }
|
||||
} make-frame* ;
|
||||
|
||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||
|
|
@ -47,6 +47,11 @@ C: presentation ( gadget object -- button )
|
|||
: <command-button> ( target command -- button )
|
||||
(command-button) <bevel-button> ;
|
||||
|
||||
: <toolbar> ( target classes -- toolbar )
|
||||
[ commands "toolbar" swap hash ] map concat
|
||||
[ <command-button> ] map-with
|
||||
make-shelf ;
|
||||
|
||||
: <menu-command> ( command -- command )
|
||||
[ hand-clicked get find-world hide-glass ]
|
||||
swap modify-command ;
|
||||
|
|
|
|||
|
|
@ -15,6 +15,7 @@ PROVIDE: core/ui
|
|||
"paint.factor"
|
||||
"gestures.factor"
|
||||
"commands.factor"
|
||||
"windows.factor"
|
||||
"gadgets/controls.factor"
|
||||
"gadgets/grid-lines.factor"
|
||||
"gadgets/theme.factor"
|
||||
|
|
@ -28,6 +29,7 @@ PROVIDE: core/ui
|
|||
"gadgets/incremental.factor"
|
||||
"gadgets/paragraphs.factor"
|
||||
"gadgets/panes.factor"
|
||||
"gadgets/labelled-gadget.factor"
|
||||
"gadgets/books.factor"
|
||||
"gadgets/outliner.factor"
|
||||
"gadgets/menus.factor"
|
||||
|
|
@ -38,9 +40,9 @@ PROVIDE: core/ui
|
|||
"text/editor.factor"
|
||||
"text/commands.factor"
|
||||
"text/interactor.factor"
|
||||
"debugger.factor"
|
||||
"ui.factor"
|
||||
"tools/tools.factor"
|
||||
"tools/debugger.factor"
|
||||
"tools/messages.factor"
|
||||
"tools/listener.factor"
|
||||
"tools/walker.factor"
|
||||
|
|
|
|||
|
|
@ -3,11 +3,10 @@
|
|||
IN: gadgets-workspace
|
||||
USING: help arrays compiler gadgets gadgets-books
|
||||
gadgets-browser gadgets-buttons gadgets-dataflow gadgets-help
|
||||
gadgets-listener gadgets-presentations gadgets-walker
|
||||
gadgets-debugger generic kernel math modules scratchpad
|
||||
sequences syntax words io namespaces hashtables
|
||||
gadgets-scrolling gadgets-panes gadgets-messages gadgets-theme
|
||||
errors ;
|
||||
gadgets-listener gadgets-presentations gadgets-walker generic
|
||||
kernel math modules scratchpad sequences syntax words io
|
||||
namespaces hashtables gadgets-scrolling gadgets-panes
|
||||
gadgets-messages gadgets-theme errors ;
|
||||
|
||||
C: tool ( gadget -- tool )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -3,28 +3,9 @@
|
|||
IN: gadgets
|
||||
USING: arrays errors gadgets gadgets-buttons
|
||||
gadgets-labels gadgets-panes gadgets-presentations
|
||||
gadgets-scrolling gadgets-theme gadgets-viewports generic
|
||||
hashtables io kernel math models namespaces prettyprint queues
|
||||
sequences test threads help sequences words timers ;
|
||||
|
||||
! Assoc mapping aliens to gadgets
|
||||
SYMBOL: windows
|
||||
|
||||
: window ( handle -- world ) windows get-global assoc ;
|
||||
|
||||
: window-focus ( handle -- gadget ) window world-focus ;
|
||||
|
||||
: register-window ( world handle -- )
|
||||
swap 2array windows get-global push ;
|
||||
|
||||
: unregister-window ( handle -- )
|
||||
windows get-global
|
||||
[ first = not ] subset-with
|
||||
windows set-global ;
|
||||
|
||||
: raised-window ( world -- )
|
||||
windows get-global [ second eq? ] find-with drop
|
||||
windows get-global [ length 1- ] keep exchange ;
|
||||
gadgets-scrolling gadgets-theme gadgets-viewports gadgets-lists
|
||||
generic hashtables io kernel math models namespaces prettyprint
|
||||
queues sequences test threads sequences words timers ;
|
||||
|
||||
: update-hand ( gadget -- )
|
||||
find-world [
|
||||
|
|
@ -57,134 +38,6 @@ SYMBOL: windows
|
|||
10 sleep
|
||||
] assert-depth ;
|
||||
|
||||
TUPLE: titled-gadget title child ;
|
||||
|
||||
M: titled-gadget gadget-title titled-gadget-title ;
|
||||
|
||||
M: titled-gadget focusable-child* titled-gadget-child ;
|
||||
|
||||
C: titled-gadget ( gadget title -- )
|
||||
[ set-titled-gadget-title ] keep
|
||||
{ { f set-titled-gadget-child f @center } } make-frame* ;
|
||||
|
||||
: open-window ( world -- )
|
||||
dup pref-dim over set-gadget-dim
|
||||
dup open-window* draw-world ;
|
||||
|
||||
: open-titled-window ( gadget title -- )
|
||||
<model> <titled-gadget> <world> open-window ;
|
||||
|
||||
: find-window ( quot -- world )
|
||||
windows get 1 <column>
|
||||
[ world-gadget swap call ] find-last-with nip ; inline
|
||||
|
||||
: start-world ( world -- )
|
||||
dup graft
|
||||
dup relayout
|
||||
world-gadget request-focus ;
|
||||
|
||||
: close-global ( world global -- )
|
||||
dup get-global find-world rot eq?
|
||||
[ f swap set-global ] [ drop ] if ;
|
||||
|
||||
: focus-world ( world -- )
|
||||
#! Sent when native window receives focus
|
||||
t over set-world-focused?
|
||||
dup raised-window
|
||||
focused-ancestors f focus-gestures ;
|
||||
|
||||
: unfocus-world ( world -- )
|
||||
#! Sent when native window loses focus.
|
||||
f over set-world-focused?
|
||||
focused-ancestors f swap focus-gestures ;
|
||||
|
||||
: reset-world ( world -- )
|
||||
dup world-fonts clear-hash
|
||||
dup unfocus-world
|
||||
f over set-world-focus
|
||||
f over set-world-handle
|
||||
ungraft ;
|
||||
|
||||
: close-world ( world -- )
|
||||
dup hand-clicked close-global
|
||||
dup hand-gadget close-global
|
||||
dup free-fonts
|
||||
reset-world ;
|
||||
|
||||
: restore-windows ( -- )
|
||||
windows get [ 1 <column> >array ] keep delete-all
|
||||
[ dup reset-world open-window* ] each
|
||||
forget-rollover ;
|
||||
|
||||
: restore-windows? ( -- ? )
|
||||
windows get [ empty? not ] [ f ] if* ;
|
||||
|
||||
: <toolbar> ( target classes -- toolbar )
|
||||
[ commands "toolbar" swap hash ] map concat
|
||||
[ <command-button> ] map-with
|
||||
make-shelf ;
|
||||
|
||||
: command-description ( command -- element )
|
||||
dup command-name swap command-gesture gesture>string
|
||||
2array ;
|
||||
|
||||
: commands. ( commands -- )
|
||||
[ command-gesture key-down? ] subset
|
||||
[ command-description ] map
|
||||
{ { $strong "Command" } { $strong "Shortcut" } } add*
|
||||
$table ;
|
||||
|
||||
: $commands ( elt -- )
|
||||
first2 swap commands hash commands. ;
|
||||
|
||||
TUPLE: labelled-gadget content ;
|
||||
|
||||
C: labelled-gadget ( gadget title -- gadget )
|
||||
{
|
||||
{ [ <label> dup reverse-video-theme ] f f @top }
|
||||
{ f set-labelled-gadget-content f @center }
|
||||
} make-frame* ;
|
||||
|
||||
M: labelled-gadget focusable-child* labelled-gadget-content ;
|
||||
|
||||
: <labelled-pane> ( model quot title -- gadget )
|
||||
>r <pane-control> t over set-pane-scrolls? <scroller> r>
|
||||
<labelled-gadget> ;
|
||||
|
||||
: <close-box> ( quot -- button/f )
|
||||
gray close-box <polygon-gadget> swap <bevel-button> ;
|
||||
|
||||
: <title-label> <label> dup title-theme ;
|
||||
|
||||
: <title-bar> ( title quot -- gadget )
|
||||
[
|
||||
{
|
||||
{ [ <close-box> ] f f @left }
|
||||
{ [ <title-label> ] f f @center }
|
||||
} make-frame
|
||||
] [
|
||||
<title-label>
|
||||
] if* ;
|
||||
|
||||
TUPLE: closable-gadget content ;
|
||||
|
||||
C: closable-gadget ( gadget title quot -- gadget )
|
||||
{
|
||||
{ [ <title-bar> ] f f @top }
|
||||
{ f set-closable-gadget-content f @center }
|
||||
} make-frame* ;
|
||||
|
||||
M: closable-gadget focusable-child* closable-gadget-content ;
|
||||
|
||||
: pane-window ( quot title -- )
|
||||
>r make-pane <scroller> r> open-titled-window ;
|
||||
|
||||
: error-window ( error -- )
|
||||
[ print-error ] "Error" pane-window ;
|
||||
|
||||
: ui-try ( quot -- )
|
||||
[ error-window ] recover ;
|
||||
|
||||
TUPLE: world-error world ;
|
||||
|
||||
C: world-error ( error world -- error )
|
||||
|
|
@ -208,7 +61,7 @@ M: world-error error.
|
|||
dup world set [
|
||||
dup (draw-world)
|
||||
] [
|
||||
over <world-error> error-window
|
||||
over <world-error> debugger-window
|
||||
f over set-world-active?
|
||||
] recover
|
||||
] with-scope
|
||||
|
|
|
|||
|
|
@ -0,0 +1,87 @@
|
|||
! Copyright (C) 2006 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: gadgets
|
||||
USING: arrays errors gadgets generic hashtables io kernel math
|
||||
models namespaces prettyprint sequences test threads
|
||||
sequences words timers ;
|
||||
|
||||
! Assoc mapping aliens to gadgets
|
||||
SYMBOL: windows
|
||||
|
||||
: window ( handle -- world ) windows get-global assoc ;
|
||||
|
||||
: window-focus ( handle -- gadget ) window world-focus ;
|
||||
|
||||
: register-window ( world handle -- )
|
||||
swap 2array windows get-global push ;
|
||||
|
||||
: unregister-window ( handle -- )
|
||||
windows get-global
|
||||
[ first = not ] subset-with
|
||||
windows set-global ;
|
||||
|
||||
: raised-window ( world -- )
|
||||
windows get-global [ second eq? ] find-with drop
|
||||
windows get-global [ length 1- ] keep exchange ;
|
||||
|
||||
TUPLE: titled-gadget title child ;
|
||||
|
||||
M: titled-gadget gadget-title titled-gadget-title ;
|
||||
|
||||
M: titled-gadget focusable-child* titled-gadget-child ;
|
||||
|
||||
C: titled-gadget ( gadget title -- )
|
||||
[ set-titled-gadget-title ] keep
|
||||
{ { f set-titled-gadget-child f @center } } make-frame* ;
|
||||
|
||||
: open-window ( world -- )
|
||||
dup pref-dim over set-gadget-dim
|
||||
dup open-window* draw-world ;
|
||||
|
||||
: open-titled-window ( gadget title -- )
|
||||
<model> <titled-gadget> <world> open-window ;
|
||||
|
||||
: find-window ( quot -- world )
|
||||
windows get 1 <column>
|
||||
[ world-gadget swap call ] find-last-with nip ; inline
|
||||
|
||||
: start-world ( world -- )
|
||||
dup graft
|
||||
dup relayout
|
||||
world-gadget request-focus ;
|
||||
|
||||
: close-global ( world global -- )
|
||||
dup get-global find-world rot eq?
|
||||
[ f swap set-global ] [ drop ] if ;
|
||||
|
||||
: focus-world ( world -- )
|
||||
#! Sent when native window receives focus
|
||||
t over set-world-focused?
|
||||
dup raised-window
|
||||
focused-ancestors f focus-gestures ;
|
||||
|
||||
: unfocus-world ( world -- )
|
||||
#! Sent when native window loses focus.
|
||||
f over set-world-focused?
|
||||
focused-ancestors f swap focus-gestures ;
|
||||
|
||||
: reset-world ( world -- )
|
||||
dup world-fonts clear-hash
|
||||
dup unfocus-world
|
||||
f over set-world-focus
|
||||
f over set-world-handle
|
||||
ungraft ;
|
||||
|
||||
: close-world ( world -- )
|
||||
dup hand-clicked close-global
|
||||
dup hand-gadget close-global
|
||||
dup free-fonts
|
||||
reset-world ;
|
||||
|
||||
: restore-windows ( -- )
|
||||
windows get [ 1 <column> >array ] keep delete-all
|
||||
[ dup reset-world open-window* ] each
|
||||
forget-rollover ;
|
||||
|
||||
: restore-windows? ( -- ? )
|
||||
windows get [ empty? not ] [ f ] if* ;
|
||||
Loading…
Reference in New Issue