Working on tool help

TODO.FACTOR.txt

@@ -25,12 +25,11 @@
 - the editor should fill up the interior of the scroller completely
 - doc sweep
 - tool help
-- perhaps commands window should sort by gesture
-- merge keyboard help with help in some way
 - keyboard help: hide commands whose gestures are shadowed
 
 + ui:
 
+- reliably clonable gadgets
 - figure out if we need both set-model and set-model*
 - help tool: edit, reload buttons
 - words:

doc/handbook/handbook.facts

@@ -43,6 +43,8 @@ ARTICLE: "handbook" "Factor documentation"
 { $subsection "help" }
 { $subsection "inference" }
 { $subsection "compiler" }
+{ $heading "Graphical user interface" }
+{ $subsection "ui-tools" }
 { $heading "Index" }
 { $subsection "article-index" }
 { $subsection "primitive-index" }

doc/handbook/load.factor

@@ -20,4 +20,5 @@ PROVIDE: doc/handbook {
     "syntax.facts"
     "tools.facts"
     "words.facts"
+    "ui/tools.facts"
 } ;

doc/handbook/ui/tools.facts

@@ -0,0 +1,43 @@
+USING: gadgets gadgets-listener gadgets-browser gadgets-help
+gadgets-walker gadgets-dataflow gadgets-workspace help
+gadgets-panes gadgets-text listener ;
+
+ARTICLE: "ui-listener" "UI listener"
+"The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds an input history and clickable output presentations (" { $link "styles" } ")."
+$terpri
+"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } "), an input area (instance of " { $link interactor } "), and a stack display kept up to date using a " { $link listener-hook } "."
+$terpri
+"The word commands appearing in the below list operate on the token at the caret position in the input area. The quotation commands operate on the entire contents of the input area. The walker and dataflow tools are invoked using these commands."
+{ $commands listener-gadget }
+;
+
+ARTICLE: "ui-browser" "UI definition browser"
+"Definition browsers are instances of " { $link browser } "."
+{ $commands browser }
+;
+
+ARTICLE: "ui-help" "UI documentation browser"
+"Documentation browsers are instances of " { $link help-gadget } "."
+{ $commands help-gadget }
+;
+
+ARTICLE: "ui-walker" "UI walker"
+"Walkers are instances of " { $link walker-gadget } "."
+{ $commands walker-gadget }
+;
+
+ARTICLE: "ui-dataflow" "UI dataflow tool"
+"Dataflow viewers are instances of " { $link dataflow-gadget } "."
+{ $commands dataflow-gadget }
+;
+
+ARTICLE: "ui-tools" "Development tools in the UI"
+"UI development tools are integrated into a single-window " { $emphasis "workspace" } ". Multiple workspaces can be open at once, and keyboard commands are provided for switching between tools."
+$terpri
+"Workspaces are instances of " { $link workspace-window } "."
+{ $commands workspace }
+{ $subsection "ui-listener" }
+{ $subsection "ui-browser" }
+{ $subsection "ui-help" }
+{ $subsection "ui-walker" }
+{ $subsection "ui-dataflow" } ;

library/ui/commands.factor

@@ -54,16 +54,10 @@ M: object gesture>string drop f ;
 : define-commands ( class specs -- )
     [ <commands> ] map concat define-commands* ;
 
-: commands ( gadget -- seq )
+: commands ( class -- seq ) "commands" word-prop ;
-    delegates [ class "commands" word-prop ] map concat ;
 
-: all-commands ( gadget -- assoc )
+: all-commands ( gadget -- seq )
-    [
+    delegates [ class commands ] map concat ;
-        parents [
-            dup commands [ set ] each-with
-        ] each
-    ] make-hash
-    hash>alist [ [ first command-name ] 2apply <=> ] sort ;
 
 : resend-button-down ( gesture world -- )
     hand-loc get-global swap send-button-down ;

library/ui/text/commands.factor

@@ -68,7 +68,7 @@ sequences ;
 
 editor {
     {
-        "Editing"
+        "Editing commands"
         { "Insert newline" T{ key-down f f "RETURN" } [ "\n" swap user-input ] }
         { "Insert newline" T{ key-down f { S+ } "RETURN" } [ "\n" swap user-input ] }
         { "Insert newline" T{ key-down f f "ENTER" } [ "\n" swap user-input ] }
@@ -81,7 +81,7 @@ editor {
     }
     
     {
-        "Clipboard"
+        "Clipboard commands"
         { "Paste" T{ paste-action } [ clipboard get paste-clipboard ] }
         { "Paste selection" T{ button-up f f 2 } [ selection get paste-clipboard ] }
         { "Copy" T{ copy-action } [ clipboard get editor-copy ] }
@@ -90,7 +90,7 @@ editor {
     }
 
     {
-        "Moving caret"
+        "Caret motion commands"
         { "Position caret" T{ button-down } [ editor-mouse-down ] }
         { "Previous character" T{ key-down f f "LEFT" } [ T{ char-elt } editor-prev ] }
         { "Next character" T{ key-down f f "RIGHT" } [ T{ char-elt } editor-next ] }
@@ -105,7 +105,7 @@ editor {
     }
     
     {
-        "Selecting text"
+        "Text selection commands"
         { "Extend selection" T{ button-down f { S+ } } [ editor-extend-selection ] }
         { "Start selection" T{ drag } [ editor-mouse-drag ] }
         { "Focus editor" T{ gain-focus } [ focus-editor ] }

library/ui/text/field.factor

@@ -18,7 +18,7 @@ C: field ( model -- field )
 
 field {
     {
-        "Editing"
+        "Editing commands"
         { "Clear input" T{ key-down f { C+ } "k" } [ control-model clear-doc ] }
         { "Accept input" T{ key-down f f "RETURN" } [ field-commit drop ] }
     }

library/ui/text/interactor.factor

@@ -52,14 +52,15 @@ SYMBOL: structured-input
         [ field-commit ] keep interactor-eval
     ] if ;
 
-: interactor-history. ( -- )
-    stdio get dup duplex-stream-out [
-        duplex-stream-in interactor-history
-        [ dup print-input ] each
-    ] with-stream* ;
-
 M: interactor stream-readln
     dup interactor-queue empty? [
         f over set-interactor-busy?
         [ over set-interactor-continuation stop ] callcc0
     ] when interactor-queue pop ;
+
+interactor {
+    {
+        "Editing commands"
+        { "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] }
+    }
+} define-commands

library/ui/tools/browser.factor

@@ -101,7 +101,7 @@ M: browser focusable-child* browser-search ;
 
 browser {
     {
-        "Browser"
+        "Browser commands"
         { "Clear" T{ key-down f f "CLEAR" } [ clear-browser ] }
     }
 } define-commands

library/ui/tools/dataflow.factor

@@ -190,7 +190,7 @@ TUPLE: dataflow-gadget history search ;
 
 dataflow-gadget {
     {
-        "Dataflow"
+        "Dataflow commands"
         { "Back" T{ key-down f { C+ } "b" } [ dataflow-gadget-history go-back ] }
         { "Forward" T{ key-down f { C+ } "f" } [ dataflow-gadget-history go-forward ] }
     }

library/ui/tools/help.factor

@@ -13,15 +13,6 @@ TUPLE: help-gadget history search ;
 
 : go-home ( help -- ) "handbook" swap show-help ;
 
-help-gadget {
-    {
-        "Help"
-        { "Back" T{ key-down f { C+ } "b" } [ help-gadget-history go-back ] }
-        { "Forward" T{ key-down f { C+ } "f" } [ help-gadget-history go-forward ] }
-        { "Home" T{ key-down f { C+ } "h" } [ go-home ] }
-    }
-} define-commands
-
 : <help-pane> ( history -- gadget )
     gadget get help-gadget-history [ help ] <pane-control> ;
 

library/ui/tools/listener.factor

@@ -61,9 +61,6 @@ M: listener-gadget focusable-child*
         drop f
     ] if ;
 
-: clear-output ( -- )
-    stdio get duplex-stream-out pane-clear ;
-
 G: call-listener ( quot/string listener -- )
     1 standard-combination ;
 
@@ -85,3 +82,23 @@ M: listener-gadget call-tool* ( quot/string listener -- )
     ] [
         [ [ run-file ] each ] curry listener-gadget call-tool
     ] if ;
+
+: listener-eof ( listener -- )
+    listener-gadget-input f swap interactor-eval ;
+
+: (listener-history) ( listener -- )
+    dup listener-gadget-output [
+        listener-gadget-input interactor-history
+        [ dup print-input ] each
+    ] with-stream* ;
+
+: listener-history ( listener -- )
+    [ [ (listener-history) ] curry ] keep
+    call-listener ;
+
+: clear-listener-output ( listener -- )
+    [ listener-gadget-output [ pane-clear ] curry ] keep
+    call-listener ;
+
+: clear-listener-stack ( listener -- )
+    [ clear ] swap call-listener ;

library/ui/tools/operations.factor

@@ -5,7 +5,7 @@ USING: definitions gadgets gadgets-browser gadgets-dataflow
 gadgets-help gadgets-listener gadgets-text gadgets-workspace
 hashtables help inference kernel namespaces parser prettyprint
 scratchpad sequences strings styles syntax test tools words
-generic ;
+generic models ;
 
 V{ } clone operations set-global
 
@@ -49,7 +49,7 @@ M: operation invoke-command ( target operation -- )
 ! Words
 [ word? ] H{
     { +button+ 1 }
-    { +group+ "Words" }
+    { +group+ "Word commands" }
     { +name+ "Browse" }
     { +gesture+ T{ key-down f { A+ } "b" } }
     { +quot+ [ browser call-tool ] }
@@ -57,7 +57,7 @@ M: operation invoke-command ( target operation -- )
 
 [ word? ] H{
     { +button+ 2 }
-    { +group+ "Words" }
+    { +group+ "Word commands" }
     { +name+ "Edit" }
     { +gesture+ T{ key-down f { A+ } "e" } }
     { +quot+ [ edit ] }
@@ -65,14 +65,14 @@ M: operation invoke-command ( target operation -- )
 
 [ word? ] H{
     { +button+ 3 }
-    { +group+ "Words" }
+    { +group+ "Word commands" }
     { +name+ "Documentation" }
     { +gesture+ T{ key-down f { A+ } "h" } }
     { +quot+ [ help-gadget call-tool ] }
 } define-operation
 
 [ word? ] H{
-    { +group+ "Words" }
+    { +group+ "Word commands" }
     { +name+ "Usage" }
     { +gesture+ T{ key-down f { A+ } "u" } }
     { +quot+ [ usage. ] }
@@ -80,7 +80,7 @@ M: operation invoke-command ( target operation -- )
 } define-operation
 
 [ word? ] H{
-    { +group+ "Words" }
+    { +group+ "Word commands" }
     { +name+ "Reload" }
     { +gesture+ T{ key-down f { A+ } "r" } }
     { +quot+ [ reload ] }
@@ -88,7 +88,7 @@ M: operation invoke-command ( target operation -- )
 } define-operation
 
 [ word? ] H{
-    { +group+ "Words" }
+    { +group+ "Word commands" }
     { +name+ "Watch" }
     { +quot+ [ watch ] }
     { +listener+ t }
@@ -122,7 +122,7 @@ M: operation invoke-command ( target operation -- )
 
 ! Strings
 [ string? ] H{
-    { +group+ "Words" }
+    { +group+ "Word commands" }
     { +name+ "Apropos (all)" }
     { +gesture+ T{ key-down f { A+ } "a" } }
     { +quot+ [ apropos ] }
@@ -135,7 +135,7 @@ M: operation invoke-command ( target operation -- )
     ] make-hash hash-values natural-sort ;
 
 [ string? ] H{
-    { +group+ "Words" }
+    { +group+ "Word commands" }
     { +name+ "Apropos (used)" }
     { +gesture+ T{ key-down f f "TAB" } }
     { +quot+ [ usable-words (apropos) ] }
@@ -144,7 +144,7 @@ M: operation invoke-command ( target operation -- )
 
 ! Quotations
 [ quotation? ] H{
-    { +group+ "Quotations" }
+    { +group+ "Quotation commands" }
     { +name+ "Infer" }
     { +gesture+ T{ key-down f { C+ A+ } "i" } }
     { +quot+ [ infer . ] }
@@ -152,7 +152,7 @@ M: operation invoke-command ( target operation -- )
 } define-operation
 
 [ quotation? ] H{
-    { +group+ "Quotations" }
+    { +group+ "Quotation commands" }
     { +name+ "Dataflow" }
     { +gesture+ T{ key-down f { C+ A+ } "d" } }
     { +quot+ [ show-dataflow ] }
@@ -160,7 +160,7 @@ M: operation invoke-command ( target operation -- )
 } define-operation
 
 [ quotation? ] H{
-    { +group+ "Quotations" }
+    { +group+ "Quotation commands" }
     { +name+ "Walk" }
     { +gesture+ T{ key-down f { C+ A+ } "w" } }
     { +quot+ [ walk ] }
@@ -168,7 +168,7 @@ M: operation invoke-command ( target operation -- )
 } define-operation
 
 [ quotation? ] H{
-    { +group+ "Quotations" }
+    { +group+ "Quotation commands" }
     { +name+ "Time" }
     { +gesture+ T{ key-down f { C+ A+ } "t" } }
     { +quot+ [ time ] }
@@ -177,7 +177,7 @@ M: operation invoke-command ( target operation -- )
 
 ! Dataflow nodes
 [ word? ] H{
-    { +group+ "Words" }
+    { +group+ "Word commands" }
     { +name+ "Word dataflow" }
     { +gesture+ T{ key-down f { A+ } "d" } }
     { +quot+ [ word-def show-dataflow ] }
@@ -185,7 +185,6 @@ M: operation invoke-command ( target operation -- )
 
 [ [ node? ] is? ] H{
     { +button+ 1 }
-    { +group+ "Nodes" }
     { +name+ "Quotation dataflow" }
     { +quot+ [ dataflow-gadget call-tool ] }
 } define-operation
@@ -200,32 +199,44 @@ T{ command f f "Close" f [ close-tile ] } add*
 define-commands*
 
 ! Interactor commands
+
+! Listener commands
 : selected-word ( editor -- string )
     dup gadget-selection?
     [ dup T{ word-elt } select-elt ] unless
     gadget-selection ;
 
+: listener-selected-word ( listener -- string )
+    listener-gadget-input selected-word ;
+
 : word-action ( target -- quot )
-    selected-word search ;
+    listener-selected-word search ;
 
 : quot-action ( quot -- quot )
-    field-commit parse ;
+    listener-gadget-input field-commit parse ;
 
-interactor [
+listener-gadget [
     {
-        "Listener"
+        "Listener commands"
-        { "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] }
+        { "Send EOF" T{ key-down f { C+ } "d" } [ listener-eof ] }
-        { "Send EOF" T{ key-down f { C+ } "d" } [ f swap interactor-eval ] }
+        { "History" T{ key-down f { C+ } "h" } [ listener-history ] }
+        { "Clear output" T{ key-down f f "CLEAR" } [ clear-listener-output ] }
+        { "Clear stack" T{ key-down f { C+ } "CLEAR" } [ clear-listener-stack ] }
     } <commands> %
 
     [ word-action ] \ word class-operations modify-listener-operations %
-    [ selected-word ] string class-operations modify-listener-operations %
+    [ listener-selected-word ] string class-operations modify-listener-operations %
     [ quot-action ] quotation class-operations modify-listener-operations %
-
+] { } make define-commands*
-    {
+
-        "Listener"
+help-gadget [
-        { "History" T{ key-down f { C+ } "h" } [ [ interactor-history. ] swap interactor-call ] }
+    {
-        { "Clear output" T{ key-down f f "CLEAR" } [ [ clear-output ] swap interactor-call ] }
+        "Help commands"
-        { "Clear stack" T{ key-down f { C+ } "CLEAR" } [ [ clear ] swap interactor-call ] }
+        { "Back" T{ key-down f { C+ } "b" } [ help-gadget-history go-back ] }
-    } <commands> %
+        { "Forward" T{ key-down f { C+ } "f" } [ help-gadget-history go-forward ] }
+        { "Home" T{ key-down f { C+ } "h" } [ go-home ] }
+    }
+    
+    [ help-gadget-history model-value ] link class-operations modify-listener-operations
+    [ command-name "Follow" = not ] subset %
 ] { } make define-commands*

library/ui/tools/walker.factor

@@ -77,7 +77,7 @@ M: walker-gadget call-tool* ( continuation walker -- )
 
 walker-gadget {
     {
-        "Walker"
+        "Walker commands"
         { "Step" T{ key-down f f "s" } [ walker-step ] }
         { "Step in" T{ key-down f f "i" } [ walker-step-in ] }
         { "Step out" T{ key-down f f "o" } [ walker-step-out ] }

library/ui/tools/workspace.factor

@@ -5,7 +5,7 @@ USING: arrays compiler gadgets gadgets-books gadgets-browser
 gadgets-buttons gadgets-controls gadgets-dataflow gadgets-frames
 gadgets-grids gadgets-help gadgets-listener
 gadgets-presentations gadgets-walker gadgets-workspace generic
-kernel math modules scratchpad sequences syntax words ;
+kernel math modules scratchpad sequences syntax words io ;
 
 C: tool ( gadget -- tool )
     {
@@ -49,15 +49,28 @@ M: workspace pref-dim* delegate pref-dim* { 550 650 } vmax ;
     [ init-tabs ] keep
     open-window ;
 
+: gadget-info. ( gadget -- )
+    "Gadget: " write
+    [ class word-name ] keep write-object terpri ;
+
+: keyboard-help ( gadget -- )
+    parents [
+        dup all-commands dup empty? [
+            2drop
+        ] [
+            swap gadget-info. commands.
+        ] if
+    ] each ;
+
 : commands-window ( workspace -- )
     dup find-world world-focus [ ] [ gadget-child ] ?if
-    [ commands. ] "Commands" pane-window ;
+    [ keyboard-help ] "Commands" pane-window ;
 
 : tool-window ( class -- ) workspace-window show-tool drop ;
 
 workspace {
     {
-        "Tools"
+        "Tool switching commands"
         { "Keyboard help" T{ key-down f f "F1" } [ commands-window ] }
         { "Listener" T{ key-down f f "F2" } [ listener-gadget select-tool ] }
         { "Definitions" T{ key-down f f "F3" } [ browser select-tool ] }
@@ -67,14 +80,14 @@ workspace {
     }
 
     {
-        "Tools in new window"
+        "Tool window commands"
         { "New listener" T{ key-down f { S+ } "F2" } [ listener-gadget tool-window drop ] }
         { "New definitions" T{ key-down f { S+ } "F3" } [ browser tool-window drop ] }
         { "New documentation" T{ key-down f { S+ } "F4" } [ help-gadget tool-window drop ] }
     }
     
     {
-        "Workflow"
+        "Workflow commands"
         { "Reload changed sources" T{ key-down f f "F7" } [ drop [ reload-modules ] listener-gadget call-tool ] }
         { "Recompile changed words" T{ key-down f f "F8" } [ drop [ recompile ] listener-gadget call-tool ] }
     }

library/ui/ui.factor

@@ -120,22 +120,17 @@ C: titled-gadget ( gadget title -- )
     windows get [ empty? not ] [ f ] if* ;
 
 : <toolbar> ( gadget -- toolbar )
-    dup commands [ <command-presentation> ] map-with
+    dup all-commands
+    [ <command-presentation> ] map-with
     make-shelf ;
 
-: $gadget ( element -- ) first gadget. ;
+: command-description ( command -- element )
-
+    dup command-name swap command-gesture gesture>string
-: command-description ( target command -- element )
+    2array ;
-    [ <command-presentation> \ $gadget swap 2array ] keep
-    command-gesture gesture>string 2array ;
-
-: gadget-info ( gadget -- )
-    "Gadget: " write
-    [ class word-name ] keep write-object terpri ;
 
 : command-table. ( commands group -- )
     $heading
-    [ first2 swap command-description ] map
+    [ command-description ] map
     { "Command" "Gesture" } add* $table ;
 
 : push-hash ( elt key hash -- )
@@ -143,14 +138,16 @@ C: titled-gadget ( gadget title -- )
 
 : group-commands ( commands -- seq )
     H{ } clone swap
-    [ dup first command-group pick push-hash ] each
+    [ dup command-group pick push-hash ] each
     hash>alist [ [ first ] 2apply <=> ] sort ;
 
-: commands. ( gadget -- )
+: commands. ( seq -- )
-    dup gadget-info terpri
+    [ command-gesture key-down? ] subset
-    all-commands [ first command-gesture key-down? ] subset
     group-commands [ first2 swap command-table. ] each ;
 
+: $commands ( elt -- )
+    dup array? [ first ] when commands commands. ;
+
 : pane-window ( quot title -- )
     >r make-pane <scroller> r> open-titled-window ;