Workspace improvements

TODO.FACTOR.txt

@@ -4,12 +4,10 @@
   space
 - workspace:
   - tool help
-  - maybe open-window should take a world
-  - book: request focus on selected gadget
-  - each workspace page has a toolbar
   - selecting walker when no quotation is being walked throws an error
   - replacement for call-tool functionality
   - status bar showing number of words needing a recompile
+  - default size is wrong
 - new browser:
   - show currently selected vocab & words
   - scroll to existing won't work

library/ui/cocoa/menu-bar.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Kevin Reid.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: cocoa compiler gadgets gadgets-browser gadgets-help
+USING: cocoa compiler gadgets gadgets-workspace gadgets-help
-gadgets-listener gadgets-search kernel memory objc objc-classes
+gadgets-listener kernel memory objc objc-classes sequences
-sequences strings words io ;
+strings words io help ;
 IN: cocoa
 
 ! -------------------------------------------------------------------------
@@ -91,9 +91,6 @@ DEFER: described-menu
 : menu-run-file ( -- )
     open-panel [ listener-run-files ] when* ;
 
-: memory-window ( -- )
-    [ heap-stats. terpri room. ] "Memory" pane-window ;
-
 : default-main-menu 
     {
         "<top>"
@@ -113,15 +110,9 @@ DEFER: described-menu
         } [ NSApp over -> setAppleMenu: ] }
         { {
             "File"
-            { "New Listener" listener-window "n" }
+            { "New Workspace" workspace-window "n" }
-            { "New Browser" browser-window "b" }
-            { "Apropos" apropos-window "r" }
-            { }
             { "Run..." menu-run-file "o" }
             { }
-            { "Globals" globals-window "" }
-            { "Memory" memory-window "" }
-            { }
             { "Save Image" save "s" }
         } }
         { {
@@ -147,7 +138,6 @@ DEFER: described-menu
         } [ NSApp over -> setWindowsMenu: ] }
         { {
             "Help"
-            { "Factor Documentation" handbook-window "?" }
+            { "Factor Documentation" [ "handbook" <link> help-tool call-tool ] "?" }
-            { "Search" search-help-window "" }
         } }
     } described-menu set-main-menu ;

library/ui/cocoa/ui.factor

@@ -4,8 +4,8 @@ IN: objc-classes
 DEFER: FactorApplicationDelegate
 
 IN: cocoa
-USING: arrays gadgets gadgets-listener hashtables kernel memory
+USING: arrays gadgets gadgets-listener gadgets-workspace
-namespaces objc sequences errors freetype ;
+hashtables kernel memory namespaces objc sequences errors freetype ;
 
 : finder-run-files ( alien -- )
     #! We filter out the image name since that might be there on
@@ -76,7 +76,7 @@ IN: shells
                 restore-windows
             ] [
                 init-ui
-                listener-window
+                workspace-window
             ] if
             finish-launching
             event-loop

library/ui/gadgets/books.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-books
 USING: gadgets gadgets-controls gadgets-panes gadgets-scrolling
-kernel sequences ;
+kernel sequences models ;
 
 TUPLE: book page pages ;
 
@@ -10,21 +10,25 @@ TUPLE: book page pages ;
     #! page gadgets are instantiated lazily.
     book-pages [ dup quotation? [ call ] when dup ] change-nth ;
 
-: show-page ( n book -- )
+M: book model-changed ( book -- )
-    dup book-page unparent
+    [ control-model model-value ] keep
+    [ book-page unparent ] keep
     [ get-page ] keep
     [ set-book-page ] 2keep
-    add-gadget ;
+    [ add-gadget ] keep
+    dup request-focus ;
 
 C: book ( pages -- book )
-    dup delegate>gadget
+    dup 0 <model> delegate>control
+    dup dup set-control-self
     [ set-book-pages ] keep
-    0 over show-page ;
+    dup model-changed ;
-
-: <book-control> ( model pages -- book )
-    <book> [ show-page ] <control> ;
 
 M: book pref-dim* book-page pref-dim ;
 
 M: book layout*
     dup rect-dim swap book-page set-layout-dim ;
+
+M: book gadget-title book-page gadget-title ;
+
+M: book focusable-child* gadget-child ;

library/ui/gadgets/grids.factor

@@ -23,9 +23,11 @@ C: grid ( children -- grid )
 : grid-remove ( grid i j -- )
     >r >r >r f r> r> r> grid-add ;
 
+: ?pref-dim ( gadget/f -- dim )
+    [ pref-dim ] [ { 0 0 } ] if* ;
+
 : pref-dim-grid ( -- dims )
-    grid get grid-children
+    grid get grid-children [ [ ?pref-dim ] map ] map ;
-    [ [ [ pref-dim ] [ { 0 0 } ] if* ] map ] map ;
 
 : compute-grid ( -- horiz vert )
     pref-dim-grid

library/ui/gestures.factor

@@ -128,7 +128,8 @@ V{ } clone hand-buttons set-global
     focus-receiver r> focus-gestures ;
 
 : request-focus ( gadget -- )
-    dup focusable-child swap find-world request-focus* ;
+    dup focusable-child swap find-world
+    [ request-focus* ] [ drop ] if* ;
 
 : modifier ( mod modifiers -- seq )
     [ second swap bitand 0 > ] subset-with

library/ui/tools/browser.factor

@@ -73,8 +73,6 @@ C: browser ( -- gadget )
 
 M: browser gadget-title drop "Browser" <model> ;
 
-: browser-window ( -- ) <browser> open-window ;
-
 : show-word ( word browser -- )
     over word-vocabulary over show-vocab
     browser-definitions show-definition ;

library/ui/tools/help.factor

@@ -25,7 +25,6 @@ help-gadget {
 C: help-gadget ( -- gadget )
     T{ link f "handbook" } <history>
     over set-help-gadget-history {
-        { [ gadget get <toolbar> ] f f @top }
         { [ <help-pane> <scroller> ] f f @center }
     } make-frame* ;
 
@@ -33,11 +32,6 @@ M: help-gadget gadget-title
     help-gadget-history
     [ "Help - " swap article-title append ] <filter> ;
 
-M: help-gadget pref-dim* drop { 500 600 } ;
-
 : help-tool [ help-gadget? ] [ <help-gadget> ] [ show-help ] ;
 
-: handbook-window ( -- )
-    T{ link f "handbook" } help-tool call-tool ;
-
 link 1 "Browse" [ help-tool call-tool ] define-operation

library/ui/tools/listener.factor

@@ -6,7 +6,7 @@ gadgets-panes gadgets-scrolling
 gadgets-text gadgets-theme gadgets-tiles gadgets-tracks generic
 hashtables inspector io kernel listener math models
 namespaces parser prettyprint sequences shells styles threads
-words ;
+words memory ;
 
 TUPLE: listener-gadget input output stack ;
 
@@ -48,16 +48,11 @@ C: listener-gadget ( -- gadget )
         { [ <listener-input> ] set-listener-gadget-input [ <scroller> ] 1/6 }
     } { 0 1 } make-track* dup start-listener ;
 
-M: listener-gadget pref-dim*
-    delegate pref-dim* { 500 600 } vmax ;
-
 M: listener-gadget focusable-child*
     listener-gadget-input ;
 
 M: listener-gadget gadget-title drop "Listener" <model> ;
 
-: listener-window ( -- ) <listener-gadget> open-window ;
-
 : call-listener ( quot/string listener -- )
     listener-gadget-input over quotation?
     [ interactor-call ] [ set-editor-text ] if ;
@@ -81,11 +76,10 @@ M: listener-gadget gadget-title drop "Listener" <model> ;
         [ [ run-file ] each ] curry listener-tool call-tool
     ] if ;
 
-: globals-window ( -- )
-    [ global inspect ] listener-tool call-tool ;
-
 listener-gadget {
     { f "Clear" T{ key-down f f "CLEAR" } [ dup [ listener-gadget-output pane-clear ] curry listener-tool call-tool ] }
+    { f "Globals" f [ [ global inspect ] listener-tool call-tool ] }
+    { f "Memory" f [ [ heap-stats. room. ] listener-tool call-tool ] }
 } define-commands
 
 object 1 "Inspect" [ [ inspect ] curry listener-tool call-tool ] define-operation

library/ui/tools/walker.factor

@@ -33,16 +33,6 @@ namespaces sequences shells threads vectors ;
 : <quotation-display> ( quot -- gadget )
     [ [ first2 callframe. ] when* ] <pane-control> <scroller> ;
 
-: <walker-track> ( model quot -- gadget )
-    {
-        { [ <quotation-display> ] f f 1/6 }
-        { [ dup <callstack-display> ] f f 1/6 }
-        { [ dup <datastack-display> ] f f 1/6 }
-        { [ dup <retainstack-display> ] f f 1/6 }
-        { [ dup <namestack-display> ] f f 1/6 }
-        { [ <catchstack-display> ] f f 1/6 }
-    } { 0 1 } make-track ;
-
 TUPLE: walker-gadget model quot ns ;
 
 : update-stacks ( walker -- )
@@ -67,20 +57,13 @@ walker-gadget {
     { f "Continue" T{ key-down f f "c" } [ walker-step-all ] }
 } define-commands
 
-: init-walker-models ( walker -- )
+: init-walker-models ( walker -- model quot )
-    f <model> over set-walker-gadget-model
+    f <model> over set-walker-gadget-quot
-    f <model> swap set-walker-gadget-quot ;
+    f <model> swap set-walker-gadget-model ;
-
-: walker-models ( -- model quot )
-    gadget get walker-gadget-model
-    gadget get walker-gadget-quot ;
 
 M: walker-gadget gadget-title
     drop "Single stepper" <model> ;
 
-M: walker-gadget pref-dim*
-    delegate pref-dim { 500 600 } vmax ;
-
 : (walk) ( quot continuation walker -- )
     H{ } clone over set-walker-gadget-ns [
         V{ } clone meta-history set
@@ -88,12 +71,19 @@ M: walker-gadget pref-dim*
         (meta-call)
     ] with-walker ;
 
+: walker-gadget-quot$ gadget get walker-gadget-quot ;
+: walker-gadget-model$ gadget get walker-gadget-model ;
+
 C: walker-gadget ( -- gadget )
     dup init-walker-models {
-        { [ gadget get <toolbar> ] f f @top }
+        { [ walker-gadget-quot$ <quotation-display> ] f f 1/6 }
-        { [ walker-models <walker-track> ] f f @center }
+        { [ walker-gadget-model$ <callstack-display> ] f f 1/6 }
-    } make-frame* ;
+        { [ walker-gadget-model$ <datastack-display> ] f f 1/6 }
+        { [ walker-gadget-model$ <retainstack-display> ] f f 1/6 }
+        { [ walker-gadget-model$ <namestack-display> ] f f 1/6 }
+        { [ walker-gadget-model$ <catchstack-display> ] f f 1/6 }
+    } { 0 1 } make-track* ;
 
 : walk ( quot -- )
     continuation dup continuation-data pop*
-    <walker-gadget> [ (walk) ] keep open-window stop ;
+    <walker-gadget> [ (walk) ] keep <world> open-window stop ;

library/ui/tools/workspace.factor

@@ -3,8 +3,20 @@
 IN: gadgets-workspace
 USING: arrays gadgets gadgets-listener gadgets-buttons
 gadgets-walker gadgets-help gadgets-walker sequences
-gadgets-browser gadgets-books gadgets-frames kernel models
+gadgets-browser gadgets-books gadgets-frames gadgets-controls
-namespaces ;
+gadgets-grids gadgets-presentations kernel models namespaces ;
+
+TUPLE: tool ;
+
+C: tool ( gadget -- tool )
+    {
+        { [ dup <toolbar> ] f f @top }
+        { [ ] f f @center }
+    } make-frame* ;
+
+M: tool gadget-title gadget-child gadget-title ;
+
+M: tool focusable-child* gadget-child ;
 
 TUPLE: workspace model ;
 
@@ -16,17 +28,22 @@ TUPLE: workspace model ;
         { "Documentation" help-gadget [ <help-gadget> ] }
     } ;
 
-: <workspace-book> ( workspace -- book )
+: <workspace> ( -- book )
-    workspace-model
+    workspace-tabs [ third [ <tool> ] append ] map <book> ;
-    workspace-tabs [ third ] map <book-control> ;
 
-: <workspace-tabs> ( workspace -- tabs )
+: <workspace-tabs> ( book -- tabs )
-    workspace-model
+    control-model
     workspace-tabs dup length [ swap first 2array ] 2map
     <radio-box> ;
 
-C: workspace
+: init-status ( world -- )
-    0 <model> over set-workspace-model {
+    dup world-status <presentation-help> swap @bottom grid-add ;
-        { [ gadget get <workspace-tabs> ] f f @top }
+
-        { [ gadget get <workspace-book> ] f f @center }
+: init-tabs ( workspace world -- )
-    } make-frame* ;
+    swap <workspace-tabs> swap @top grid-add ;
+
+: workspace-window ( -- )
+    <workspace> dup <world>
+    [ init-status ] keep
+    [ init-tabs ] keep
+    open-window ;

library/ui/ui.factor

@@ -69,24 +69,19 @@ C: titled-gadget ( gadget title -- )
     [ set-titled-gadget-title ] keep
     { { f f f @center } } make-frame* ;
 
-: init-status ( world -- )
+: open-window ( world -- )
-    dup world-status <presentation-help> swap @bottom grid-add ;
-
-: open-window ( gadget -- )
-    <world> dup init-status
     dup pref-dim over set-gadget-dim
-    dup open-window*
+    dup open-window* draw-world ;
-    draw-world ;
 
 : open-titled-window ( gadget title -- )
-    <model> <titled-gadget> open-window ;
+    <model> <titled-gadget> <world> open-window ;
 
 : find-window ( quot -- world )
     windows get [ second ] map
     [ world-gadget swap call ] find-last-with nip ; inline
 
 : open-tool ( arg cons setter -- )
-    >r call dup open-window r> call ; inline
+    >r call dup <world> open-window r> call ; inline
 
 : call-tool ( arg pred cons setter -- )
     rot find-window [

library/ui/windows/ui.factor

@@ -328,7 +328,7 @@ IN: shells
                 restore-windows
             ] [
                 init-ui
-                listener-window
+                workspace-window
             ] if
             event-loop
         ] with-freetype

library/ui/x11/ui.factor

@@ -184,7 +184,7 @@ IN: shells
                 restore-windows
             ] [
                 init-ui
-                listener-window
+                workspace-window
             ] if
             event-loop
         ] with-x