Add slot editing to UI inspector, remove slot editing from TTY inspector

basis/inspector/inspector-docs.factor

@@ -1,4 +1,5 @@
-USING: help.markup help.syntax kernel classes io io.styles mirrors ;
+USING: help.markup help.syntax kernel classes io io.styles mirrors
+inspector.private ;
 IN: inspector
 
 ARTICLE: "inspector" "The inspector"
@@ -16,23 +17,11 @@ $nl
 { $subsection &delete }
 "A variable holding the current object:"
 { $subsection me }
-"A variable holding inspector history:"
-{ $subsection inspector-stack }
-"A customization hook:"
-{ $subsection inspector-hook }
 "A description of an object can be printed without starting the inspector:"
-{ $subsection describe }
+{ $subsection describe } ;
-{ $subsection describe* } ;
 
 ABOUT: "inspector"
 
-HELP: value-editor
-{ $values { "path" "a sequence of keys" } }
-{ $description "Prettyprints the value at a path, and if the output stream supports it, a graphical gadget for editing the object." }
-{ $notes "To learn about paths, see " { $link "mirrors" } "." } ;
-
-{ presented-path presented-printer value-editor } related-words
-
 HELP: describe
 { $values { "obj" object } }
 { $description "Print a tabular overview of the object."
@@ -40,11 +29,6 @@ $nl
 "For sequences and hashtables, this outputs the entries of the collection. For all other object types, slot names and values are shown." }
 { $examples { $code "global describe" } } ;
 
-HELP: describe*
-{ $values { "obj" object } { "mirror" mirror } { "keys" "a sequence of objects" } }
-{ $description "Print a tabular overview of the object." }
-{ $notes "This word is a factor of " { $link describe } " and " { $link inspect } "." } ;
-
 HELP: inspector-stack
 { $var-description "If the inspector is running, this variable holds previously-inspected objects." } ;
 
@@ -91,8 +75,3 @@ HELP: &back
 
 HELP: me
 { $var-description "The currently inspected object." } ;
-
-HELP: inspector-hook
-{ $var-description "A quotation with stack effect " { $snippet "( obj -- )" } ", called by the inspector to display an overview of an object."
-$nl
-"The default implementation calls " { $link describe } " which outputs on " { $link output-stream } ", but the graphical listener sets this variable so that calling " { $link inspect } " in the UI opens the graphical inspector." } ;

basis/inspector/inspector-tests.factor

@@ -10,8 +10,6 @@ H{ } describe
 
 [ "fixnum instance\n" ] [ [ 3 describe ] with-string-writer ] unit-test
 
-[ ] [ inspector-hook get-global inspector-hook set ] unit-test
-
 [ ] [ H{ } clone inspect ] unit-test
 
 [ ] [ "a" "b" &add ] unit-test

basis/inspector/inspector.factor

@@ -1,64 +1,53 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic hashtables io kernel assocs math
-namespaces prettyprint sequences strings io.styles vectors words
+namespaces prettyprint prettyprint.custom prettyprint.sections
-quotations mirrors splitting math.parser classes vocabs refs
+sequences strings io.styles vectors words quotations mirrors
-sets sorting summary debugger continuations fry ;
+splitting math.parser classes vocabs sets sorting summary
+debugger continuations fry combinators ;
 IN: inspector
 
-: value-editor ( path -- )
-    [
-        [ pprint-short ] presented-printer set
-        dup presented-path set
-    ] H{ } make-assoc
-    [ get-ref pprint-short ] with-nesting ;
-
-SYMBOL: +sequence+
 SYMBOL: +number-rows+
-SYMBOL: +editable+
-
-: write-slot-editor ( path -- )
-    [
-        +editable+ get [
-            value-editor
-        ] [
-            get-ref pprint-short
-        ] if
-    ] with-cell ;
-
-: write-key ( mirror key -- )
-    +sequence+ get
-    [ 2drop ] [ <key-ref> write-slot-editor ] if ;
-
-: write-value ( mirror key -- )
-    <value-ref> write-slot-editor ;
-
-: describe-row ( mirror key n -- )
-    [
-        +number-rows+ get [ pprint-cell ] [ drop ] if
-        [ write-key ] [ write-value ] 2bi
-    ] with-row ;
 
 : summary. ( obj -- ) [ summary ] keep write-object nl ;
 
-: sorted-keys ( assoc -- alist )
+<PRIVATE
-    dup hashtable? [
-        keys
-        [ [ unparse-short ] keep ] { } map>assoc
-        sort-keys values
-    ] [ keys ] if ;
 
-: describe* ( obj mirror keys -- )
+: sort-unparsed-keys ( assoc -- alist )
-    [ summary. ] 2dip
+    >alist dup keys
-    [ drop ] [
+    [ unparse-short ] map
-        dup enum? [ +sequence+ on ] when
+    zip sort-values keys ;
-        standard-table-style [
-            swap '[ [ _ ] 2dip describe-row ] each-index
-        ] tabular-output
-    ] if-empty ;
 
-: describe ( obj -- )
+GENERIC: add-numbers ( alist -- table' )
-    dup make-mirror dup sorted-keys describe* ;
+
+M: enum add-numbers ;
+
+M: assoc add-numbers
+    +number-rows+ get [
+        dup length [ prefix ] 2map
+    ] when ;
+
+TUPLE: slot-name name ;
+
+M: slot-name pprint* name>> text ;
+
+GENERIC: fix-slot-names ( assoc -- assoc )
+
+M: assoc fix-slot-names >alist ;
+
+M: mirror fix-slot-names
+    [ [ slot-name boa ] dip ] { } assoc-map-as ;
+
+: (describe) ( obj assoc -- keys )
+    pprint-string-cells? on
+    [ summary. ] [
+        dup hashtable? [ sort-unparsed-keys ] when
+        [ fix-slot-names add-numbers simple-table. ] [ keys ] bi
+    ] bi* ;
+
+PRIVATE>
+
+: describe ( obj -- ) dup make-mirror (describe) drop ;
 
 M: tuple error. describe ;
 
@@ -72,25 +61,28 @@ M: tuple error. describe ;
 : :vars ( -- )
     error-continuation get name>> namestack. ;
 
-SYMBOL: inspector-hook
+SYMBOL: me
 
-[ t +number-rows+ [ describe* ] with-variable ] inspector-hook set-global
+<PRIVATE
 
 SYMBOL: inspector-stack
 
-SYMBOL: me
+SYMBOL: sorted-keys
 
 : reinspect ( obj -- )
     [ me set ]
     [
-        dup make-mirror dup mirror set dup sorted-keys dup \ keys set
+        dup make-mirror dup mirror set
-        inspector-hook get call
+        t +number-rows+ [ (describe) ] with-variable
+        sorted-keys set
     ] bi ;
 
 : (inspect) ( obj -- )
     [ inspector-stack get push ] [ reinspect ] bi ;
 
-: key@ ( n -- key ) \ keys get nth ;
+PRIVATE>
+
+: key@ ( n -- key ) sorted-keys get nth ;
 
 : &push ( -- obj ) me get ;
 
@@ -98,7 +90,7 @@ SYMBOL: me
 
 : &back ( -- )
     inspector-stack get
-    dup length 1 <= [ drop ] [ dup pop* peek reinspect ] if ;
+    dup length 1 <= [ drop ] [ [ pop* ] [ peek reinspect ] bi ] if ;
 
 : &add ( value key -- ) mirror get set-at &push reinspect ;
 

basis/io/styles/styles-docs.factor

@@ -106,12 +106,6 @@ HELP: font-style
 HELP: presented
 { $description "Character and paragraph style. An object associated with the text. In the Factor UI, this is shown as a clickable presentation of the object; left-clicking invokes a default command, and right-clicking shows a menu of commands." } ;
 
-HELP: presented-path
-{ $description "Character and paragraph style. An editable object associated with the text. In the Factor UI, this is shown as a clickable presentation of the object path together with an expander button which displays an object editor; left-clicking invokes a default command, and right-clicking shows a menu of commands." } ;
-
-HELP: presented-printer
-{ $description "Character and paragraph style. A quotation with stack effect " { $snippet "( obj -- )" } " which is applied to the value at the " { $link presented-path } " if the presentation needs to be re-displayed after the object has been edited." } ;
-
 HELP: page-color
 { $description "Paragraph style. Background color of the paragraph block, denoted by a sequence of four numbers between 0 and 1 (red, green, blue and alpha)." } 
 { $examples

basis/io/styles/styles.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables io colors summary make accessors splitting
 kernel ;
@@ -18,8 +18,6 @@ SYMBOL: font-style
 
 ! Presentation
 SYMBOL: presented
-SYMBOL: presented-path
-SYMBOL: presented-printer
 
 SYMBOL: href
 

basis/prettyprint/prettyprint.factor

@@ -149,14 +149,16 @@ PRIVATE>
 
 : .c ( -- ) callstack callstack. ;
 
-: pprint-cell ( obj -- ) [ pprint ] with-cell ;
+: pprint-cell ( obj -- ) [ pprint-short ] with-cell ;
+
+SYMBOL: pprint-string-cells?
 
 : simple-table. ( values -- )
     standard-table-style [
         [
             [
                 [
-                    dup string?
+                    dup string? pprint-string-cells? get not and
                     [ [ write ] with-cell ]
                     [ pprint-cell ]
                     if

basis/ui/backend/backend.factor

@@ -27,8 +27,6 @@ GENERIC: flush-gl-context ( handle -- )
 
 HOOK: offscreen-pixels ui-backend ( world -- alien w h )
 
-HOOK: beep ui-backend ( -- )
-
 : with-gl-context ( handle quot -- )
     swap [ select-gl-context call ] keep
     glFlush flush-gl-context gl-error ; inline

basis/ui/gadgets/panes/panes.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.paragraphs
@@ -7,7 +7,7 @@ ui.gadgets.menus ui.clipboards ui.gestures ui.traverse ui.render
 hashtables io kernel namespaces sequences io.styles strings
 quotations math opengl combinators math.vectors sorting
 splitting io.streams.nested assocs ui.gadgets.presentations
-ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
+ui.gadgets.grids ui.gadgets.grid-lines
 classes.tuple models continuations destructors accessors
 math.geometry.rect fry ;
 IN: ui.gadgets.panes
@@ -221,22 +221,14 @@ M: pane-stream make-span-stream
 : apply-page-color-style ( style gadget -- style gadget )
     page-color [ solid-interior ] apply-style ;
 
-: apply-path-style ( style gadget -- style gadget )
-    presented-path [ <editable-slot> ] apply-style ;
-
 : apply-border-width-style ( style gadget -- style gadget )
     border-width [ <border> ] apply-style ;
 
-: apply-printer-style ( style gadget -- style gadget )
-    presented-printer [ '[ _ make-pane ] >>printer ] apply-style ;
-
 : style-pane ( style pane -- pane )
     apply-border-width-style
     apply-border-color-style
     apply-page-color-style
     apply-presentation-style
-    apply-path-style
-    apply-printer-style
     nip ;
 
 TUPLE: nested-pane-stream < pane-stream style parent ;

basis/ui/gadgets/slots/slots.factor

@@ -1,10 +1,10 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces kernel parser prettyprint
 sequences arrays io math definitions math.vectors assocs refs
 ui.gadgets ui.gestures ui.commands ui.gadgets.scrollers
 ui.gadgets.buttons ui.gadgets.borders ui.gadgets.tracks
-ui.gadgets.editors eval ;
+ui.gadgets.editors eval continuations ;
 IN: ui.gadgets.slots
 
 TUPLE: update-object ;
@@ -13,40 +13,44 @@ TUPLE: update-slot ;
 
 TUPLE: edit-slot ;
 
-TUPLE: slot-editor < track ref text ;
+TUPLE: slot-editor < track ref close-hook update-hook text ;
 
 : revert ( slot-editor -- )
-    dup ref>> get-ref unparse-use
+    [ ref>> get-ref unparse-use ] [ text>> ] bi set-editor-string ;
-    swap text>> set-editor-string ;
 
 \ revert H{
     { +description+ "Revert any uncomitted changes." }
 } define-command
 
-GENERIC: finish-editing ( slot-editor ref -- )
+: close ( slot-editor -- )
+    dup close-hook>> call ;
 
-M: key-ref finish-editing
+\ close H{
-    drop T{ update-object } swap propagate-gesture ;
+    { +description+ "Close the slot editor without saving changes." }
+} define-command
 
-M: value-ref finish-editing
+: close-and-update ( slot-editor -- )
-    drop T{ update-slot } swap propagate-gesture ;
+    [ update-hook>> call ] [ close ] bi ;
 
 : slot-editor-value ( slot-editor -- object )
-    text>> control-value parse-fresh ;
+    text>> control-value parse-fresh first ;
 
 : commit ( slot-editor -- )
-    dup text>> control-value parse-fresh first
+    [ [ slot-editor-value ] [ ref>> ] bi set-ref ]
-    over ref>> set-ref
+    [ close-and-update ]
-    dup ref>> finish-editing ;
+    bi ;
 
 \ commit H{
     { +description+ "Parse the object being edited, and store the result back into the edited slot." }
 } define-command
 
+: eval-1 ( string -- object )
+    1array [ eval ] with-datastack first ;
+
 : com-eval ( slot-editor -- )
-    [ text>> editor-string eval ] keep
+    [ [ text>> editor-string eval-1 ] [ ref>> ] bi set-ref ]
-    [ ref>> set-ref ] keep
+    [ close-and-update ]
-    dup ref>> finish-editing ;
+    bi ;
 
 \ com-eval H{
     { +listener+ t }
@@ -54,23 +58,17 @@ M: value-ref finish-editing
 } define-command
 
 : delete ( slot-editor -- )
-    dup ref>> delete-ref
+    [ ref>> delete-ref ] [ close-and-update ] bi ;
-    T{ update-object } swap propagate-gesture ;
 
 \ delete H{
     { +description+ "Delete the slot and close the slot editor." }
 } define-command
 
-: close ( slot-editor -- )
+: <slot-editor> ( close-hook update-hook ref -- gadget )
-    T{ update-slot } swap propagate-gesture ;
-
-\ close H{
-    { +description+ "Close the slot editor without saving changes." }
-} define-command
-
-: <slot-editor> ( ref -- gadget )
     { 0 1 } slot-editor new-track
         swap >>ref
+        swap >>update-hook
+        swap >>close-hook
         add-toolbar
         <source-editor> >>text
         dup text>> <scroller> 1 track-add
@@ -87,39 +85,3 @@ slot-editor "toolbar" f {
     { f delete }
     { T{ key-down f f "ESC" } close }
 } define-command-map
-
-TUPLE: editable-slot < track printer ref ;
-
-: <edit-button> ( -- gadget )
-    "..."
-    [ T{ edit-slot } swap propagate-gesture ]
-    <roll-button> ;
-
-: display-slot ( gadget editable-slot -- )
-  dup clear-track
-    swap          1 track-add
-    <edit-button> f track-add
-  drop ;
-
-: update-slot ( editable-slot -- )
-    [ [ ref>> get-ref ] [ printer>> ] bi call ] keep
-    display-slot ;
-
-: edit-slot ( editable-slot -- )
-    [ clear-track ]
-    [
-        dup ref>> <slot-editor>
-        [ 1 track-add drop ]
-        [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
-    ] bi ;
-
-\ editable-slot H{
-    { T{ update-slot } [ update-slot ] }
-    { T{ edit-slot } [ edit-slot ] }
-} set-gestures
-
-: <editable-slot> ( gadget ref -- editable-slot )
-    { 1 0 } editable-slot new-track
-        swap >>ref
-        [ drop <gadget> ] >>printer
-        [ display-slot ] keep ;

basis/ui/gadgets/tables/tables.factor

@@ -183,15 +183,22 @@ M: table pref-dim*
     [ control-value length ]
     bi * 2array ;
 
-: nth-row ( row table -- value/f )
+: nth-row ( row table -- value/f ? )
-    over [ control-value nth ] [ 2drop f ] if ;
+    over [ control-value nth t ] [ 2drop f f ] if ;
 
-: selected-row ( table -- value/f )
+PRIVATE>
-    [ selected-index>> ] keep [ nth-row ] keep
+
-    over [ renderer>> row-value ] [ drop ] if ;
+: (selected-row) ( table -- value/f ? )
+    [ selected-index>> ] keep nth-row ;
+
+: selected-row ( table -- value/f ? )
+    [ (selected-row) ] keep
+    swap [ renderer>> row-value t ] [ 2drop f f ] if ;
+
+<PRIVATE
 
 : update-selected-value ( table -- )
-    [ selected-row ] [ selected-value>> ] bi set-model ;
+    [ selected-row drop ] [ selected-value>> ] bi set-model ;
 
 M: table model-changed
     nip
@@ -219,8 +226,7 @@ M: table model-changed
     ] if ;
 
 : row-action ( table -- )
-    dup selected-row dup
+    dup selected-row [ swap action>> call ] [ 2drop ] if ;
-    [ swap action>> call ] [ 2drop ] if ;
 
 : table-button-up ( table -- )
     hand-click# get 2 =
@@ -259,13 +265,13 @@ M: table model-changed
         [ swap >>mouse-index relayout-1 ]
         [
             [ nth-row ] keep
-            over [ show-row-summary ] [ 2drop ] if
+            swap [ show-row-summary ] [ 2drop ] if
         ] 2bi
     ] [ hide-mouse-help ] if-mouse-row ;
 
 : table-operations-menu ( table -- )
     [
-        [ nth-row ] keep [ renderer>> row-value ] keep
+        [ nth-row drop ] keep [ renderer>> row-value ] keep
         swap show-operations-menu
     ] [ drop ] if-mouse-row ;
 

basis/ui/tools/inspector/inspector-tests.factor

@@ -0,0 +1,6 @@
+IN: ui.tools.inspector.tests
+USING: tools.test ui.tools.inspector math ;
+
+\ <inspector-gadget> must-infer
+
+[ ] [ \ + <inspector-gadget> com-edit-slot ] unit-test

basis/ui/tools/inspector/inspector.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors inspector namespaces kernel models
+USING: accessors inspector namespaces kernel models fry
 models.filter prettyprint sequences mirrors assocs classes
-io io.styles arrays hashtables math.order sorting
+io io.styles arrays hashtables math.order sorting refs
 ui.tools.browser ui.commands ui.gadgets ui.gadgets.panes
 ui.gadgets.scrollers ui.gadgets.slots ui.gadgets.tracks
 ui.gestures ui.gadgets.buttons ui.gadgets.tables
-ui.gadgets.status-bar ui.gadgets.theme ui.gadgets.labelled ;
+ui.gadgets.status-bar ui.gadgets.theme ui.gadgets.labelled ui ;
 IN: ui.tools.inspector
 
 TUPLE: inspector-gadget < track table ;
@@ -86,6 +86,19 @@ M: inspector-gadget pref-dim*
 
 \ com-push H{ { +listener+ t } } define-command
 
+: slot-editor-window ( close-hook update-hook assoc key key-string -- )
+    [ <value-ref> <slot-editor> ] [ "Slot editor: " prepend ] bi*
+    open-window ;
+
+: com-edit-slot ( inspector -- )
+    [ close-window ] swap
+    [ '[ _ com-refresh ] ]
+    [ control-value make-mirror ]
+    [ table>> (selected-row) ] tri [
+        [ key>> ] [ key-string>> ] bi
+        slot-editor-window
+    ] [ 2drop 2drop ] if ;
+
 : inspector-help ( -- ) "ui-inspector" com-follow ;
 
 \ inspector-help H{ { +nullary+ t } } define-command
@@ -93,6 +106,7 @@ M: inspector-gadget pref-dim*
 inspector-gadget "toolbar" f {
     { T{ update-object } com-refresh }
     { T{ key-down f f "p" } com-push }
+    { T{ key-down f f "e" } com-edit-slot }
     { T{ key-down f f "F1" } inspector-help }
 } define-command-map
 

basis/ui/ui-docs.factor

@@ -59,6 +59,9 @@ HELP: with-ui
 { $notes "This combinator should be used in the " { $link POSTPONE: MAIN: } " word of a vocabulary, in order for the vocabulary to work when run from the UI listener (" { $snippet "\"my-app\" run" } " and the command line (" { $snippet "./factor -run=my-app" } ")." }
 { $examples "The " { $vocab-link "hello-ui" } " vocabulary implements a simple UI application which uses this combinator." } ;
 
+HELP: beep
+{ $description "Plays the system beep sound." } ;
+
 ARTICLE: "ui-glossary" "UI glossary"
 { $table
     { "color" { "an instance of " { $link color } } }

basis/ui/ui.factor

@@ -193,3 +193,5 @@ HOOK: (with-ui) ui-backend ( quot -- )
 
 : with-ui ( quot -- )
     ui-running? [ call ] [ '[ init-ui @ ] (with-ui) ] if ;
+
+HOOK: beep ui-backend ( -- )