Split up ui.factor, and other cleanups

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
+- 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

core/ui/commands.factor

@@ -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. ;

core/ui/debugger.factor

@@ -1,9 +1,14 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-IN: gadgets-debugger
+IN: gadgets-listener
-USING: errors sequences gadgets gadgets-buttons gadgets-listener
+DEFER: call-listener
-gadgets-panes gadgets-lists gadgets-scrolling gadgets-theme
+
-kernel models arrays namespaces ;
+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 ;

core/ui/gadgets/labelled-gadget.factor

@@ -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 ;

core/ui/gadgets/presentations.factor

@@ -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 ;

core/ui/load.factor

@@ -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"

core/ui/tools/workspace.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-listener gadgets-presentations gadgets-walker generic
-gadgets-debugger generic kernel math modules scratchpad
+kernel math modules scratchpad sequences syntax words io
-sequences syntax words io namespaces hashtables
+namespaces hashtables gadgets-scrolling gadgets-panes
-gadgets-scrolling gadgets-panes gadgets-messages gadgets-theme
+gadgets-messages gadgets-theme errors ;
-errors ;
 
 C: tool ( gadget -- tool )
     {

core/ui/ui.factor

@@ -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
+gadgets-scrolling gadgets-theme gadgets-viewports gadgets-lists
-hashtables io kernel math models namespaces prettyprint queues
+generic hashtables io kernel math models namespaces prettyprint
-sequences test threads help sequences words timers ;
+queues 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 ;
 
 : 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

core/ui/windows.factor

@@ -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* ;