diff --git a/basis/inspector/inspector-docs.factor b/basis/inspector/inspector-docs.factor index 82e1e104d1..60a1fb274b 100644 --- a/basis/inspector/inspector-docs.factor +++ b/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." } ; diff --git a/basis/inspector/inspector-tests.factor b/basis/inspector/inspector-tests.factor index c230364342..4ce549ac83 100644 --- a/basis/inspector/inspector-tests.factor +++ b/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 diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor index 9c61d092e5..ec8b950af3 100644 --- a/basis/inspector/inspector.factor +++ b/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 -quotations mirrors splitting math.parser classes vocabs refs -sets sorting summary debugger continuations fry ; +namespaces prettyprint prettyprint.custom prettyprint.sections +sequences strings io.styles vectors words quotations mirrors +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 ] [ write-slot-editor ] if ; - -: write-value ( mirror key -- ) - 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 ) - dup hashtable? [ - keys - [ [ unparse-short ] keep ] { } map>assoc - sort-keys values - ] [ keys ] if ; +alist dup keys + [ unparse-short ] map + zip sort-values keys ; -: describe ( obj -- ) - dup make-mirror dup sorted-keys describe* ; +GENERIC: add-numbers ( alist -- table' ) + +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 + + +: 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 ; diff --git a/basis/io/styles/styles-docs.factor b/basis/io/styles/styles-docs.factor index c29f3d5d70..902110ac50 100644 --- a/basis/io/styles/styles-docs.factor +++ b/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 diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index e07753c640..d6de58e21f 100644 --- a/basis/io/styles/styles.factor +++ b/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 diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor index 37a75de9b3..042827d9ad 100644 --- a/basis/prettyprint/prettyprint.factor +++ b/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 diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index eaa0953d25..0486210a67 100755 --- a/basis/ui/backend/backend.factor +++ b/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 diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor index efdd54bcc7..e7e02bf54d 100644 --- a/basis/ui/gadgets/panes/panes.factor +++ b/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 [ ] apply-style ; - : apply-border-width-style ( style gadget -- style gadget ) border-width [ ] 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 ; diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor index e04b288a5d..305f8f2b26 100644 --- a/basis/ui/gadgets/slots/slots.factor +++ b/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 - swap text>> set-editor-string ; + [ ref>> get-ref unparse-use ] [ text>> ] bi 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 - drop T{ update-object } swap propagate-gesture ; +\ close H{ + { +description+ "Close the slot editor without saving changes." } +} define-command -M: value-ref finish-editing - drop T{ update-slot } swap propagate-gesture ; +: close-and-update ( slot-editor -- ) + [ 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 - over ref>> set-ref - dup ref>> finish-editing ; + [ [ slot-editor-value ] [ ref>> ] bi set-ref ] + [ close-and-update ] + 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 - [ ref>> set-ref ] keep - dup ref>> finish-editing ; + [ [ text>> editor-string eval-1 ] [ ref>> ] bi set-ref ] + [ close-and-update ] + bi ; \ com-eval H{ { +listener+ t } @@ -54,23 +58,17 @@ M: value-ref finish-editing } define-command : delete ( slot-editor -- ) - dup ref>> delete-ref - T{ update-object } swap propagate-gesture ; + [ ref>> delete-ref ] [ close-and-update ] bi ; \ delete H{ { +description+ "Delete the slot and close the slot editor." } } define-command -: close ( slot-editor -- ) - T{ update-slot } swap propagate-gesture ; - -\ close H{ - { +description+ "Close the slot editor without saving changes." } -} define-command - -: ( ref -- gadget ) +: ( close-hook update-hook ref -- gadget ) { 0 1 } slot-editor new-track swap >>ref + swap >>update-hook + swap >>close-hook add-toolbar >>text dup text>> 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 ; - -: ( -- gadget ) - "..." - [ T{ edit-slot } swap propagate-gesture ] - ; - -: display-slot ( gadget editable-slot -- ) - dup clear-track - swap 1 track-add - 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>> - [ 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 - -: ( gadget ref -- editable-slot ) - { 1 0 } editable-slot new-track - swap >>ref - [ drop ] >>printer - [ display-slot ] keep ; diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index bd7becbc11..dce47fc11d 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/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 ) - over [ control-value nth ] [ 2drop f ] if ; +: nth-row ( row table -- value/f ? ) + over [ control-value nth t ] [ 2drop f f ] if ; -: selected-row ( table -- value/f ) - [ selected-index>> ] keep [ nth-row ] keep - over [ renderer>> row-value ] [ drop ] if ; +PRIVATE> + +: (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 ; + +> ] 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 - [ swap action>> call ] [ 2drop ] if ; + dup selected-row [ 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 ; diff --git a/basis/ui/tools/inspector/inspector-tests.factor b/basis/ui/tools/inspector/inspector-tests.factor new file mode 100644 index 0000000000..07ba5bc5c6 --- /dev/null +++ b/basis/ui/tools/inspector/inspector-tests.factor @@ -0,0 +1,6 @@ +IN: ui.tools.inspector.tests +USING: tools.test ui.tools.inspector math ; + +\ must-infer + +[ ] [ \ + com-edit-slot ] unit-test \ No newline at end of file diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor index a41001a46a..2d531c3d77 100644 --- a/basis/ui/tools/inspector/inspector.factor +++ b/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 -- ) + [ ] [ "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 diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index aead1d3a1f..e7f2d3e290 100644 --- a/basis/ui/ui-docs.factor +++ b/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 } } } diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index ea36d87b32..5b270cdf9e 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -192,4 +192,6 @@ HOOK: (with-ui) ui-backend ( quot -- ) windows get empty? not ; : with-ui ( quot -- ) - ui-running? [ call ] [ '[ init-ui @ ] (with-ui) ] if ; \ No newline at end of file + ui-running? [ call ] [ '[ init-ui @ ] (with-ui) ] if ; + +HOOK: beep ui-backend ( -- ) \ No newline at end of file