]> gitweb.factorcode.org Git - factor.git/commitdiff
Merge branch 'master' of git://factorcode.org/git/factor into new_ui
authorSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Fri, 9 Jan 2009 04:44:57 +0000 (22:44 -0600)
committerSlava Pestov <slava@slava-pestovs-macbook-pro.local>
Fri, 9 Jan 2009 04:44:57 +0000 (22:44 -0600)
103 files changed:
Factor.app/Contents/Resources/English.lproj/Factor.nib/classes.nib
Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib
Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib
basis/colors/colors.factor
basis/documents/documents-tests.factor
basis/documents/documents.factor
basis/help/crossref/crossref-tests.factor
basis/help/crossref/crossref.factor
basis/help/help.factor
basis/help/markup/markup.factor
basis/help/topics/topics.factor
basis/help/tutorial/tutorial.factor
basis/inspector/inspector-docs.factor
basis/inspector/inspector-tests.factor
basis/inspector/inspector.factor
basis/io/styles/styles-docs.factor
basis/io/styles/styles.factor
basis/models/search/search.factor [new file with mode: 0644]
basis/models/sort/sort.factor [new file with mode: 0644]
basis/opengl/gl/gl-docs.factor
basis/prettyprint/prettyprint.factor
basis/tools/apropos/apropos-docs.factor [new file with mode: 0644]
basis/tools/apropos/apropos-tests.factor [new file with mode: 0644]
basis/tools/apropos/apropos.factor [new file with mode: 0644]
basis/tools/completion/completion.factor
basis/tools/crossref/crossref-docs.factor
basis/tools/crossref/crossref.factor
basis/tools/profiler/profiler.factor
basis/tools/test/tools.factor [deleted file]
basis/tools/vocabs/browser/browser-docs.factor
basis/tools/vocabs/browser/browser-tests.factor
basis/tools/vocabs/browser/browser.factor
basis/ui/backend/backend.factor
basis/ui/cocoa/cocoa.factor
basis/ui/cocoa/tools/tools.factor
basis/ui/gadgets/books/books-docs.factor
basis/ui/gadgets/books/books.factor
basis/ui/gadgets/borders/borders-docs.factor
basis/ui/gadgets/buttons/buttons-docs.factor
basis/ui/gadgets/buttons/buttons.factor
basis/ui/gadgets/editors/editors-docs.factor
basis/ui/gadgets/editors/editors-tests.factor
basis/ui/gadgets/editors/editors.factor
basis/ui/gadgets/labelled/labelled-docs.factor
basis/ui/gadgets/labels/labels-docs.factor
basis/ui/gadgets/lists/authors.txt [deleted file]
basis/ui/gadgets/lists/lists-docs.factor [deleted file]
basis/ui/gadgets/lists/lists-tests.factor [deleted file]
basis/ui/gadgets/lists/lists.factor [deleted file]
basis/ui/gadgets/lists/summary.txt [deleted file]
basis/ui/gadgets/panes/panes-docs.factor
basis/ui/gadgets/panes/panes-tests.factor
basis/ui/gadgets/panes/panes.factor
basis/ui/gadgets/presentations/presentations-docs.factor
basis/ui/gadgets/scrollers/scrollers-docs.factor
basis/ui/gadgets/search-tables/search-tables.factor [new file with mode: 0644]
basis/ui/gadgets/sliders/sliders-docs.factor
basis/ui/gadgets/slots/slots.factor
basis/ui/gadgets/tabbed/tabbed.factor [new file with mode: 0644]
basis/ui/gadgets/tables/tables-docs.factor [new file with mode: 0644]
basis/ui/gadgets/tables/tables.factor [new file with mode: 0644]
basis/ui/tools/browser/browser-docs.factor [new file with mode: 0644]
basis/ui/tools/browser/browser-tests.factor
basis/ui/tools/browser/browser.factor
basis/ui/tools/common/common.factor [new file with mode: 0644]
basis/ui/tools/deploy/deploy.factor
basis/ui/tools/inspector/inspector-docs.factor [new file with mode: 0644]
basis/ui/tools/inspector/inspector-tests.factor [new file with mode: 0644]
basis/ui/tools/inspector/inspector.factor
basis/ui/tools/interactor/authors.txt [deleted file]
basis/ui/tools/interactor/interactor-docs.factor [deleted file]
basis/ui/tools/interactor/interactor-tests.factor [deleted file]
basis/ui/tools/interactor/interactor.factor [deleted file]
basis/ui/tools/interactor/summary.txt [deleted file]
basis/ui/tools/listener/listener-docs.factor [new file with mode: 0644]
basis/ui/tools/listener/listener-tests.factor
basis/ui/tools/listener/listener.factor
basis/ui/tools/operations/operations.factor
basis/ui/tools/profiler/profiler.factor
basis/ui/tools/search/authors.txt [deleted file]
basis/ui/tools/search/search-tests.factor [deleted file]
basis/ui/tools/search/search.factor [deleted file]
basis/ui/tools/search/summary.txt [deleted file]
basis/ui/tools/tools-docs.factor
basis/ui/tools/tools-tests.factor [deleted file]
basis/ui/tools/tools.factor
basis/ui/tools/traceback/traceback.factor
basis/ui/tools/walker/walker.factor
basis/ui/tools/workspace/authors.txt [deleted file]
basis/ui/tools/workspace/summary.txt [deleted file]
basis/ui/tools/workspace/tags.txt [deleted file]
basis/ui/tools/workspace/workspace-tests.factor [deleted file]
basis/ui/tools/workspace/workspace.factor [deleted file]
basis/ui/ui-docs.factor
basis/ui/ui.factor
basis/ui/windows/windows.factor
basis/ui/x11/x11.factor
core/parser/parser.factor
extra/ui/gadgets/lists/authors.txt [new file with mode: 0644]
extra/ui/gadgets/lists/lists-docs.factor [new file with mode: 0644]
extra/ui/gadgets/lists/lists-tests.factor [new file with mode: 0644]
extra/ui/gadgets/lists/lists.factor [new file with mode: 0644]
extra/ui/gadgets/lists/summary.txt [new file with mode: 0644]

index bf3d2a65608e45f465b0ee815204720924a36609..6a6eedfcc0caa10bb48691f60a4d49f20208a0ba 100644 (file)
@@ -1,17 +1,38 @@
-{
-    IBClasses = (
-        {
-            ACTIONS = {
-                newFactorWorkspace = id; 
-                runFactorFile = id; 
-                saveFactorImage = id; 
-                saveFactorImageAs = id; 
-                showFactorHelp = id; 
-            }; 
-            CLASS = FirstResponder; 
-            LANGUAGE = ObjC; 
-            SUPERCLASS = NSObject; 
-        }
-    ); 
-    IBVersion = 1; 
-}
\ No newline at end of file
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<plist version="1.0">
+<dict>
+       <key>IBClasses</key>
+       <array>
+               <dict>
+                       <key>ACTIONS</key>
+                       <dict>
+                               <key>factorBrowser</key>
+                               <string>id</string>
+                               <key>factorListener</key>
+                               <string>id</string>
+                               <key>newFactorBrowser</key>
+                               <string>id</string>
+                               <key>newFactorListener</key>
+                               <string>id</string>
+                               <key>refreshAll</key>
+                               <string>id</string>
+                               <key>runFactorFile</key>
+                               <string>id</string>
+                               <key>saveFactorImage</key>
+                               <string>id</string>
+                               <key>saveFactorImageAs</key>
+                               <string>id</string>
+                       </dict>
+                       <key>CLASS</key>
+                       <string>FirstResponder</string>
+                       <key>LANGUAGE</key>
+                       <string>ObjC</string>
+                       <key>SUPERCLASS</key>
+                       <string>NSObject</string>
+               </dict>
+       </array>
+       <key>IBVersion</key>
+       <string>1</string>
+</dict>
+</plist>
index 8e4b9eeba85984431ea1571bae5874dbcbf4e282..725fb096861f5af4de1b2ebf53b464dbd87e2c28 100644 (file)
@@ -1,21 +1,18 @@
 <?xml version="1.0" encoding="UTF-8"?>
-<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
+<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
 <plist version="1.0">
 <dict>
-       <key>IBDocumentLocation</key>
-       <string>557 119 525 491 0 0 2560 1578 </string>
-       <key>IBEditorPositions</key>
-       <dict>
-               <key>29</key>
-               <string>326 905 270 44 0 0 2560 1578 </string>
-       </dict>
        <key>IBFramework Version</key>
-       <string>439.0</string>
+       <string>629</string>
+       <key>IBOldestOS</key>
+       <integer>5</integer>
        <key>IBOpenObjects</key>
        <array>
-               <integer>29</integer>
+               <integer>299</integer>
        </array>
        <key>IBSystem Version</key>
-       <string>8R218</string>
+       <string>9G55</string>
+       <key>targetFramework</key>
+       <string>IBCocoaFramework</string>
 </dict>
 </plist>
index 8dfebba5669ffdf8e672731f7d51c4dd3320621d..daf88abfcd3e193b8f171f8f7edb6747116d36fe 100644 (file)
Binary files a/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib and b/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib differ
index 1183c2e46c9cec55a431a81c087ecfe881232a87..1364f173d5c67ff4efbac6a4c11d412b2c3f2e5f 100644 (file)
@@ -22,6 +22,7 @@ M: color blue>>  ( color -- blue  ) >rgba blue>>  ;
 : blue         T{ rgba f 0.0   0.0   1.0   1.0  } ; inline
 : cyan         T{ rgba f 0     0.941 0.941 1    } ; inline
 : gray         T{ rgba f 0.6   0.6   0.6   1.0  } ; inline
+: dark-gray    T{ rgba f 0.8   0.8   0.8   1.0  } ; inline
 : green        T{ rgba f 0.0   1.0   0.0   1.0  } ; inline
 : light-gray   T{ rgba f 0.95  0.95  0.95  0.95 } ; inline
 : light-purple T{ rgba f 0.8   0.8   1.0   1.0  } ; inline
index 88e471cce1eca37b1b77de6a8a451b40dc2ba3e7..4bc9de6645ac6c6c1c024d46df28f4d9cfbeeb7d 100644 (file)
@@ -90,17 +90,17 @@ USING: documents namespaces tools.test make arrays kernel fry ;
 
 <document> "doc" set
 "Hello world" "doc" get set-doc-string
-[ { 0 0 } ] [ { 0 0 } "doc" get T{ one-word-elt } prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get T{ one-word-elt } prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get T{ one-word-elt } prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 2 } "doc" get T{ one-word-elt } next-elt ] unit-test
-[ { 0 5 } ] [ { 0 5 } "doc" get T{ one-word-elt } next-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
+[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
 
 <document> "doc" set
 "Hello\nworld, how are\nyou?" "doc" get set-doc-string
 
 [ { 2 4 } ] [ "doc" get doc-end ] unit-test
 
-[ { 0 0 } ] [ { 0 3 } "doc" get T{ line-elt } prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 3 } "doc" get T{ line-elt } prev-elt ] unit-test
-[ { 2 4 } ] [ { 2 1 } "doc" get T{ line-elt } next-elt ] unit-test
+[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
+[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
index 29f865cf3c7673d7603ded2cbf062c4b1f94a2a3..f8255c980126c374ec9a1508408caa8b3204e201 100644 (file)
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays io kernel math models namespaces make
 sequences strings splitting combinators unicode.categories
-math.order math.ranges ;
+math.order math.ranges fry ;
 IN: documents
 
 : +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
@@ -150,7 +150,7 @@ GENERIC: next-elt ( loc document elt -- newloc )
 : elt-string ( loc document elt -- string )
     [ prev/next-elt ] [ drop ] 2bi doc-range ;
 
-TUPLE: char-elt ;
+SINGLETON: char-elt
 
 : (prev-char) ( loc document quot -- loc )
     {
@@ -172,7 +172,7 @@ M: char-elt prev-elt
 M: char-elt next-elt
     drop [ drop 1 +col ] (next-char) ;
 
-TUPLE: one-char-elt ;
+SINGLETON: one-char-elt
 
 M: one-char-elt prev-elt 2drop ;
 
@@ -186,7 +186,7 @@ M: one-char-elt next-elt 2drop ;
 : ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
 
 : break-detector ( ? -- quot )
-    [ [ blank? ] dip xor ] curry ; inline
+    '[ blank? _ xor ] ; inline
 
 : (prev-word) ( ? col str -- col )
     rot break-detector find-last-from drop ?1+ ;
@@ -195,7 +195,7 @@ M: one-char-elt next-elt 2drop ;
     [ rot break-detector find-from drop ] keep
     over not [ nip length ] [ drop ] if ;
 
-TUPLE: one-word-elt ;
+SINGLETON: one-word-elt
 
 M: one-word-elt prev-elt
     drop
@@ -205,7 +205,7 @@ M: one-word-elt next-elt
     drop
     [ [ f ] 2dip (next-word) ] (word-elt) ;
 
-TUPLE: word-elt ;
+SINGLETON: word-elt
 
 M: word-elt prev-elt
     drop
@@ -217,7 +217,7 @@ M: word-elt next-elt
     [ [ ((word-elt)) (next-word) ] (word-elt) ]
     (next-char) ;
 
-TUPLE: one-line-elt ;
+SINGLETON: one-line-elt
 
 M: one-line-elt prev-elt
     2drop first 0 2array ;
@@ -225,7 +225,7 @@ M: one-line-elt prev-elt
 M: one-line-elt next-elt
     drop [ first dup ] dip doc-line length 2array ;
 
-TUPLE: line-elt ;
+SINGLETON: line-elt
 
 M: line-elt prev-elt
     2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
@@ -234,7 +234,7 @@ M: line-elt next-elt
     drop over first over last-line# number=
     [ nip doc-end ] [ drop 1 +line ] if ;
 
-TUPLE: doc-elt ;
+SINGLETON: doc-elt
 
 M: doc-elt prev-elt 3drop { 0 0 } ;
 
index 2e8c17394421986424030a5902d5b9577548c6ca..47c3105436c7a00e06e5a43c5267332f247077f8 100644 (file)
@@ -13,7 +13,7 @@ io.streams.string continuations debugger compiler.units eval ;
 
 [ t ] [
     "foo" article-children
-    "foo" "help.crossref.tests" lookup 1array sequence=
+    "foo" "help.crossref.tests" lookup >link 1array sequence=
 ] unit-test
 
 [ "foo" ] [ "foo" "help.crossref.tests" lookup article-parent ] unit-test
index 9eec5b859ed07edc2b6c9542ce2be8f685827a56..b791a4b124760645638118a1ed2f2d5fd29d4236 100644 (file)
@@ -1,17 +1,19 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays definitions generic assocs
+USING: arrays definitions generic assocs math fry
 io kernel namespaces prettyprint prettyprint.sections
 sequences words summary classes help.topics help.markup ;
 IN: help.crossref
 
+: article-links ( topic elements -- seq )
+    [ article-content ] dip
+    collect-elements [ >link ] map ;
+
 : article-children ( topic -- seq )
-    article-content { $subsection } collect-elements ;
+    { $subsection } article-links ;
 
 M: link uses
-    article-content
-    { $subsection $link $see-also }
-    collect-elements [ \ f or ] map ;
+    { $subsection $link $see-also } article-links ;
 
 : help-path ( topic -- seq )
     [ article-parent ] follow rest ;
@@ -24,3 +26,15 @@ M: link uses
 
 : unxref-article ( topic -- )
     >link unxref ;
+
+: prev/next ( obj seq n -- obj' )
+    [ [ index dup ] keep ] dip swap
+    '[ _ + _ ?nth ] when ;
+
+: prev/next-article ( article n -- article' )
+    [ dup article-parent dup ] dip
+    '[ article-children _ prev/next ] [ 2drop f ] if ;
+
+: prev-article ( article -- prev ) -1 prev/next-article ;
+
+: next-article ( article -- next ) 1 prev/next-article ;
\ No newline at end of file
index 272bdc1db3696891947e38f8d0d80cc2857e609a..0d13f3aeb0a23bafa1a0d5443e6654d1538b5e16 100644 (file)
@@ -93,28 +93,32 @@ M: word article-parent "help-parent" word-prop ;
 
 M: word set-article-parent swap "help-parent" set-word-prop ;
 
-: $doc-path ( article -- )
-    help-path [
-        [
-            help-path-style get [
-                "Parent topics: " write $links
-            ] with-style
-        ] ($block)
-    ] unless-empty ;
+: ($title) ( topic -- )
+    [ [ article-title ] [ >link ] bi write-object ] ($block) ;
+
+: $navigation-row ( content element label -- )
+    [ prefix 1array ] dip prefix , ;
+
+: $navigation-table ( topic -- )
+    [
+        [ help-path [ \ $links "Up:" $navigation-row ] unless-empty ]
+        [ prev-article [ 1array \ $long-link "Prev:" $navigation-row ] when* ]
+        [ next-article [ 1array \ $long-link "Next:" $navigation-row ] when* ]
+        tri
+    ] { } make [ $table ] unless-empty ;
 
 : $title ( topic -- )
     title-style get [
         title-style get [
-            dup [
-                dup article-title swap >link write-object
-            ] ($block) $doc-path
+            [ ($title) ]
+            [ help-path-style get [ $navigation-table ] with-style ] bi
         ] with-nesting
     ] with-style nl ;
 
 : print-topic ( topic -- )
     >link
-    last-element off dup $title
-    article-content print-content nl ;
+    last-element off
+    [ $title ] [ article-content print-content nl ] bi ;
 
 SYMBOL: help-hook
 
@@ -125,12 +129,8 @@ help-hook global [ [ print-topic ] or ] change-at
 
 : about ( vocab -- )
     dup require
-    dup vocab [ ] [
-        "No such vocabulary: " prepend throw
-    ] ?if
-    dup vocab-help [
-        help
-    ] [
+    dup vocab [ ] [ no-vocab ] ?if
+    dup vocab-help [ help ] [
         "The " write vocab-name write
         " vocabulary does not define a main help article." print
         "To define one, refer to \\ ABOUT: help" print
index bf933cd9f12008335ab84d6972b77812cd7f71ea..c6bc70cef0d84ab07c7370535a86002570022c82 100644 (file)
@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays definitions generic io kernel assocs
 hashtables namespaces make parser prettyprint sequences strings
-io.styles vectors words math sorting splitting classes slots
-vocabs help.stylesheet help.topics vocabs.loader quotations ;
+io.styles vectors words math sorting splitting classes slots fry
+sets vocabs help.stylesheet help.topics vocabs.loader quotations ;
 IN: help.markup
 
 ! Simple markup language.
@@ -157,6 +157,9 @@ ALIAS: $slot $snippet
 : ($long-link) ( object -- )
     [ article-title ] [ >link ] bi write-link ;
 
+: $long-link ( object -- )
+    first ($long-link) ;
+
 : ($subsection) ( element quot -- )
     [
         subsection-style get [
@@ -201,7 +204,7 @@ ALIAS: $slot $snippet
     "See also" $heading $links ;
 
 : related-words ( seq -- )
-    dup [ "related" set-word-prop ] curry each ;
+    dup '[ _ "related" set-word-prop ] each ;
 
 : $related ( element -- )
     first dup "related" word-prop remove
@@ -335,7 +338,8 @@ M: f ($instance)
 
 GENERIC: elements* ( elt-type element -- )
 
-M: simple-element elements* [ elements* ] with each ;
+M: simple-element elements*
+    [ elements* ] with each ;
 
 M: object elements* 2drop ;
 
@@ -346,13 +350,10 @@ M: array elements*
 : elements ( elt-type element -- seq ) [ elements* ] { } make ;
 
 : collect-elements ( element seq -- elements )
-    [
-        swap [
-            elements [
-                rest [ dup set ] each
-            ] each
-        ] curry each
-    ] H{ } make-assoc keys ;
+    swap '[ _ elements [ rest ] map concat ] map concat prune ;
 
 : <$link> ( topic -- element )
-    \ $link swap 2array ;
+    1array \ $link prefix ;
+
+: <$snippet> ( str -- element )
+    1array \ $snippet prefix ;
index e6b19d5baae1866acd6e84bb1c299a2e4ff9a2c1..54cc53a0e8bdb5cf7fcc72598094c74c6a87030b 100644 (file)
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.x
 USING: accessors arrays definitions generic assocs
 io kernel namespaces make prettyprint prettyprint.sections
@@ -15,13 +15,14 @@ GENERIC: >link ( obj -- obj )
 M: link >link ;
 M: vocab-spec >link ;
 M: object >link link boa ;
+M: f >link drop \ f >link ;
 
 PREDICATE: word-link < link name>> word? ;
 
 M: link summary
     [
         "Link: " %
-        name>> dup word? [ summary ] [ unparse ] if %
+        name>> dup word? [ summary ] [ unparse-short ] if %
     ] "" make ;
 
 ! Help articles
@@ -73,4 +74,4 @@ M: f article-name drop \ f article-name ;
 M: f article-title drop \ f article-title ;
 M: f article-content drop \ f article-content ;
 M: f article-parent drop \ f article-parent ;
-M: f set-article-parent drop \ f set-article-parent ;
+M: f set-article-parent drop \ f set-article-parent ;
\ No newline at end of file
index 9ed36ac77cbf453e53c7c9ad930b23e4ca686894..83ca58e04b1ba673626b8d1207f3bf291959fae4 100644 (file)
@@ -1,7 +1,7 @@
 USING: help.markup help.syntax ui.commands ui.operations
-ui.tools.search ui.tools.workspace editors vocabs.loader
-kernel sequences prettyprint tools.test tools.vocabs strings
-unicode.categories unicode.case ui.tools.browser ;
+editors vocabs.loader kernel sequences prettyprint tools.test
+tools.vocabs strings unicode.categories unicode.case
+ui.tools.browser ui.tools.listener ;
 IN: help.tutorial
 
 ARTICLE: "first-program-start" "Creating a vocabulary for your first program"
@@ -36,7 +36,7 @@ $nl
 { $code ": palindrome? ( string -- ? ) dup reverse = ;" }
 "Place this definition at the end of your source file."
 $nl
-"Now we have changed the source file, we must reload it into Factor so that we can test the new definition. To do this, simply go to the Factor workspace and press " { $command workspace "workflow" refresh-all } ". This will find any previously-loaded source files which have changed on disk, and reload them."
+"Now we have changed the source file, we must reload it into Factor so that we can test the new definition. To do this, simply go to the Factor listener and press " { $command listener-gadget "workflow" refresh-all } ". This will find any previously-loaded source files which have changed on disk, and reload them."
 $nl
 "When you do this, you will get an error about the " { $link dup } " word not being found. This is because this word is part of the " { $vocab-link "kernel" } " vocabulary, but this vocabulary is not part of the source file's " { $link "vocabulary-search" } ". You must explicitly list dependencies in source files. This allows Factor to automatically load required vocabularies and makes larger programs easier to maintain."
 $nl
@@ -44,13 +44,13 @@ $nl
 $nl
 "So now, add the following at the start of the source file:"
 { $code "USING: kernel ;" }
-"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the workspace listener's input area, and press " { $operation com-follow } "."
+"Next, find out what vocabulary " { $link reverse } " lives in; type the word name " { $snippet "reverse" } " in the listener's input area, and press " { $operation com-follow } "."
 $nl
 "It lives in the " { $vocab-link "sequences" } " vocabulary, so we add that to the search path:"
 { $code "USING: kernel sequences ;" }
 "Finally, check what vocabulary " { $link = } " lives in, and confirm that it's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path."
 $nl
-"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
+"Now press " { $command listener-gadget "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ;
 
 ARTICLE: "first-program-test" "Testing your first program"
 "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:"
@@ -132,13 +132,13 @@ $nl
 $nl
 "We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:"
 { $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" }
-"Now if you press " { $command workspace "workflow" refresh-all } ", the source file should reload without any errors. You can run unit tests again, and this time, they will all pass:"
+"Now if you press " { $command listener-gadget "workflow" refresh-all } ", the source file should reload without any errors. You can run unit tests again, and this time, they will all pass:"
 { $code "\"palindrome\" test" } ;
 
 ARTICLE: "first-program" "Your first program"
 "In this tutorial, we will write a simple Factor program which prompts the user to enter a word, and tests if it is a palindrome (that is, the word is spelled the same backwards and forwards)."
 $nl
-"In this tutorial, you will learn about basic Factor development tools. You may want to open a second workspace window by pressing " { $command workspace "workflow" workspace-window } "; this will allow you to read this tutorial and browse other documentation at the same time."
+"In this tutorial, you will learn about basic Factor development tools."
 { $subsection "first-program-start" }
 { $subsection "first-program-logic" }
 { $subsection "first-program-test" }
index 82e1e104d1fce03991c0b76f7fc1afb6739a26ba..60a1fb274b0ba2e565001c611bafe70d6f25dd5c 100644 (file)
@@ -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." } ;
index c2303643423858235bdb6721c23d21218d272c68..4ce549ac83854e9ff6463d63084091e49807abc6 100644 (file)
@@ -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
index 9c61d092e5622ea66f1bec001fe9620006d2ec52..ec8b950af3ecebab93886cbf27bcccae932030dd 100644 (file)
@@ -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 ;
+: summary. ( obj -- ) [ summary ] keep write-object nl ;
 
-: write-key ( mirror key -- )
-    +sequence+ get
-    [ 2drop ] [ <key-ref> write-slot-editor ] if ;
+<PRIVATE
 
-: write-value ( mirror key -- )
-    <value-ref> write-slot-editor ;
+: sort-unparsed-keys ( assoc -- alist )
+    >alist dup keys
+    [ unparse-short ] map
+    zip sort-values keys ;
 
-: describe-row ( mirror key n -- )
-    [
-        +number-rows+ get [ pprint-cell ] [ drop ] if
-        [ write-key ] [ write-value ] 2bi
-    ] with-row ;
+GENERIC: add-numbers ( alist -- table' )
 
-: summary. ( obj -- ) [ summary ] keep write-object nl ;
+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 ;
 
-: sorted-keys ( assoc -- alist )
-    dup hashtable? [
-        keys
-        [ [ unparse-short ] keep ] { } map>assoc
-        sort-keys values
-    ] [ keys ] if ;
-
-: describe* ( obj mirror keys -- )
-    [ summary. ] 2dip
-    [ drop ] [
-        dup enum? [ +sequence+ on ] when
-        standard-table-style [
-            swap '[ [ _ ] 2dip describe-row ] each-index
-        ] tabular-output
-    ] if-empty ;
-
-: describe ( obj -- )
-    dup make-mirror dup sorted-keys describe* ;
+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
-        inspector-hook get call
+        dup make-mirror dup mirror set
+        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 ;
 
index c29f3d5d702a7aa87d849f673651173dca9f0f1e..902110ac501ca8fdea168f7018a81b1efe021fff 100644 (file)
@@ -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
index e07753c64076990032f20991523f05ac79f12cdc..d6de58e21f26a7ce554fa8eb580a2beeee95f3dc 100644 (file)
@@ -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/models/search/search.factor b/basis/models/search/search.factor
new file mode 100644 (file)
index 0000000..62e4db3
--- /dev/null
@@ -0,0 +1,8 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays fry kernel models.compose models.filter sequences ;
+IN: models.search
+
+: <search> ( values search quot -- model )
+    [ 2array <compose> ] dip
+    '[ first2 _ curry filter ] <filter> ;
\ No newline at end of file
diff --git a/basis/models/sort/sort.factor b/basis/models/sort/sort.factor
new file mode 100644 (file)
index 0000000..cbced93
--- /dev/null
@@ -0,0 +1,8 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays fry kernel models.compose models.filter
+sequences sorting ;
+IN: models.sort
+
+: <sort> ( values sort -- model )
+    2array <compose> [ first2 sort ] <filter> ;
\ No newline at end of file
index adc4d6f7740b097245bad53931b0581c0b554b92..83331decee86edf544e4ba1a9f0dd3f50c7a8ea7 100644 (file)
@@ -8,7 +8,7 @@ ARTICLE: "opengl-low-level" "OpenGL binding"
   { $subsection "opengl-geometric-primitives" }
   { $subsection "opengl-modeling-transformations" } ;
 
-ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
+ARTICLE: "opengl-specifying-vertices" "Specifying vertices"
 
   { $subsection glVertex2d }
   { $subsection glVertex2f }
@@ -35,7 +35,7 @@ ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
   { $subsection glVertex4iv }
   { $subsection glVertex4sv } ;
 
-ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
+ARTICLE: "opengl-geometric-primitives" "OpenGL geometric primitives"
 
   { $table
       { { $link GL_POINTS         } "individual points" }
@@ -70,7 +70,7 @@ HELP: glPolygonMode
                          { $link GL_LINE }
                          { $link GL_FILL } } } } } ;
 
-ARTICLE: "opengl-modeling-transformations" "Modeling Transformations"
+ARTICLE: "opengl-modeling-transformations" "Modeling transformations"
   { $subsection glTranslatef }
   { $subsection glTranslated }
   { $subsection glRotatef }
index b3800babe8fdb3a4ca76038b87931d4db07710af..042827d9ada5ecd780e33c818760e360a36cf418 100644 (file)
@@ -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
@@ -234,15 +236,6 @@ M: pathname synopsis* pprint* ;
 
 M: word summary synopsis ;
 
-: synopsis-alist ( definitions -- alist )
-    [ dup synopsis swap ] { } map>assoc ;
-
-: definitions. ( alist -- )
-    [ write-object nl ] assoc-each ;
-
-: sorted-definitions. ( definitions -- )
-    synopsis-alist sort-keys definitions. ;
-
 GENERIC: declarations. ( obj -- )
 
 M: object declarations. drop ;
diff --git a/basis/tools/apropos/apropos-docs.factor b/basis/tools/apropos/apropos-docs.factor
new file mode 100644 (file)
index 0000000..b50b51b
--- /dev/null
@@ -0,0 +1,6 @@
+IN: tools.apropos
+USING: help.markup help.syntax strings ;
+
+HELP: apropos
+{ $values { "str" string } }
+{ $description "Lists all words, vocabularies and help articles whose name contains a subsequence equal to " { $snippet "str" } ". Results are ranked using a simple distance algorithm." } ;
diff --git a/basis/tools/apropos/apropos-tests.factor b/basis/tools/apropos/apropos-tests.factor
new file mode 100644 (file)
index 0000000..96ce9d3
--- /dev/null
@@ -0,0 +1,4 @@
+IN: tools.apropos.tests
+USING: tools.apropos tools.test ;
+
+[ ] [ "swp" apropos ] unit-test
diff --git a/basis/tools/apropos/apropos.factor b/basis/tools/apropos/apropos.factor
new file mode 100644 (file)
index 0000000..582c7b5
--- /dev/null
@@ -0,0 +1,73 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs fry help.markup help.topics io
+kernel make math math.parser namespaces sequences sorting
+summary tools.completion tools.vocabs tools.vocabs.browser
+vocabs words unicode.case help ;
+IN: tools.apropos
+
+: $completions ( seq -- )
+    dup [ word? ] all? [ words-table ] [
+        dup [ vocab-spec? ] all? [
+            $vocabs
+        ] [
+            [ <$link> ] map $list
+        ] if
+    ] if ;
+
+TUPLE: more-completions seq ;
+
+CONSTANT: max-completions 5
+
+M: more-completions article-title
+    seq>> length number>string " results" append ;
+
+M: more-completions article-name
+    seq>> length max-completions - number>string " more results" append ;
+
+M: more-completions article-content
+    seq>> sort-values keys \ $completions prefix ;
+
+M: more-completions summary article-title ;
+
+: (apropos) ( str candidates title -- element )
+    [
+        [ completions ] dip '[
+            _ 1array \ $heading prefix ,
+            [ max-completions short head keys \ $completions prefix , ]
+            [ dup length max-completions > [ more-completions boa <$link> , ] [ drop ] if ]
+            bi
+        ] unless-empty
+    ] { } make ;
+
+: word-candidates ( words -- candidates )
+    [ dup name>> >lower ] { } map>assoc ;
+
+: vocab-candidates ( -- candidates )
+    all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
+
+: help-candidates ( seq -- candidates )
+    [ [ >link ] [ article-title >lower ] bi ] { } map>assoc
+    sort-values ;
+
+: $apropos ( str -- )
+    first
+    [ all-words word-candidates "Words" (apropos) ]
+    [ vocab-candidates "Vocabularies" (apropos) ]
+    [ articles get keys help-candidates "Help articles" (apropos) ]
+    tri 3array print-element ;
+
+TUPLE: apropos search ;
+
+C: <apropos> apropos
+
+M: apropos article-title
+    search>> "Search results for ``" "''" surround ;
+
+M: apropos article-name article-title ;
+
+M: apropos article-content
+    search>> 1array \ $apropos prefix ;
+
+: apropos ( str -- )
+    <apropos> print-topic ;
index 084b97970d63e00ffc260fda7c6f69b13f55adcf..55e58ebf146418c45f9ed1374bc425f429cc54fb 100644 (file)
@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math namespaces strings io
+USING: kernel arrays sequences math namespaces strings io fry
 vectors words assocs combinators sorting unicode.case
 unicode.categories math.order ;
 IN: tools.completion
 
 : (fuzzy) ( accum ch i full -- accum i ? )
-    index-from 
+    index-from
     [
         [ swap push ] 2keep 1+ t
     ] [
@@ -61,18 +61,12 @@ IN: tools.completion
     dupd fuzzy score max ;
 
 : completion ( short candidate -- result )
-    [ second >lower swap complete ] keep first 2array ;
+    [ second >lower swap complete ] keep 2array ;
 
 : completions ( short candidates -- seq )
-    over empty? [
-        nip [ first ] map
-    ] [
-        [ >lower ] dip [ completion ] with map
-        rank-completions
-    ] if ;
-
-: string-completions ( short strs -- seq )
-    dup zip completions ;
+    [ '[ _ ] ]
+    [ '[ >lower _ [ completion ] with map rank-completions ] ] bi
+    if-empty ;
 
 : limited-completions ( short candidates -- seq )
     [ completions ] [ drop ] 2bi
index b7ec0d07a2af2f7fa71f1de243677e9d36b1e2a4..820c957cbc3b3c54ad5e1d4e0afdafb87690041d 100644 (file)
@@ -3,7 +3,6 @@ IN: tools.crossref
 
 ARTICLE: "tools.crossref" "Cross-referencing tools" 
 { $subsection usage. }
-{ $subsection apropos }
 { $see-also "definitions" "words" see see-methods } ;
 
 ABOUT: "tools.crossref"
@@ -14,7 +13,3 @@ HELP: usage.
 { $examples { $code "\\ reverse usage." } } ;
 
 { usage usage. } related-words
-
-HELP: apropos
-{ $values { "str" "a string" } }
-{ $description "Lists all words whose name contains a subsequence equal to " { $snippet "str" } ". Results are ranked using a simple distance algorithm." } ;
index c4b046ecccb26d87479119166fbac44d30806fe9..494e022243f5afd269808281f9fb6d90380a6ab2 100644 (file)
@@ -1,16 +1,17 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays definitions assocs io kernel
-math namespaces prettyprint sequences strings io.styles words
-generic tools.completion quotations parser summary
-sorting hashtables vocabs parser source-files ;
+USING: assocs definitions io io.styles kernel prettyprint
+sorting ;
 IN: tools.crossref
 
-: usage. ( word -- )
-    smart-usage sorted-definitions. ;
+: synopsis-alist ( definitions -- alist )
+    [ dup synopsis swap ] { } map>assoc ;
+
+: definitions. ( alist -- )
+    [ write-object nl ] assoc-each ;
 
-: words-matching ( str -- seq )
-    all-words [ dup name>> ] { } map>assoc completions ;
+: sorted-definitions. ( definitions -- )
+    synopsis-alist sort-keys definitions. ;
 
-: apropos ( str -- )
-    words-matching synopsis-alist reverse definitions. ;
+: usage. ( word -- )
+    smart-usage sorted-definitions. ;
index 83915363749f6ef62dfed14c2903cba72b80a153..19646e55c2df814f8db3954b9a754aa69a383b98 100644 (file)
@@ -3,45 +3,51 @@
 USING: accessors words sequences math prettyprint kernel arrays io
 io.styles namespaces assocs kernel.private strings combinators
 sorting math.parser vocabs definitions tools.profiler.private
-continuations generic compiler.units sets ;
+continuations generic compiler.units sets classes fry ;
 IN: tools.profiler
 
 : profile ( quot -- )
     [ t profiling call ] [ f profiling ] [ ] cleanup ;
 
-: counters ( words -- assoc )
-    [ dup counter>> ] { } map>assoc ;
+: filter-counts ( alist -- alist' )
+    [ second 0 > ] filter ;
 
-GENERIC: (profile.) ( obj -- )
+: map-counters ( obj quot -- alist )
+    { } map>assoc filter-counts ; inline
 
-TUPLE: usage-profile word ;
+: counters ( words -- alist )
+    [ dup counter>> ] map-counters ;
 
-C: <usage-profile> usage-profile
+: cumulative-counters ( obj quot -- alist )
+    '[ dup @ [ counter>> ] sigma ] map-counters ; inline
 
-M: word (profile.)
-    [ name>> "( no name )" or ] [ <usage-profile> ] bi write-object ;
+: vocab-counters ( -- alist )
+    vocabs [ words [ predicate? not ] filter ] cumulative-counters ;
 
-TUPLE: vocab-profile vocab ;
+: generic-counters ( -- alist )
+    all-words [ subwords ] cumulative-counters ;
 
-C: <vocab-profile> vocab-profile
+: methods-on ( class -- methods )
+    dup implementors [ method ] with map ;
 
-M: string (profile.)
-    dup <vocab-profile> write-object ;
+: class-counters ( -- alist )
+    classes [ methods-on ] cumulative-counters ;
 
-M: method-body (profile.)
-    [ synopsis ] [ "method-generic" word-prop <usage-profile> ] bi
-    write-object ;
+: method-counters ( -- alist )
+    all-words [ subwords ] map concat counters ;
 
-: counter. ( obj n -- )
-    [
-        [ [ (profile.) ] with-cell ] dip
-        [ number>string write ] with-cell
-    ] with-row ;
+: profiler-usage ( word -- words )
+    [ smart-usage [ word? ] filter ]
+    [ compiled-generic-usage keys ]
+    [ compiled-usage keys ]
+    tri 3append prune ;
+
+: usage-counters ( word -- alist )
+    profiler-usage counters ;
 
 : counters. ( assoc -- )
-    [ second 0 > ] filter sort-values
     standard-table-style [
-        [ counter. ] assoc-each
+        sort-values simple-table.
     ] tabular-output ;
 
 : profile. ( -- )
@@ -58,19 +64,20 @@ M: method-body (profile.)
     "Call counts for words which call " write
     dup pprint
     ":" print
-    [ smart-usage [ word? ] filter ]
-    [ compiled-generic-usage keys ]
-    [ compiled-usage keys ]
-    tri 3append prune counters counters. ;
+    usage-counters counters. ;
 
 : vocabs-profile. ( -- )
     "Call counts for all vocabularies:" print
-    vocabs [
-        dup words
-        [ "predicating" word-prop not ] filter
-        [ counter>> ] map sum
-    ] { } map>assoc counters. ;
+    vocab-counters counters. ;
+
+: generic-profile. ( -- )
+    "Call counts for methods on generic words:" print
+    generic-counters counters. ;
+
+: class-profile. ( -- )
+    "Call counts for methods on classes:" print
+    class-counters counters. ;
 
 : method-profile. ( -- )
-    all-words [ subwords ] map concat
-    counters counters. ;
+    "Call counts for all methods:" print
+    method-counters counters. ;
diff --git a/basis/tools/test/tools.factor b/basis/tools/test/tools.factor
deleted file mode 100644 (file)
index bf74c1a..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-IN: tools.test.tests
-USING: completion words sequences test ;
-
-[ ] [ "swp" apropos ] unit-test
-[ f ] [ "swp" words-matching empty? ] unit-test
index 508b4a34938703fe4af0e0e6ffbefee0e3cd2575..723c4ac483278da4153c8103d4a095de1ab20697 100644 (file)
@@ -10,7 +10,7 @@ ARTICLE: "vocab-authors" "Vocabulary authors"
 ARTICLE: "vocab-index" "Vocabulary index"
 { $subsection "vocab-tags" }
 { $subsection "vocab-authors" }
-{ $describe-vocab "" } ;
+{ $vocab "" } ;
 
 HELP: words.
 { $values { "vocab" "a vocabulary name" } }
index 7e12a56cf28eb8bdba6fbc0618c82daf71ad8a0a..385d1b2d462bf90522555203d96ca9ada260649c 100644 (file)
@@ -1,4 +1,5 @@
 IN: tools.vocabs.browser.tests
-USING: tools.vocabs.browser tools.test help.markup ;
+USING: tools.vocabs.browser tools.test help.markup help vocabs ;
 
-[ ] [ { $describe-vocab "scratchpad" } print-content ] unit-test
+[ ] [ { $vocab "scratchpad" } print-content ] unit-test
+[ ] [ "classes" vocab print-topic ] unit-test
\ No newline at end of file
index 36f23a8298aa2f6244406db3fbc7a15d8db501e9..3c8ffa5c5b00852d362c59f21bfe6abd39b01445 100644 (file)
@@ -11,42 +11,32 @@ IN: tools.vocabs.browser
 
 : vocab-status-string ( vocab -- string )
     {
-        { [ dup not ] [ drop "" ] }
+        { [ dup vocab not ] [ drop "" ] }
         { [ dup vocab-main ] [ drop "[Runnable]" ] }
         [ drop "[Loaded]" ]
     } cond ;
 
-: write-status ( vocab -- )
-    vocab vocab-status-string write ;
+: vocab-row ( vocab -- row )
+    [ <$link> ] [ vocab-status-string ] [ vocab-summary ] tri
+    3array ;
 
-: vocab. ( vocab -- )
-    [
-        [ [ write-status ] with-cell ]
-        [ [ ($link) ] with-cell ]
-        [ [ vocab-summary write ] with-cell ] tri
-    ] with-row ;
-
-: vocab-headings. ( -- )
-    [
-        [ "State" write ] with-cell
-        [ "Vocabulary" write ] with-cell
-        [ "Summary" write ] with-cell
-    ] with-row ;
+: vocab-headings ( -- headings )
+    {
+        { $strong "Vocabulary" }
+        { $strong "State" }
+        { $strong "Summary" }
+    } ;
 
-: root-heading. ( root -- )
+: root-heading ( root -- )
     [ "Children from " prepend ] [ "Children" ] if*
     $heading ;
 
-: $vocabs ( assoc -- )
+: $vocabs ( seq -- )
+    [ vocab-row ] map vocab-headings prefix $table ;
+
+: $vocab-roots ( assoc -- )
     [
-        [ drop ] [
-            [ root-heading. ]
-            [
-                standard-table-style [
-                    vocab-headings. [ vocab. ] each
-                ] ($grid)
-            ] bi*
-        ] if-empty
+        [ drop ] [ [ root-heading ] [ $vocabs ] bi* ] if-empty
     ] assoc-each ;
 
 TUPLE: vocab-tag name ;
@@ -74,7 +64,7 @@ C: <vocab-author> vocab-author
     ] unless-empty ;
 
 : describe-children ( vocab -- )
-    vocab-name all-child-vocabs $vocabs ;
+    vocab-name all-child-vocabs $vocab-roots ;
 
 : describe-files ( vocab -- )
     vocab-files [ <pathname> ] map [
@@ -94,7 +84,7 @@ C: <vocab-author> vocab-author
         [
             [ <$link> ]
             [ superclass <$link> ]
-            [ "slots" word-prop [ name>> ] map " " join \ $snippet swap 2array ]
+            [ "slots" word-prop [ name>> ] map " " join <$snippet> ]
             tri 3array
         ] map
         { { $strong "Class" } { $strong "Superclass" } { $strong "Slots" } } prefix
@@ -161,24 +151,24 @@ C: <vocab-author> vocab-author
         "Parsing words" $subheading
         [
             [ <$link> ]
-            [ word-syntax dup [ \ $snippet swap 2array ] when ]
+            [ word-syntax dup [ <$snippet> ] when ]
             bi 2array
         ] map
         { { $strong "Word" } { $strong "Syntax" } } prefix
         $table
     ] unless-empty ;
 
+: words-table ( words -- )
+    [
+        [ <$link> ]
+        [ stack-effect dup [ effect>string <$snippet> ] when ]
+        bi 2array
+    ] map
+    { { $strong "Word" } { $strong "Stack effect" } } prefix
+    $table ;
+
 : (describe-words) ( words heading -- )
-    '[
-        _ $subheading
-        [
-            [ <$link> ]
-            [ stack-effect dup [ effect>string \ $snippet swap 2array ] when ]
-            bi 2array
-        ] map
-        { { $strong "Word" } { $strong "Stack effect" } } prefix
-        $table
-    ] unless-empty ;
+    '[ _ $subheading words-table ] unless-empty ;
 
 : describe-generics ( words -- )
     "Generic words" (describe-words) ;
@@ -201,8 +191,8 @@ C: <vocab-author> vocab-author
         [ <$link> 1array ] map $table
     ] unless-empty ;
 
-: describe-words ( vocab -- )
-    words [
+: $words ( words -- )
+    [
         "Words" $heading
 
         natural-sort
@@ -229,7 +219,7 @@ C: <vocab-author> vocab-author
 
 : words. ( vocab -- )
     last-element off
-    vocab-name describe-words ;
+    words $words ;
 
 : describe-metadata ( vocab -- )
     [
@@ -239,11 +229,11 @@ C: <vocab-author> vocab-author
     ] { } make
     [ "Meta-data" $heading $table ] unless-empty ;
 
-: $describe-vocab ( element -- )
+: $vocab ( element -- )
     first {
         [ describe-help ]
         [ describe-metadata ]
-        [ describe-words ]
+        [ words $words ]
         [ describe-files ]
         [ describe-children ]
     } cleave ;
@@ -262,10 +252,10 @@ C: <vocab-author> vocab-author
     [ vocab-authors ] keyed-vocabs ;
 
 : $tagged-vocabs ( element -- )
-    first tagged $vocabs ;
+    first tagged $vocab-roots ;
 
 : $authored-vocabs ( element -- )
-    first authored $vocabs ;
+    first authored $vocab-roots ;
 
 : $all-tags ( element -- )
     drop "Tags" $heading all-tags $tags ;
@@ -282,7 +272,7 @@ M: vocab-spec article-title vocab-name " vocabulary" append ;
 M: vocab-spec article-name vocab-name ;
 
 M: vocab-spec article-content
-    vocab-name \ $describe-vocab swap 2array ;
+    vocab-name \ $vocab swap 2array ;
 
 M: vocab-spec article-parent drop "vocab-index" ;
 
index eaa0953d2571de0babd08ca442d140a5b8cb9595..0486210a677d40a9cc7ad0f1f8c23631abf341a2 100755 (executable)
@@ -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
index 331c0a698cbf3c7c98cb2d648a844c1a6f1f4bc3..15a916716c7722f156252154a7712fcc0daaca2e 100755 (executable)
@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math arrays assocs cocoa cocoa.application
 command-line kernel memory namespaces cocoa.messages
@@ -145,7 +145,7 @@ cocoa-init-hook global [
     [ "MiniFactor.nib" load-nib install-app-delegate ] or
 ] change-at
 
-M: cocoa-ui-backend ui
+M: cocoa-ui-backend (with-ui)
     "UI" assert.app [
         [
             init-clipboard
@@ -160,4 +160,4 @@ M: cocoa-ui-backend ui
 
 cocoa-ui-backend ui-backend set-global
 
-[ running.app? "ui" "listener" ? ] main-vocab-hook set-global
+[ running.app? "ui.tools" "listener" ? ] main-vocab-hook set-global
index a0755e9ec89da647a7566e457e01c9239dcfec20..2c2e0273a81593adf497cdca9b20a7f5869532bd 100644 (file)
@@ -1,10 +1,10 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.syntax cocoa cocoa.nibs cocoa.application
 cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
 core-foundation core-foundation.strings help.topics kernel
 memory namespaces parser system ui ui.tools.browser
-ui.tools.listener ui.tools.workspace ui.cocoa eval locals ;
+ui.tools.listener ui.cocoa eval locals tools.vocabs ;
 IN: ui.cocoa.tools
 
 : finder-run-files ( alien -- )
@@ -28,8 +28,20 @@ CLASS: {
     [ [ 3drop ] dip finder-run-files ]
 }
 
-{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }
-    [ 3drop workspace-window f ]
+{ "factorListener:" "id" { "id" "SEL" "id" }
+    [ 3drop show-listener f ]
+}
+
+{ "factorBrowser:" "id" { "id" "SEL" "id" }
+    [ 3drop show-browser f ]
+}
+
+{ "newFactorListener:" "id" { "id" "SEL" "id" }
+    [ 3drop listener-window f ]
+}
+
+{ "newFactorBrowser:" "id" { "id" "SEL" "id" }
+    [ 3drop browser-window f ]
 }
 
 { "runFactorFile:" "id" { "id" "SEL" "id" }
@@ -44,8 +56,8 @@ CLASS: {
     [ 3drop menu-save-image f ]
 }
 
-{ "showFactorHelp:" "id" { "id" "SEL" "id" }
-    [ 3drop "handbook" com-follow f ]
+{ "refreshAll:" "id" { "id" "SEL" "id" }
+    [ 3drop [ refresh-all ] call-listener f ]
 } ;
 
 : install-app-delegate ( -- )
index f6f5d7dd4d3fc3bd4294f871c5d0286f3af0026e..38018fa720c95db79ca53ac103eb7fd7cc6ed667 100644 (file)
@@ -8,11 +8,17 @@ $nl
 
 HELP: <book>
 { $values { "pages" "a sequence of gadgets" } { "model" model } { "book" book } }
-{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } ". A book shows one child at a time, determined by the value of the model, which must be an integer " } ;
+{ $description "Creates a " { $link book } " control, which contains the gadgets in " { $snippet "pages" } "." } ;
+
+HELP: <empty-book>
+{ $values { "model" model } { "book" book } }
+{ $description "Creates a " { $link book } " control with no children." }
+{ $notes "Children must be added to the book before it is grafted, otherwise an error will be thrown." } ;
 
 ARTICLE: "ui-book-layout" "Book layouts"
-"Books can contain any number of children, and display one child at a time."
+"Books can contain any number of children, and display one child at a time. The currently visible child is determined by the value of the model, which must be an integer."
 { $subsection book }
-{ $subsection <book> } ;
+{ $subsection <book> }
+{ $subsection <empty-book> } ;
 
 ABOUT: "ui-book-layout"
index 4ef90d87b98f518c4f3d642151e96862f8fbc87d..24b91bba9fb89b4a12f9d17f7512a5a1722fc412 100644 (file)
@@ -16,12 +16,15 @@ M: book model-changed ( model book -- )
     dup current-page show-gadget
     relayout ;
 
-: new-book ( pages model class -- book )
+: new-book ( model class -- book )
     new-gadget
-        swap >>model
-        swap add-gadgets ; inline
+        swap >>model ; inline
 
-: <book> ( pages model -- book ) book new-book ;
+: <book> ( pages model -- book )
+    book new-book swap add-gadgets ;
+
+: <empty-book> ( model -- book )
+    book new-book ;
 
 M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
 
index c0274e3b458d16703faae3a2ae92f4c04757a97f..0f9be42d7ba7872ac75d60566aa96844014d2276 100644 (file)
@@ -9,7 +9,7 @@ HELP: <border>
 { $description "Creates a new border around the child with the specified horizontal and vertical gap." } ;
 
 ARTICLE: "ui.gadgets.borders" "Border gadgets"
-"Border gadgets add empty space around a child gadget."
+"The " { $vocab-link "ui.gadgets.borders" } " vocabulary implements border gadgets, which add empty space around a child gadget."
 { $subsection border }
 { $subsection <border> } ;
 
index 086ef2ca81939dbf8434e6a7064e8d1c262fb471..d6878517a13e8a41d09944ecc96e2f289a1a806f 100644 (file)
@@ -55,7 +55,7 @@ HELP: <toolbar>
 { $description "Creates a row of " { $link <command-button> } " gadgets invoking commands on " { $snippet "target" } ". The commands are taken from the " { $snippet "\"toolbar\"" } " command group of each class in " { $snippet "classes" } "." } ;
 
 ARTICLE: "ui.gadgets.buttons" "Button gadgets"
-"Buttons respond to mouse clicks by invoking a quotation."
+"The " { $vocab-link "ui.gadgets.buttons" } " vocabulary implements buttons. Buttons respond to mouse clicks by invoking a quotation."
 { $subsection button }
 "There are many ways to create a new button:"
 { $subsection <button> }
index dabc12d3ae7cda020288f5a768dcf061cbfcdf81..e264dd9aa8a224b76014b755192a82f67918f330 100644 (file)
@@ -199,12 +199,11 @@ M: radio-paint draw-boundary
     GL_LINE_STRIP 0 circle-steps 1+ glDrawArrays ;
 
 :: radio-knob-theme ( gadget -- gadget )
-    [let | radio-paint [ black <radio-paint> ] |
-        gadget
-        f f radio-paint radio-paint <button-paint> >>interior
-        radio-paint >>boundary
-        { 16 16 } >>dim
-    ] ;
+    black <radio-paint> :> radio-paint
+    gadget
+    f f radio-paint radio-paint <button-paint> >>interior
+    radio-paint >>boundary
+    { 16 16 } >>dim ;
 
 : <radio-knob> ( -- gadget )
     <gadget> radio-knob-theme ;
@@ -223,8 +222,8 @@ M: radio-control model-changed
     over value>> = >>selected?
     relayout-1 ;
 
-: <radio-controls> ( assoc model parent quot: ( value model label -- ) -- parent )
-    '[ _ swap _ call add-gadget ] assoc-each ; inline
+: <radio-controls> ( assoc model parent quot: ( value model label -- gadget ) -- parent )
+    '[ _ swap @ add-gadget ] assoc-each ; inline
 
 : radio-button-theme ( gadget -- gadget )
     { 5 5 } >>gap
index d749b8905c02ede603fb5eb5f6c5d0ddd47e6614..0522a6a5224e27d59317c77fcf8bb4bf42491913 100644 (file)
@@ -81,13 +81,15 @@ ARTICLE: "gadgets-editors-selection" "The caret and mark"
 "Use " { $link user-input* } " to change selected text." ;
 
 ARTICLE: "gadgets-editors" "Editor gadgets"
-"An editor edits a multi-line passage of text."
+"The " { $vocab-link "ui.gadgets.editors" } " vocabulary implements editor gadgets. An editor edits a passage of text."
 { $command-map editor "general" }
 { $command-map editor "caret-motion" }
 { $command-map editor "selection" }
+{ $command-map multiline-editor "multiline" }
 { $heading "Editor words" }
 { $subsection editor }
 { $subsection <editor> }
+{ $subsection <multiline-editor> }
 { $subsection editor-string }
 { $subsection set-editor-string }
 { $subsection "gadgets-editors-selection" }
index 274d62ea46564a44a1eb647c146ee4ad3cf580a6..004f2c6e0eefc9c67d55e4f0d8dd8a693c6e15d2 100644 (file)
@@ -8,7 +8,7 @@ IN: ui.gadgets.editors.tests
     <editor> "editor" set
     "editor" get [
         "foo bar" "editor" get set-editor-string
-        "editor" get T{ one-line-elt } select-elt
+        "editor" get one-line-elt select-elt
         "editor" get gadget-selection
     ] with-grafted-gadget
 ] unit-test
@@ -17,7 +17,7 @@ IN: ui.gadgets.editors.tests
     <editor> "editor" set
     "editor" get [
         "foo bar\nbaz quux" "editor" get set-editor-string
-        "editor" get T{ one-line-elt } select-elt
+        "editor" get one-line-elt select-elt
         "editor" get gadget-selection
     ] with-grafted-gadget
 ] unit-test
@@ -43,7 +43,7 @@ IN: ui.gadgets.editors.tests
 
 \ <editor> must-infer
 
-"hello" <model> <field> "field" set
+"hello" <model> <model-field> "field" set
 
 "field" get [
     [ "hello" ] [ "field" get field-model>> value>> ] unit-test
index 67386c180783ccc7d7b881942f039eb22a8e6a88..1c87a4fe0fd7caf1ea232f8e38ea1b2c1d2bff53 100755 (executable)
@@ -1,9 +1,9 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays documents kernel math models
-namespaces locals fry make opengl opengl.gl sequences strings
-io.styles math.vectors sorting colors combinators assocs
-math.order fry calendar alarms ui.clipboards ui.commands
+USING: accessors arrays documents kernel math models namespaces
+locals fry make opengl opengl.gl sequences strings io.styles
+math.vectors sorting colors combinators assocs math.order fry
+calendar alarms continuations ui.clipboards ui.commands
 ui.gadgets ui.gadgets.borders ui.gadgets.buttons
 ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.theme
 ui.gadgets.menus ui.gadgets.wrappers ui.render ui.gestures
@@ -291,9 +291,9 @@ M: editor gadget-text* editor-string % ;
 
 : mouse-elt ( -- element )
     hand-click# get {
-        { 1 T{ one-char-elt } }
-        { 2 T{ one-word-elt } }
-    } at T{ one-line-elt } or ;
+        { 1 one-char-elt }
+        { 2 one-word-elt }
+    } at one-line-elt or ;
 
 : drag-direction? ( loc editor -- ? )
     editor-mark* before? ;
@@ -356,34 +356,34 @@ M: editor gadget-text* editor-string % ;
     [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi
     editor-select ;
 
-: start-of-document ( editor -- ) T{ doc-elt } editor-prev ;
+: start-of-document ( editor -- ) doc-elt editor-prev ;
 
-: end-of-document ( editor -- ) T{ doc-elt } editor-next ;
+: end-of-document ( editor -- ) doc-elt editor-next ;
 
 : position-caret ( editor -- )
-    mouse-elt dup T{ one-char-elt } =
+    mouse-elt dup one-char-elt =
     [ drop dup extend-selection dup mark>> click-loc ]
     [ select-elt ] if ;
 
 : insert-newline ( editor -- ) "\n" swap user-input* drop ;
 
 : delete-next-character ( editor -- ) 
-    T{ char-elt } editor-delete ;
+    char-elt editor-delete ;
 
 : delete-previous-character ( editor -- ) 
-    T{ char-elt } editor-backspace ;
+    char-elt editor-backspace ;
 
 : delete-previous-word ( editor -- ) 
-    T{ word-elt } editor-delete ;
+    word-elt editor-delete ;
 
 : delete-next-word ( editor -- ) 
-    T{ word-elt } editor-backspace ;
+    word-elt editor-backspace ;
 
 : delete-to-start-of-line ( editor -- ) 
-    T{ one-line-elt } editor-delete ;
+    one-line-elt editor-delete ;
 
 : delete-to-end-of-line ( editor -- ) 
-    T{ one-line-elt } editor-backspace ;
+    one-line-elt editor-backspace ;
 
 editor "general" f {
     { T{ key-down f f "DELETE" } delete-next-character }
@@ -415,7 +415,7 @@ editor "clipboard" f {
         dup selection-start/end drop
         over set-caret mark>caret
     ] [
-        T{ char-elt } editor-prev
+        char-elt editor-prev
     ] if ;
 
 : next-character ( editor -- )
@@ -423,27 +423,25 @@ editor "clipboard" f {
         dup selection-start/end nip
         over set-caret mark>caret
     ] [
-        T{ char-elt } editor-next
+        char-elt editor-next
     ] if ;
 
-: previous-line ( editor -- ) T{ line-elt } editor-prev ;
+: previous-line ( editor -- ) line-elt editor-prev ;
 
-: next-line ( editor -- ) T{ line-elt } editor-next ;
+: next-line ( editor -- ) line-elt editor-next ;
 
-: previous-word ( editor -- ) T{ word-elt } editor-prev ;
+: previous-word ( editor -- ) word-elt editor-prev ;
 
-: next-word ( editor -- ) T{ word-elt } editor-next ;
+: next-word ( editor -- ) word-elt editor-next ;
 
-: start-of-line ( editor -- ) T{ one-line-elt } editor-prev ;
+: start-of-line ( editor -- ) one-line-elt editor-prev ;
 
-: end-of-line ( editor -- ) T{ one-line-elt } editor-next ;
+: end-of-line ( editor -- ) one-line-elt editor-next ;
 
 editor "caret-motion" f {
     { T{ button-down } position-caret }
     { T{ key-down f f "LEFT" } previous-character }
     { T{ key-down f f "RIGHT" } next-character }
-    { T{ key-down f f "UP" } previous-line }
-    { T{ key-down f f "DOWN" } next-line }
     { T{ key-down f { C+ } "LEFT" } previous-word }
     { T{ key-down f { C+ } "RIGHT" } next-word }
     { T{ key-down f f "HOME" } start-of-line }
@@ -452,11 +450,15 @@ editor "caret-motion" f {
     { T{ key-down f { C+ } "END" } end-of-document }
 } define-command-map
 
-: select-all ( editor -- ) T{ doc-elt } select-elt ;
+: clear-editor ( editor -- )
+    #! The with-datastack is a kludge to make it infer. Stupid.
+    model>> 1array [ clear-doc ] with-datastack drop ;
+
+: select-all ( editor -- ) doc-elt select-elt ;
 
-: select-line ( editor -- ) T{ one-line-elt } select-elt ;
+: select-line ( editor -- ) one-line-elt select-elt ;
 
-: select-word ( editor -- ) T{ one-word-elt } select-elt ;
+: select-word ( editor -- ) one-word-elt select-elt ;
 
 : selected-word ( editor -- string )
     dup gadget-selection?
@@ -464,34 +466,34 @@ editor "caret-motion" f {
     gadget-selection ;
 
 : select-previous-character ( editor -- ) 
-    T{ char-elt } editor-select-prev ;
+    char-elt editor-select-prev ;
 
 : select-next-character ( editor -- ) 
-    T{ char-elt } editor-select-next ;
+    char-elt editor-select-next ;
 
 : select-previous-line ( editor -- ) 
-    T{ line-elt } editor-select-prev ;
+    line-elt editor-select-prev ;
 
 : select-next-line ( editor -- ) 
-    T{ line-elt } editor-select-next ;
+    line-elt editor-select-next ;
 
 : select-previous-word ( editor -- ) 
-    T{ word-elt } editor-select-prev ;
+    word-elt editor-select-prev ;
 
 : select-next-word ( editor -- ) 
-    T{ word-elt } editor-select-next ;
+    word-elt editor-select-next ;
 
 : select-start-of-line ( editor -- ) 
-    T{ one-line-elt } editor-select-prev ;
+    one-line-elt editor-select-prev ;
 
 : select-end-of-line ( editor -- ) 
-    T{ one-line-elt } editor-select-next ;
+    one-line-elt editor-select-next ;
 
 : select-start-of-document ( editor -- ) 
-    T{ doc-elt } editor-select-prev ;
+    doc-elt editor-select-prev ;
 
 : select-end-of-document ( editor -- ) 
-    T{ doc-elt } editor-select-next ;
+    doc-elt editor-select-next ;
 
 editor "selection" f {
     { T{ button-down f { S+ } 1 } extend-selection }
@@ -503,8 +505,6 @@ editor "selection" f {
     { T{ key-down f { C+ } "l" } select-line }
     { T{ key-down f { S+ } "LEFT" } select-previous-character }
     { T{ key-down f { S+ } "RIGHT" } select-next-character }
-    { T{ key-down f { S+ } "UP" } select-previous-line }
-    { T{ key-down f { S+ } "DOWN" } select-next-line }
     { T{ key-down f { S+ C+ } "LEFT" } select-previous-word }
     { T{ key-down f { S+ C+ } "RIGHT" } select-next-word }
     { T{ key-down f { S+ } "HOME" } select-start-of-line }
@@ -526,7 +526,11 @@ TUPLE: multiline-editor < editor ;
 : <multiline-editor> ( -- editor )
     multiline-editor new-editor ;
 
-multiline-editor "general" f {
+multiline-editor "multiline" f {
+    { T{ key-down f f "UP" } previous-line }
+    { T{ key-down f f "DOWN" } next-line }
+    { T{ key-down f { S+ } "UP" } select-previous-line }
+    { T{ key-down f { S+ } "DOWN" } select-next-line }
     { T{ key-down f f "RET" } insert-newline }
     { T{ key-down f { S+ } "RET" } insert-newline }
     { T{ key-down f f "ENTER" } insert-newline }
@@ -537,8 +541,8 @@ TUPLE: source-editor < multiline-editor ;
 : <source-editor> ( -- editor )
     source-editor new-editor ;
 
-! Fields wrap an editor and edit an external model
-TUPLE: field < wrapper field-model editor ;
+! Fields wrap an editor
+TUPLE: field < wrapper editor min-width max-width ;
 
 : field-theme ( gadget -- gadget )
     gray <solid> >>boundary ; inline
@@ -548,18 +552,45 @@ TUPLE: field < wrapper field-model editor ;
         { 1 0 } >>fill
         field-theme ;
 
-: <field> ( model -- gadget )
-    <editor> dup <field-border> field new-wrapper
-        swap >>editor
-        swap >>field-model ;
+: new-field ( class -- gadget )
+    [ <editor> dup <field-border> ] dip new-wrapper swap >>editor ; inline
 
-M: field graft*
+: column-width ( editor n -- width )
+    [ editor>> editor-font* ] dip CHAR: \s <string> string-width ;
+
+M: field pref-dim*
+    [ call-next-method ]
+    [ dup min-width>> dup [ column-width 0 2array vmax ] [ 2drop ] if ]
+    [ dup max-width>> dup [ column-width 1/0. 2array vmin ] [ 2drop ] if ]
+    tri ;
+
+TUPLE: model-field < field field-model ;
+
+: <model-field> ( model -- gadget )
+    model-field new-field swap >>field-model ;
+
+M: model-field graft*
     [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
     [ dup editor>> model>> add-connection ]
     bi ;
 
-M: field ungraft*
+M: model-field ungraft*
     dup editor>> model>> remove-connection ;
 
-M: field model-changed
+M: model-field model-changed
     nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
+
+TUPLE: action-field < field quot ;
+
+: <action-field> ( quot -- gadget )
+    action-field new-field swap >>quot ;
+
+: invoke-action-field ( field -- )
+    [ editor>> editor-string ]
+    [ editor>> clear-editor ]
+    [ quot>> ]
+    tri call ;
+
+action-field H{
+    { T{ key-down f f "RET" } [ invoke-action-field ] }
+} set-gestures
index 4ad14abfd175b2def24e982247ce73e00e253287..6b7d948ae1325872039b66acda5de637c36a376b 100644 (file)
@@ -24,7 +24,7 @@ HELP: <labelled-pane>
 { <labelled-pane> <pane-control> } related-words
 
 ARTICLE: "ui.gadgets.labelled" "Labelled gadgets"
-"It is possible to create a labelled border around a child gadget:"
+"The " { $vocab-link "ui.gadgets.labelled" } " vocabulary implements labelled borders around child gadgets."
 { $subsection labelled-gadget }
 { $subsection <labelled-gadget> }
 "Or a labelled border with a close box:"
index 8a63900d4d1220b1e1aa12f8528a567100e6296a..ed4278e2cd765b9e6277f0d55432aec886442a43 100644 (file)
@@ -24,7 +24,7 @@ HELP: <label-control>
 { <label> <label-control> } related-words
 
 ARTICLE: "ui.gadgets.labels" "Label gadgets"
-"A label displays a piece of text, either a single line string or an array of line strings."
+"The " { $vocab-link "ui.gadgets.labels" } " vocabulary implements labels. A label displays a piece of text, either a single line string or an array of line strings."
 { $subsection label }
 { $subsection <label> }
 { $subsection <label-control> }
diff --git a/basis/ui/gadgets/lists/authors.txt b/basis/ui/gadgets/lists/authors.txt
deleted file mode 100644 (file)
index 1901f27..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/ui/gadgets/lists/lists-docs.factor b/basis/ui/gadgets/lists/lists-docs.factor
deleted file mode 100644 (file)
index 6341e09..0000000
+++ /dev/null
@@ -1,32 +0,0 @@
-USING: ui.commands help.markup help.syntax ui.gadgets
-ui.gadgets.presentations ui.operations kernel models classes ;
-IN: ui.gadgets.lists
-
-HELP: +secondary+
-{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when " { $snippet "RET" } " is pressed in a " { $link list } " gadget where the current selection is a presentation matching the operation's predicate." } ;
-
-HELP: list
-{ $class-description
-    "A list control is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
-    $nl
-    "Lists are created by calling " { $link <list> } "."
-    { $command-map list "keyboard-navigation" }
-} ;
-
-HELP: <list>
-{ $values { "hook" { $quotation "( list -- )" } } { "presenter" { $quotation "( object -- label )" } } { "model" model } { "gadget" list } }
-{ $description "Creates a new " { $link list } "."
-$nl
-"The model value must be a sequence. The list displays presentations of elements with labels obtained by applying the " { $snippet "presenter" } " quotation to each object. The " { $snippet "hook" } " quotation is called when a presentation is selected." } ;
-
-HELP: list-value
-{ $values { "list" list } { "object" object } }
-{ $description "Outputs the currently selected list value." } ;
-
-ARTICLE: "ui.gadgets.lists" "List gadgets"
-"A list displays a list of presentations."
-{ $subsection list }
-{ $subsection <list> }
-{ $subsection list-value } ;
-
-ABOUT: "ui.gadgets.lists"
diff --git a/basis/ui/gadgets/lists/lists-tests.factor b/basis/ui/gadgets/lists/lists-tests.factor
deleted file mode 100644 (file)
index bf2ad72..0000000
+++ /dev/null
@@ -1,5 +0,0 @@
-IN: ui.gadgets.lists.tests
-USING: ui.gadgets.lists models prettyprint math tools.test
-kernel ;
-
-[ ] [ [ drop ] [ 3 + . ] f <model> <list> invoke-value-action ] unit-test
diff --git a/basis/ui/gadgets/lists/lists.factor b/basis/ui/gadgets/lists/lists.factor
deleted file mode 100644 (file)
index 0113e19..0000000
+++ /dev/null
@@ -1,130 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ui.commands ui.gestures ui.render ui.gadgets
-ui.gadgets.labels ui.gadgets.scrollers
-kernel sequences models opengl math math.order namespaces
-ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
-math.vectors classes.tuple math.geometry.rect colors ;
-
-IN: ui.gadgets.lists
-
-TUPLE: list < pack index presenter color hook ;
-
-: list-theme ( list -- list )
-    T{ rgba f 0.8 0.8 1.0 1.0 } >>color ; inline
-
-: <list> ( hook presenter model -- gadget )
-    list new-gadget
-        { 0 1 } >>orientation
-        1 >>fill
-        0 >>index
-        swap >>model
-        swap >>presenter
-        swap >>hook
-        list-theme ;
-
-: calc-bounded-index ( n list -- m )
-    control-value length 1- min 0 max ;
-
-: bound-index ( list -- )
-    dup index>> over calc-bounded-index >>index drop ;
-
-: list-presentation-hook ( list -- quot )
-    hook>> [ [ list? ] find-parent ] prepend ;
-
-: <list-presentation> ( hook elt presenter -- gadget )
-    keep [ >label text-theme ] dip
-    <presentation>
-    swap >>hook ; inline
-
-: <list-items> ( list -- seq )
-    [ list-presentation-hook ]
-    [ presenter>> ]
-    [ control-value ]
-    tri [
-        [ 2dup ] dip swap <list-presentation>
-    ] map 2nip ;
-
-M: list model-changed
-    nip
-    dup clear-gadget
-    dup <list-items> add-gadgets
-    bound-index ;
-
-: selected-rect ( list -- rect )
-    dup index>> swap children>> ?nth ;
-
-M: list draw-gadget*
-    origin get [
-        dup color>> gl-color
-        selected-rect [
-            dup loc>> [
-                dim>> gl-fill-rect
-            ] with-translation
-        ] when*
-    ] with-translation ;
-
-M: list focusable-child* drop t ;
-
-: list-value ( list -- object )
-    dup index>> swap control-value ?nth ;
-
-: scroll>selected ( list -- )
-    #! We change the rectangle's width to zero to avoid
-    #! scrolling right.
-    [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
-    scroll>rect ;
-
-: list-empty? ( list -- ? ) control-value empty? ;
-
-: select-index ( n list -- )
-    dup list-empty? [
-        2drop
-    ] [
-        [ control-value length rem ] keep
-        swap >>index
-        dup relayout-1
-        scroll>selected
-    ] if ;
-
-: select-previous ( list -- )
-    dup index>> 1- swap select-index ;
-
-: select-next ( list -- )
-    dup index>> 1+ swap select-index ;
-
-: invoke-value-action ( list -- )
-    dup list-empty? [
-        dup hook>> call
-    ] [
-        dup index>> swap nth-gadget invoke-secondary
-    ] if ;
-
-: select-gadget ( gadget list -- )
-    tuck children>> index
-    [ swap select-index ] [ drop ] if* ;
-
-: clamp-loc ( point max -- point )
-    vmin { 0 0 } vmax ;
-
-: select-at ( point list -- )
-    [ rect-dim clamp-loc ] keep
-    [ pick-up ] keep
-    select-gadget ;
-
-: list-page ( list vec -- )
-    [ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
-    v* v+ swap select-at ;
-
-: list-page-up ( list -- ) { 0 -1 } list-page ;
-
-: list-page-down ( list -- ) { 0 1 } list-page ;
-
-list "keyboard-navigation" "Lists can be navigated from the keyboard." {
-    { T{ button-down } request-focus }
-    { T{ key-down f f "UP" } select-previous }
-    { T{ key-down f f "DOWN" } select-next }
-    { T{ key-down f f "PAGE_UP" } list-page-up }
-    { T{ key-down f f "PAGE_DOWN" } list-page-down }
-    { T{ key-down f f "RET" } invoke-value-action }
-} define-command-map
diff --git a/basis/ui/gadgets/lists/summary.txt b/basis/ui/gadgets/lists/summary.txt
deleted file mode 100644 (file)
index f0b84e7..0000000
+++ /dev/null
@@ -1 +0,0 @@
-List gadgets display a keyboard-navigatable list of presentations
index 23dc99da82124b3d0305f6d075ab7fb94c7e3d97..6718f9b7d80302a94a8c15c89f9a3d756e3a65a0 100644 (file)
@@ -56,7 +56,7 @@ HELP: <pane-stream>
 { with-pane make-pane } related-words
 
 ARTICLE: "ui.gadgets.panes" "Pane gadgets"
-"A pane displays formatted text."
+"The " { $vocab-link "ui.gadgets.panes" } " vocabulary implements panes, which display formatted text."
 { $subsection pane }
 { $subsection <pane> }
 { $subsection <scrolling-pane> }
index 8627f7fbfe2b72f0b560f0507f7b0095c8d700ce..1c5123703504fd55ec43be1e6942ae77540c27a1 100644 (file)
@@ -2,7 +2,7 @@ USING: alien ui.gadgets.panes ui.gadgets namespaces
 kernel sequences io io.styles io.streams.string tools.test
 prettyprint definitions help help.syntax help.markup
 help.stylesheet splitting tools.test.ui models math summary
-inspector accessors ;
+inspector accessors help.topics ;
 IN: ui.gadgets.panes.tests
 
 : #children "pane" get children>> length ;
@@ -79,6 +79,14 @@ IN: ui.gadgets.panes.tests
     ] test-gadget-text
 ] unit-test
 
+[ t ] [
+    [
+        last-element off
+        \ = >link $title
+        "Hello world" print-content
+    ] test-gadget-text
+] unit-test
+
 ARTICLE: "test-article-1" "This is a test article"
 "Hello world, how are you today." ;
 
index efdd54bcc7b8b18c601964ef299e7df4e1c350c2..e7e02bf54d482d4231c310b20df414d2e64fbcf3 100644 (file)
@@ -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 ;
index 005fa1e7fe61b6a75732dd01508ee0d2824a41b6..88eb66129d2d0cb4c32b8164fbb0c5c3eeb9a80f 100644 (file)
@@ -42,9 +42,10 @@ HELP: show-mouse-help
 { $description "Displays a " { $link summary } " of the " { $snippet "object" } "in the status bar of the " { $link world } " containing this presentation. This word is executed when the mouse enters the presentation." } ;
 
 ARTICLE: "ui.gadgets.presentations" "Presentation gadgets"
-"Outliner gadgets are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (" { $link "presentations" } ")."
+"The " { $vocab-link "ui.gadgets.presentations" } " vocabulary implements presentations, which are graphical representations of an object, associated with the object itself (see " { $link "ui-operations" } ")."
+$nl
+"Clicking a presentation with the left mouse button invokes the object's primary operation, and clicking with the right mouse button displays a menu of all applicable operations. Presentations are usually not constructed directly, and instead are written to " { $link "ui.gadgets.panes" } " with formatted stream output words (see " { $link "presentations" } ")."
 { $subsection presentation }
-{ $subsection <presentation> }
-"Presentations remember the object they are presenting; operations can be performed on the presented object. See " { $link "ui-operations" } "." ;
+{ $subsection <presentation> } ;
 
 ABOUT: "ui.gadgets.presentations"
index b248527c37db4629c2f8bab8c3a7a4ddf143bc78..b6e0c6691b0e6a0e816525d245cbf03a0f79c6ee 100644 (file)
@@ -44,7 +44,7 @@ HELP: scroll>top
 { $description "Ensures that any scroller containing " { $snippet "gadget" } " is scrolled all the way up. If no parent of " { $snippet "scroller" } " is a gadget, does nothing." } ;
 
 ARTICLE: "ui.gadgets.scrollers" "Scroller gadgets"
-"A scroller displays a gadget which is larger than the visible area."
+"The " { $vocab-link "ui.gadgets.scrollers" } " vocabulary implements scroller gadgets. A scroller displays a gadget which is larger than the visible area."
 { $subsection scroller }
 { $subsection <scroller> }
 "Getting and setting the scroll position:"
diff --git a/basis/ui/gadgets/search-tables/search-tables.factor b/basis/ui/gadgets/search-tables/search-tables.factor
new file mode 100644 (file)
index 0000000..5ac7f6b
--- /dev/null
@@ -0,0 +1,47 @@
+! Copyright (C) 2008, 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel delegate fry sequences
+models models.search models.delay calendar locals
+ui.gadgets.editors ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.tables ui.gadgets.tracks ui.gadgets.borders
+ui.gadgets.buttons ;
+IN: ui.gadgets.search-tables
+
+TUPLE: search-field < track field ;
+
+: clear-search-field ( search-field -- )
+    field>> editor>> clear-editor ;
+
+: <clear-button> ( search-field -- button )
+    "X" swap '[ drop _ clear-search-field ] <roll-button> ;
+
+: <search-field> ( model -- gadget )
+    { 1 0 } search-field new-track
+        { 5 5 } >>gap
+        "Search:" <label> f track-add
+        swap <model-field> 10 >>min-width >>field
+        dup field>> 1 track-add
+        dup <clear-button> f track-add ;
+
+TUPLE: search-table < track table field ;
+
+! We don't want to delegate all slots, just a few setters
+PROTOCOL: table-protocol
+renderer>> (>>renderer)
+filled-column>> (>>filled-column)
+selected-value>> (>>selected-value)
+column-alignment>> (>>column-alignment) ;
+
+CONSULT: table-protocol search-table table>> ;
+
+:: <search-table> ( values quot -- gadget )
+    f <model> :> search
+    { 0 1 } search-table new-track
+        values >>model
+        search <search-field> >>field
+        dup field>> 2 <filled-border> f track-add
+        values search 500 milliseconds <delay> quot <search> <table> >>table
+        dup table>> <scroller> 1 track-add ;
+
+M: search-table model-changed
+    nip field>> clear-search-field ;
\ No newline at end of file
index c130c724d0eef790829c7ecee21eb6698d03d2de..6f107b4e423ad1081794a4f731b4ec508d46471b 100644 (file)
@@ -48,7 +48,7 @@ HELP: <y-slider>
 { <x-slider> <y-slider> } related-words
 
 ARTICLE: "ui.gadgets.sliders" "Slider gadgets"
-"A slider allows the user to graphically manipulate a value by moving a thumb back and forth."
+"The " { $vocab-link "ui.gadgets.sliders" } " vocabulary implements slider gadgets. A slider allows the user to graphically manipulate a value by moving a thumb back and forth."
 { $subsection slider }
 { $subsection <x-slider> }
 { $subsection <y-slider> }
index e04b288a5d747feb9eaae7c0f6a8173c94a0ccfc..305f8f2b26fa300be4e94ff5ab53cae46201d4f0 100644 (file)
@@ -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
-
-: <slot-editor> ( ref -- gadget )
+: <slot-editor> ( close-hook update-hook 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 ;
diff --git a/basis/ui/gadgets/tabbed/tabbed.factor b/basis/ui/gadgets/tabbed/tabbed.factor
new file mode 100644 (file)
index 0000000..92bf24b
--- /dev/null
@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.books
+ui.gadgets.packs ui.gadgets sequences models accessors kernel ;
+IN: ui.gadgets.tabbed
+
+TUPLE: tabbed-gadget < track tabs book ;
+
+: <tabbed-gadget> ( -- gadget )
+    { 0 1 } tabbed-gadget new-track
+        0 <model> >>model
+        <shelf> >>tabs
+        dup tabs>> f track-add
+        dup model>> <empty-book> >>book
+        dup book>> 1 track-add ;
+
+: add-tab/book ( tabbed child -- tabbed )
+    [ dup book>> ] dip add-gadget drop ;
+
+: add-tab/button ( tabbed label -- tabbed )
+    [ [ dup tabs>> dup children>> length ] [ model>> ] bi ] dip
+    <toggle-button> add-gadget drop ;
+
+: add-tab ( tabbed child label -- tabbed )
+    [ add-tab/book ] [ add-tab/button ] bi* ;
diff --git a/basis/ui/gadgets/tables/tables-docs.factor b/basis/ui/gadgets/tables/tables-docs.factor
new file mode 100644 (file)
index 0000000..b499faa
--- /dev/null
@@ -0,0 +1,10 @@
+USING: help.markup help.syntax ;
+IN: ui.gadgets.tables
+
+ARTICLE: "ui.gadgets.tables" "Table gadgets"
+"The " { $vocab-link "ui.gadgets.tables" } " vocabulary implements table gadgets. Table gadgets display a grid of values, with each row's columns generated by a renderer object."
+{ $subsection table }
+"Creating new tables:"
+{ $subsection <table> } ;
+
+ABOUT: "ui.gadgets.tables"
\ No newline at end of file
diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor
new file mode 100644 (file)
index 0000000..dce47fc
--- /dev/null
@@ -0,0 +1,295 @@
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors fry io.styles kernel math
+math.geometry.rect math.order math.vectors namespaces opengl
+sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar
+ui.gadgets.worlds ui.gadgets.theme ui.gestures ui.render
+ui.gadgets.menus models math.ranges sequences combinators ;
+IN: ui.gadgets.tables
+
+! Row rendererer protocol
+GENERIC: row-columns ( row renderer -- columns )
+GENERIC: row-value ( row renderer -- object )
+
+SINGLETON: trivial-renderer
+
+M: trivial-renderer row-columns drop ;
+M: object row-value drop ;
+
+TUPLE: table < gadget
+renderer filled-column column-alignment action
+column-widths total-width
+font text-color selection-color mouse-color column-line-color
+selected-index selected-value
+mouse-index
+focused? ;
+
+: <table> ( rows -- table )
+    table new-gadget
+        swap >>model
+        trivial-renderer >>renderer
+        [ drop ] >>action
+        f <model> >>selected-value
+        sans-serif-font >>font
+        selection-color >>selection-color
+        dark-gray >>column-line-color
+        black >>mouse-color
+        black >>text-color ;
+
+<PRIVATE
+
+: line-height ( table -- n )
+    font>> open-font "" string-height ;
+
+CONSTANT: table-gap 5
+
+: table-rows ( table -- rows )
+    [ control-value ] [ renderer>> ] bi '[ _ row-columns ] map ;
+
+: column-offsets ( table -- xs )
+    0 [ table-gap + + ] accumulate nip ;
+
+: (compute-column-widths) ( font rows -- total widths )
+    [ drop 0 { } ] [
+        tuck [ first length 0 <repetition> ] 2dip
+        [ [ string-width ] with map vmax ] with each
+        [ [ sum ] [ length 1 [-] table-gap * ] bi + ] keep
+    ] if-empty ;
+
+: compute-column-widths ( table -- total-width column-widths )
+    [ font>> open-font ] [ table-rows ] bi (compute-column-widths) ;
+
+: update-cached-widths ( table -- )
+    dup compute-column-widths
+    [ >>total-width ] [ >>column-widths ] bi*
+    drop ;
+
+: filled-column-width ( table -- n )
+    [ dim>> first ] [ total-width>> ] bi [-] ;
+
+: update-filled-column ( table -- )
+    [ filled-column-width ]
+    [ filled-column>> ]
+    [ column-widths>> ] tri
+    2dup empty? not and
+    [ [ + ] change-nth ] [ 3drop ] if ;
+
+M: table layout*
+    [ update-cached-widths ] [ update-filled-column ] bi ;
+
+: row-rect ( table row -- rect )
+    [ [ line-height ] dip * 0 swap 2array ]
+    [ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
+
+: highlight-row ( table row color filled? -- )
+    [ dup ] 2dip '[
+        _ gl-color
+        row-rect rect-bounds swap [
+            _ [ gl-fill-rect ] [ gl-rect ] if
+        ] with-translation
+    ] [ 2drop ] if ;
+
+: draw-selected ( table -- )
+    {
+        [ ]
+        [ selected-index>> ]
+        [ selection-color>> ]
+        [ focused?>> ]
+    } cleave
+    highlight-row ;
+
+: draw-moused ( table -- )
+    [ ] [ mouse-index>> ] [ mouse-color>> ] tri f highlight-row ;
+
+: column-lines ( widths -- xs )
+    0 [ + ] accumulate nip rest-slice ; inline
+
+: draw-columns ( table -- )
+    [ column-line-color>> gl-color ]
+    [
+        [ column-widths>> column-lines ] [ dim>> second ] bi
+        '[ [ 0 2array ] [ _ 2array ] bi gl-line ] each
+    ] bi ;
+
+: y>row ( y table -- n )
+    line-height /i ;
+
+: validate-row ( m table -- n )
+    control-value length 1- min 0 max ;
+
+: visible-row ( table quot -- n )
+    '[
+        [ clip get @ origin get [ second ] bi@ - ] dip
+        y>row
+    ] keep validate-row ; inline
+
+: first-visible-row ( table -- n )
+    [ loc>> ] visible-row ;
+
+: last-visible-row ( table -- n )
+    [ rect-extent nip ] visible-row 1+ ;
+
+: column-loc ( font column width align -- loc )
+    [ [ [ open-font ] dip string-width ] dip swap - ] dip
+    * 0 2array ;
+
+: draw-column ( font column width align -- )
+    over [
+        [ 2dup ] 2dip column-loc draw-string
+    ] dip table-gap + 0 2array gl-translate ;
+
+: draw-row ( columns widths align font -- )
+    '[ [ _ ] 3dip draw-column ] 3each ;
+
+: each-slice-index ( from to seq quot -- )
+    [ [ <slice> ] [ drop [a,b) ] 3bi ] dip 2each ; inline
+
+: column-alignment ( table -- seq )
+    dup column-alignment>>
+    [ ] [ column-widths>> length 0 <repetition> ] ?if ;
+
+: draw-rows ( table -- )
+    {
+        [ text-color>> gl-color ]
+        [ first-visible-row ]
+        [ last-visible-row ]
+        [ control-value ]
+        [ line-height ]
+        [ renderer>> ]
+        [ column-widths>> ]
+        [ column-alignment ]
+        [ font>> ]
+    } cleave '[
+        [ 0 ] dip _ * 2array [
+            _ row-columns _ _ _ draw-row
+        ] with-translation
+    ] each-slice-index ;
+
+M: table draw-gadget*
+    dup control-value empty? [ drop ] [
+        origin get [
+            {
+                [ draw-selected ]
+                [ draw-columns ]
+                [ draw-moused ]
+                [ draw-rows ]
+            } cleave
+        ] with-translation
+    ] if ;
+
+M: table pref-dim*
+    [ compute-column-widths drop ] keep
+    [ font>> open-font "" string-height ]
+    [ control-value length ]
+    bi * 2array ;
+
+: nth-row ( row table -- value/f ? )
+    over [ control-value nth t ] [ 2drop f f ] 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 ;
+
+<PRIVATE
+
+: update-selected-value ( table -- )
+    [ selected-row drop ] [ selected-value>> ] bi set-model ;
+
+M: table model-changed
+    nip
+    [ f >>selected-index update-selected-value ]
+    [ relayout ]
+    bi ;
+
+: thin-row-rect ( table row -- rect )
+    row-rect [ { 0 1 } v* ] change-dim ;
+
+: (select-row) ( table row -- )
+    over validate-row
+    [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ]
+    [ >>selected-index relayout-1 ]
+    2bi ;
+
+: mouse-row ( table -- n )
+    [ hand-rel second ] keep y>row ;
+
+: table-button-down ( table -- )
+    dup request-focus
+    dup control-value empty? [ drop ] [
+        dup [ mouse-row ] keep validate-row
+        [ >>mouse-index ] [ (select-row) ] bi
+    ] if ;
+
+: row-action ( table -- )
+    dup selected-row [ swap action>> call ] [ 2drop ] if ;
+
+: table-button-up ( table -- )
+    hand-click# get 2 =
+    [ row-action ] [ update-selected-value ] if ;
+
+: select-row ( table row -- )
+    [ (select-row) ] [ drop update-selected-value ] 2bi ;
+
+: prev-row ( table -- )
+    dup selected-index>> [ 1- ] [ 0 ] if* select-row ;
+
+: next-row ( table -- )
+    dup selected-index>> [ 1+ ] [ 0 ] if* select-row ;
+
+: first-row ( table -- )
+    0 select-row ;
+
+: last-row ( table -- )
+    dup control-value length 1- select-row ;
+
+: hide-mouse-help ( table -- )
+    f >>mouse-index [ hide-status ] [ relayout-1 ] bi ;
+
+: valid-row? ( row table -- ? )
+    control-value length 1- 0 swap between? ;
+
+: show-row-summary ( row table -- )
+    [ renderer>> row-value ] keep show-summary ;
+
+: if-mouse-row ( table true false -- )
+    [ [ mouse-row ] keep 2dup valid-row? ]
+    [ ] [ '[ nip @ ] ] tri* if ; inline
+
+: show-mouse-help ( table -- )
+    [
+        [ swap >>mouse-index relayout-1 ]
+        [
+            [ nth-row ] keep
+            swap [ show-row-summary ] [ 2drop ] if
+        ] 2bi
+    ] [ hide-mouse-help ] if-mouse-row ;
+
+: table-operations-menu ( table -- )
+    [
+        [ nth-row drop ] keep [ renderer>> row-value ] keep
+        swap show-operations-menu
+    ] [ drop ] if-mouse-row ;
+
+table H{
+    { T{ mouse-enter } [ show-mouse-help ] }
+    { T{ mouse-leave } [ hide-mouse-help ] }
+    { T{ motion } [ show-mouse-help ] }
+    { T{ button-down } [ table-button-down ] }
+    { T{ button-down f f 3 } [ table-operations-menu ] }
+    { T{ button-up } [ table-button-up ] }
+    { T{ gain-focus } [ t >>focused? drop ] }
+    { T{ lose-focus } [ f >>focused? drop ] }
+    { T{ drag } [ table-button-down ] }
+    { T{ key-down f f "RET" } [ row-action ] }
+    { T{ key-down f f "UP" } [ prev-row ] }
+    { T{ key-down f f "DOWN" } [ next-row ] }
+    { T{ key-down f f "HOME" } [ first-row ] }
+    { T{ key-down f f "END" } [ last-row ] }
+} set-gestures
+
+PRIVATE>
\ No newline at end of file
diff --git a/basis/ui/tools/browser/browser-docs.factor b/basis/ui/tools/browser/browser-docs.factor
new file mode 100644 (file)
index 0000000..f3d9463
--- /dev/null
@@ -0,0 +1,14 @@
+USING: help.markup help.syntax ui.commands ;
+IN: ui.tools.browser
+
+ARTICLE: "ui-browser" "UI browser"
+"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or articlelink presentation is clicked. It can also be opened using words:"
+{ $subsection com-follow }
+{ $subsection browser-window }
+{ $command-map browser-gadget "toolbar" }
+{ $command-map browser-gadget "scrolling" }
+{ $command-map browser-gadget "navigation" }
+{ $command-map browser-gadget "multi-touch" }
+"Browsers are instances of " { $link browser-gadget } "." ;
+
+ABOUT: "ui-browser"
\ No newline at end of file
index f56f5bcc4e51ff2e3b7e519b61b015f6cf2e73e8..7477edbe6a713499bc603588c352ead84926abe1 100644 (file)
@@ -1,5 +1,5 @@
 IN: ui.tools.browser.tests
-USING: tools.test tools.test.ui ui.tools.browser ;
+USING: tools.test tools.test.ui ui.tools.browser math ;
 
 \ <browser-gadget> must-infer
-[ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test
+[ ] [ \ + <browser-gadget> [ ] with-grafted-gadget ] unit-test
index becb401fa618e234a01f11548d4e956e8b126538..82aef92158c164c6e571340d0d2292904ee872da 100644 (file)
@@ -1,35 +1,48 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: debugger ui.tools.workspace help help.topics kernel
-models models.history ui.commands ui.gadgets ui.gadgets.panes
-ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons compiler.units assocs words vocabs
-accessors fry combinators.short-circuit ;
+USING: debugger help help.topics help.crossref kernel models compiler.units
+assocs words vocabs accessors fry combinators.short-circuit
+sequences models models.history tools.apropos
+ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
+ui.gadgets.tracks ui.gestures ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.editors ui.gadgets.labels ui.gadgets.status-bar
+ui.tools.common ui ;
 IN: ui.tools.browser
 
-TUPLE: browser-gadget < track pane history ;
+TUPLE: browser-gadget < tool pane scroller search-field ;
 
-: show-help ( link help -- )
-    history>> dup add-history
+{ 550 400 } browser-gadget set-tool-dim
+
+: show-help ( link browser-gadget -- )
+    model>> dup add-history
     [ >link ] dip set-model ;
 
 : <help-pane> ( browser-gadget -- gadget )
-    history>> [ '[ _ print-topic ] try ] <pane-control> ;
+    model>> [ '[ _ print-topic ] try ] <pane-control> ;
 
-: init-history ( browser-gadget -- )
-    "handbook" >link <history> >>history drop ;
+: search-browser ( string browser -- )
+    '[ <apropos> _ show-help ] unless-empty ;
 
-: <browser-gadget> ( -- gadget )
-    { 0 1 } browser-gadget new-track
-        dup init-history
-        add-toolbar
-        dup <help-pane> >>pane
-        dup pane>> <scroller> 1 track-add ;
+: <search-field> ( browser -- field )
+    '[ _ search-browser ] <action-field>
+        10 >>min-width
+        10 >>max-width ;
 
-M: browser-gadget call-tool* show-help ;
+: <browser-toolbar> ( browser -- toolbar )
+    <shelf>
+        { 5 5 } >>gap
+        over <toolbar> add-gadget
+        "Search:" <label> add-gadget
+        swap search-field>> add-gadget ;
 
-M: browser-gadget tool-scroller
-    pane>> find-scroller ;
+: <browser-gadget> ( link -- gadget )
+    { 0 1 } browser-gadget new-track
+        swap >link <history> >>model
+        dup <search-field> >>search-field
+        dup <browser-toolbar> f track-add
+        dup <help-pane> >>pane
+        dup pane>> <scroller> >>scroller
+        dup scroller>> 1 track-add ;
 
 M: browser-gadget graft*
     [ add-definition-observer ] [ call-next-method ] bi ;
@@ -45,24 +58,35 @@ M: browser-gadget ungraft*
     } 2|| ;
 
 M: browser-gadget definitions-changed ( assoc browser -- )
-    history>>
-    dup value>> rot showing-definition?
+    model>> tuck value>> swap showing-definition?
     [ notify-connections ] [ drop ] if ;
 
-: help-action ( browser-gadget -- link )
-    history>> value>> >link ;
+M: browser-gadget focusable-child* search-field>> ;
 
-: com-follow ( link -- ) browser-gadget call-tool ;
+: (browser-window) ( topic -- )
+    <browser-gadget> "Browser" open-status-window ;
 
-: com-back ( browser -- ) history>> go-back ;
+: browser-window ( -- )
+    "handbook" (browser-window) ;
 
-: com-forward ( browser -- ) history>> go-forward ;
+\ browser-window H{ { +nullary+ t } } define-command
 
-: com-documentation ( browser -- ) "handbook" swap show-help ;
+: com-follow ( link -- )
+    [ browser-gadget? ] find-window
+    [ [ raise-window ] [ gadget-child show-help ] bi ]
+    [ (browser-window) ] if* ;
 
-: com-vocabularies ( browser -- ) "vocab-index" swap show-help ;
+: show-browser ( -- ) "handbook" com-follow ;
+
+\ show-browser H{ { +nullary+ t } } define-command
+
+: com-back ( browser -- ) model>> go-back ;
+
+: com-forward ( browser -- ) model>> go-forward ;
+
+: com-documentation ( browser -- ) "handbook" swap show-help ;
 
-: browser-help ( -- ) "ui-browser" help-window ;
+: browser-help ( -- ) "ui-browser" com-follow ;
 
 \ browser-help H{ { +nullary+ t } } define-command
 
@@ -70,11 +94,39 @@ browser-gadget "toolbar" f {
     { T{ key-down f { A+ } "LEFT" } com-back }
     { T{ key-down f { A+ } "RIGHT" } com-forward }
     { f com-documentation }
-    { f com-vocabularies }
     { T{ key-down f f "F1" } browser-help }
 } define-command-map
 
+: ?show-help ( link browser -- )
+    over [ show-help ] [ 2drop ] if ;
+
+: navigate ( browser quot -- )
+    '[ control-value @ ] keep ?show-help ;
+
+: com-up ( browser -- ) [ article-parent ] navigate ;
+
+: com-prev ( browser -- ) [ prev-article ] navigate ;
+
+: com-next ( browser -- ) [ next-article ] navigate ;
+
+browser-gadget "navigation" "Commands for navigating in the article hierarchy" {
+    { T{ key-down f { A+ } "u" } com-up }
+    { T{ key-down f { A+ } "p" } com-prev }
+    { T{ key-down f { A+ } "n" } com-next }
+} define-command-map
+
 browser-gadget "multi-touch" f {
     { T{ left-action } com-back }
     { T{ right-action } com-forward }
 } define-command-map
+
+browser-gadget "scrolling"
+"The browser's scroller can be scrolled from the keyboard."
+{
+    { T{ key-down f f "UP" } com-scroll-up }
+    { T{ key-down f f "DOWN" } com-scroll-down }
+    { T{ key-down f f "PAGE_UP" } com-page-up }
+    { T{ key-down f f "PAGE_DOWN" } com-page-down }
+} define-command-map
+
+MAIN: browser-window
\ No newline at end of file
diff --git a/basis/ui/tools/common/common.factor b/basis/ui/tools/common/common.factor
new file mode 100644 (file)
index 0000000..6d40acb
--- /dev/null
@@ -0,0 +1,35 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs classes classes.mixin kernel namespaces
+parser ui.gadgets ui.gadgets.scrollers ui.gadgets.tracks ;
+IN: ui.tools.common
+
+SYMBOL: tool-dims
+
+tool-dims global [ H{ } clone or ] change-at
+
+TUPLE: tool < track ;
+
+M: tool pref-dim*
+    class tool-dims get at ;
+
+M: tool layout*
+    [ call-next-method ]
+    [ [ dim>> ] [ class ] bi tool-dims get set-at ]
+    bi ;
+
+: set-tool-dim ( dim class -- ) tool-dims get set-at ;
+
+SLOT: scroller
+
+: com-page-up ( tool -- )
+    scroller>> scroll-up-page ;
+
+: com-page-down ( tool -- )
+    scroller>> scroll-down-page ;
+
+: com-scroll-up ( tool -- )
+    scroller>> scroll-up-line ;
+
+: com-scroll-down ( tool -- )
+    scroller>> scroll-down-line ;
index 38db81c3dc26e5664f741e905c170fc514c69de4..b7fa846ef2dc0ec51a9a618c5de1b1115ceffe50 100644 (file)
@@ -1,17 +1,18 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ui.gadgets colors kernel ui.render namespaces models
-models.mapping sequences ui.gadgets.buttons ui.gadgets.packs
-ui.gadgets.labels tools.deploy.config tools.deploy.config.editor
-namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
+USING: colors kernel namespaces models tools.deploy.config
+tools.deploy.config.editor tools.deploy vocabs
+namespaces models.mapping sequences system accessors fry
+ui.gadgets ui.render ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.labels ui.gadgets.editors ui.gadgets.borders ui.gestures
 ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
-tools.deploy vocabs ui.tools.workspace system accessors fry ;
+ui.tools.browser ;
 IN: ui.tools.deploy
 
 TUPLE: deploy-gadget < pack vocab settings ;
 
 : bundle-name ( parent -- parent )
-    deploy-name get <field>
+    deploy-name get <model-field>
     "Executable name:" label-on-left add-gadget ;
 
 : deploy-ui ( parent -- parent )
@@ -81,7 +82,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
     close-window ;
 
 : com-help ( -- )
-    "ui.tools.deploy" help-window ;
+    "ui.tools.deploy" com-follow ;
 
 \ com-help H{
     { +nullary+ t }
diff --git a/basis/ui/tools/inspector/inspector-docs.factor b/basis/ui/tools/inspector/inspector-docs.factor
new file mode 100644 (file)
index 0000000..af20462
--- /dev/null
@@ -0,0 +1,26 @@
+USING: help.markup help.syntax ui.commands ui.gadgets.slots
+ui.gadgets.editors ;
+IN: ui.tools.inspector
+
+ARTICLE: "ui-inspector-edit" "Editing slot values in the inspector"
+"Slot values can be edited in the inspector. Clicking the ellipsis to the left of the slot's textual representation displays a slot editor gadget. A text representation of the object can be edited in the slot editor. The parser is used to turn the text representation back into an object. Keep in mind that some structure is lost in the conversion; see " { $link "prettyprint-limitations" } "."
+$nl
+"The slot editor's text editing commands are standard; see " { $link "gadgets-editors" } "."
+$nl
+"The slot editor has a toolbar containing various commands."
+{ $command-map slot-editor "toolbar" }
+"The following commands are also available."
+{ $command-map source-editor "word" } ;
+
+ARTICLE: "ui-inspector" "UI inspector"
+"The graphical inspector provides functionality similar to the terminal inspector (see " { $link "inspector" } "), adding in-place editing of slot values."
+$nl
+"To display an object in the UI inspector, right-click a presentation and choose " { $strong "Inspector" } " from the menu that appears. The inspector can also be opened from the listener using a word:"
+{ $subsection inspector }
+"The inspector embeds a table gadget, which supports keyboard navigation; see " { $link "ui.gadgets.tables" } ". It also provides a few other commands:"
+{ $command-map inspector-gadget "toolbar" }
+{ $command-map inspector-gadget "multi-touch" }
+"The UI inspector is an instance of " { $link inspector-gadget } "."
+{ $subsection "ui-inspector-edit" } ;
+
+ABOUT: "ui-inspector"
\ No newline at end of file
diff --git a/basis/ui/tools/inspector/inspector-tests.factor b/basis/ui/tools/inspector/inspector-tests.factor
new file mode 100644 (file)
index 0000000..07ba5bc
--- /dev/null
@@ -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
\ No newline at end of file
index 579210325b26d96fc4931a1c067e580daecfea50..9191110fcd4dffeccf7fa648f605d386135429e9 100644 (file)
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ui.tools.workspace inspector kernel ui.commands
-ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.slots ui.gadgets.tracks ui.gestures
-ui.gadgets.buttons namespaces ;
+USING: accessors inspector namespaces kernel models fry
+models.filter prettyprint sequences mirrors assocs classes
+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.tools.common ui ;
 IN: ui.tools.inspector
 
-TUPLE: inspector-gadget < track object pane ;
+TUPLE: inspector-gadget < tool table ;
 
-: refresh ( inspector -- )
-    [ object>> ] [ pane>> ] bi [
-        +editable+ on
-        +number-rows+ on
-        describe
-    ] with-pane ;
+{ 500 300 } inspector-gadget set-tool-dim
 
-: <inspector-gadget> ( -- gadget )
+TUPLE: slot-description key key-string value value-string ;
+
+: <slot-description> ( key value -- slot-description )
+    [ dup unparse-short ] bi@ slot-description boa ;
+
+SINGLETON: inspector-renderer
+
+M: inspector-renderer row-columns
+    drop [ key-string>> ] [ value-string>> ] bi 2array ;
+
+M: inspector-renderer row-value
+    drop value>> ;
+
+: <summary-gadget> ( model -- gadget )
+    [
+        standard-table-style [
+            [
+                [
+                    [ "Class:" write ] with-cell
+                    [ class . ] with-cell
+                ] with-row
+            ]
+            [
+                [
+                    [ "Object:" write ] with-cell
+                    [ short. ] with-cell
+                ] with-row
+            ]
+            [
+                [
+                    [ "Summary:" write ] with-cell
+                    [ summary. ] with-cell
+                ] with-row
+            ] tri
+        ] tabular-output
+    ] <pane-control> ;
+
+DEFER: inspector
+
+GENERIC: make-slot-descriptions ( obj -- seq )
+
+M: object make-slot-descriptions
+    make-mirror [ <slot-description> ] { } assoc>map ;
+
+M: hashtable make-slot-descriptions
+    call-next-method [ [ key-string>> ] compare ] sort ;
+
+: <inspector-table> ( model -- table )
+    [ make-slot-descriptions ] <filter> <table>
+        [ inspector ] >>action
+        inspector-renderer >>renderer
+        monospace-font >>font ;
+
+: <inspector-gadget> ( obj -- gadget )
     { 0 1 } inspector-gadget new-track
         add-toolbar
-        <pane> >>pane
-        dup pane>> <scroller> 1 track-add ;
+        swap <model> >>model
+        dup model>> <inspector-table> >>table
+        dup model>> <summary-gadget> "Object" <labelled-gadget> f track-add
+        dup table>> <scroller> "Contents" <labelled-gadget> 1 track-add ;
+
+M: inspector-gadget focusable-child*
+    table>> ;
+
+: com-refresh ( inspector -- )
+    model>> notify-connections ;
 
-: inspect-object ( obj mirror keys inspector -- )
-    2nip swap >>object refresh ;
+: com-push ( inspector -- obj )
+    control-value ;
 
-\ &push H{ { +nullary+ t } { +listener+ t } } define-command
+\ com-push H{ { +listener+ t } } define-command
 
-\ &back H{ { +nullary+ t } { +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 ;
 
-\ &globals H{ { +nullary+ t } { +listener+ t } } define-command
+: 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" help-window ;
+: inspector-help ( -- ) "ui-inspector" com-follow ;
 
 \ inspector-help H{ { +nullary+ t } } define-command
 
 inspector-gadget "toolbar" f {
-    { T{ update-object } refresh }
-    { f &push }
-    { f &back }
-    { f &globals }
+    { 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
 
 inspector-gadget "multi-touch" f {
-    { T{ left-action } &back }
+    { T{ up-action } com-refresh }
 } define-command-map
 
-M: inspector-gadget tool-scroller
-    pane>> find-scroller ;
+: inspector ( obj -- )
+    <inspector-gadget> "Inspector" open-status-window ;
\ No newline at end of file
diff --git a/basis/ui/tools/interactor/authors.txt b/basis/ui/tools/interactor/authors.txt
deleted file mode 100644 (file)
index 1901f27..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/ui/tools/interactor/interactor-docs.factor b/basis/ui/tools/interactor/interactor-docs.factor
deleted file mode 100644 (file)
index 338a9be..0000000
+++ /dev/null
@@ -1,10 +0,0 @@
-USING: ui.gadgets ui.gadgets.editors listener io help.syntax
-help.markup ;
-IN: ui.tools.interactor
-
-HELP: interactor
-{ $class-description "An interactor is an " { $link editor } " intended to be used as the input component of a " { $link "ui-listener" } "."
-$nl
-"Interactors are created by calling " { $link <interactor> } "."
-$nl
-"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ;
diff --git a/basis/ui/tools/interactor/interactor-tests.factor b/basis/ui/tools/interactor/interactor-tests.factor
deleted file mode 100644 (file)
index 628570c..0000000
+++ /dev/null
@@ -1,87 +0,0 @@
-IN: ui.tools.interactor.tests
-USING: ui.tools.interactor ui.gadgets.panes namespaces
-ui.gadgets.editors concurrency.promises threads listener
-tools.test kernel calendar parser accessors calendar io ;
-
-\ <interactor> must-infer
-
-[
-    [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-    [ ] [ "interactor" get register-self ] unit-test
-
-    [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
-
-    [ ] [ <promise> "promise" set ] unit-test
-
-    [
-        self "interactor" get (>>thread)
-        "interactor" get stream-read-quot "promise" get fulfill
-    ] "Interactor test" spawn drop
-
-    ! This should not throw an exception
-    [ ] [ "interactor" get evaluate-input ] unit-test
-
-    [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
-
-    [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
-
-    [ ] [ "interactor" get evaluate-input ] unit-test
-
-    [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
-] with-interactive-vocabs
-
-! Hang
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
-
-[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
-
-[ ] [ 1 seconds sleep ] unit-test
-
-[ ] [ "interactor" get interactor-eof ] unit-test
-
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-: text "Hello world.\nThis is a test." ;
-
-[ ] [ text "interactor" get set-editor-string ] unit-test
-
-[ ] [ <promise> "promise" set ] unit-test
-
-[ ] [
-    [
-        "interactor" get register-self
-        "interactor" get contents "promise" get fulfill
-    ] in-thread
-] unit-test
-
-[ ] [ 100 milliseconds sleep ] unit-test
-
-[ ] [ "interactor" get evaluate-input ] unit-test
-
-[ ] [ 100 milliseconds sleep ] unit-test
-    
-[ ] [ "interactor" get interactor-eof ] unit-test
-
-[ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
-
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
-
-[ ] [ text "interactor" get set-editor-string ] unit-test
-
-[ ] [ <promise> "promise" set ] unit-test
-
-[ ] [
-    [
-        "interactor" get register-self
-        "interactor" get stream-read1 "promise" get fulfill
-    ] in-thread
-] unit-test
-
-[ ] [ 100 milliseconds sleep ] unit-test
-
-[ ] [ "interactor" get evaluate-input ] unit-test
-
-[ CHAR: H ] [ "promise" get 2 seconds ?promise-timeout ] unit-test
diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor
deleted file mode 100644 (file)
index 40da6eb..0000000
+++ /dev/null
@@ -1,185 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs combinators continuations documents
-hashtables io io.styles kernel math math.order math.vectors
-models models.delay namespaces parser lexer prettyprint
-quotations sequences strings threads listener classes.tuple
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
-ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-definitions calendar concurrency.flags concurrency.mailboxes
-ui.tools.workspace accessors sets destructors fry vocabs.parser ;
-IN: ui.tools.interactor
-
-! If waiting is t, we're waiting for user input, and invoking
-! evaluate-input resumes the thread.
-TUPLE: interactor < source-editor
-output history flag mailbox thread waiting help ;
-
-: register-self ( interactor -- )
-    <mailbox> >>mailbox
-    self >>thread
-    drop ;
-
-: interactor-continuation ( interactor -- continuation )
-    thread>> continuation>> value>> ;
-
-: interactor-busy? ( interactor -- ? )
-    #! We're busy if there's no thread to resume.
-    [ waiting>> ]
-    [ thread>> dup [ thread-registered? ] when ]
-    bi and not ;
-
-: interactor-use ( interactor -- seq )
-    dup interactor-busy? [ drop f ] [
-        use swap
-        interactor-continuation name>>
-        assoc-stack
-    ] if ;
-
-: <help-model> ( interactor -- model ) caret>> 1/3 seconds <delay> ;
-
-: <interactor> ( output -- gadget )
-    interactor new-editor
-        V{ } clone >>history
-        <flag> >>flag
-        dup <help-model> >>help
-        swap >>output ;
-
-M: interactor graft*
-    [ call-next-method ] [ dup help>> add-connection ] bi ;
-
-M: interactor ungraft*
-    [ dup help>> remove-connection ] [ call-next-method ] bi ;
-
-: word-at-loc ( loc interactor -- word )
-    over [
-        [ model>> T{ one-word-elt } elt-string ] keep
-        interactor-use assoc-stack
-    ] [
-        2drop f
-    ] if ;
-
-M: interactor model-changed
-    2dup help>> eq? [
-        swap value>> over word-at-loc swap show-summary
-    ] [
-        call-next-method
-    ] if ;
-
-: write-input ( string input -- )
-    <input> presented associate
-    [ H{ { font-style bold } } format ] with-nesting ;
-
-: interactor-input. ( string interactor -- )
-    output>> [
-        dup string? [ dup write-input nl ] [ short. ] if
-    ] with-output-stream* ;
-
-: add-interactor-history ( str interactor -- )
-    over empty? [ 2drop ] [ history>> adjoin ] if ;
-
-: interactor-continue ( obj interactor -- )
-    mailbox>> mailbox-put ;
-
-: clear-input ( interactor -- )
-    #! The with-datastack is a kludge to make it infer. Stupid.
-    model>> 1array [ clear-doc ] with-datastack drop ;
-
-: interactor-finish ( interactor -- )
-    [ editor-string ] keep
-    [ interactor-input. ] 2keep
-    [ add-interactor-history ] keep
-    clear-input ;
-
-: interactor-eof ( interactor -- )
-    dup interactor-busy? [
-        f over interactor-continue
-    ] unless drop ;
-
-: evaluate-input ( interactor -- )
-    dup interactor-busy? [
-        dup control-value over interactor-continue
-    ] unless drop ;
-
-: interactor-yield ( interactor -- obj )
-    dup thread>> self eq? [
-        {
-            [ t >>waiting drop ]
-            [ flag>> raise-flag ]
-            [ mailbox>> mailbox-get ]
-            [ f >>waiting drop ]
-        } cleave
-    ] [ drop f ] if ;
-
-: interactor-read ( interactor -- lines )
-    [ interactor-yield ] [ interactor-finish ] bi ;
-
-M: interactor stream-readln
-    interactor-read dup [ first ] when ;
-
-: interactor-call ( quot interactor -- )
-    dup interactor-busy? [
-        2dup interactor-input.
-        2dup interactor-continue
-    ] unless 2drop ;
-
-M: interactor stream-read
-    swap dup zero? [
-        2drop ""
-    ] [
-        [ interactor-read dup [ "\n" join ] when ] dip short head
-    ] if ;
-
-M: interactor stream-read-partial
-    stream-read ;
-
-M: interactor stream-read1
-    dup interactor-read {
-        { [ dup not ] [ 2drop f ] }
-        { [ dup empty? ] [ drop stream-read1 ] }
-        { [ dup first empty? ] [ 2drop CHAR: \n ] }
-        [ nip first first ]
-    } cond ;
-
-M: interactor dispose drop ;
-
-: go-to-error ( interactor error -- )
-    [ line>> 1- ] [ column>> ] bi 2array
-    over set-caret
-    mark>caret ;
-
-: handle-parse-error ( interactor error -- )
-    dup lexer-error? [ 2dup go-to-error error>> ] when
-    swap find-workspace debugger-popup ;
-
-: try-parse ( lines interactor -- quot/error/f )
-    [
-        drop parse-lines-interactive
-    ] [
-        2nip
-        dup lexer-error? [
-            dup error>> unexpected-eof? [ drop f ] when
-        ] when
-    ] recover ;
-
-: handle-interactive ( lines interactor -- quot/f ? )
-    tuck try-parse {
-        { [ dup quotation? ] [ nip t ] }
-        { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
-        [ handle-parse-error f f ]
-    } cond ;
-
-M: interactor stream-read-quot
-    [ interactor-yield ] keep {
-        { [ over not ] [ drop ] }
-        { [ over callable? ] [ drop ] }
-        [
-            [ handle-interactive ] keep swap
-            [ interactor-finish ] [ nip stream-read-quot ] if
-        ]
-    } cond ;
-
-interactor "interactor" f {
-    { T{ key-down f f "RET" } evaluate-input }
-    { T{ key-down f { C+ } "k" } clear-input }
-} define-command-map
diff --git a/basis/ui/tools/interactor/summary.txt b/basis/ui/tools/interactor/summary.txt
deleted file mode 100644 (file)
index 6929b20..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Interactors are used to input Factor code
diff --git a/basis/ui/tools/listener/listener-docs.factor b/basis/ui/tools/listener/listener-docs.factor
new file mode 100644 (file)
index 0000000..8ea9637
--- /dev/null
@@ -0,0 +1,35 @@
+USING: help.markup help.syntax ui.commands
+ui.gadgets.editors ui.gadgets.panes listener io ;
+IN: ui.tools.listener
+
+HELP: interactor
+{ $class-description "An interactor is an " { $link editor } " intended to be used as the input component of a " { $link "ui-listener" } "."
+$nl
+"Interactors are created by calling " { $link <interactor> } "."
+$nl
+"Interactors implement the " { $link stream-readln } ", " { $link stream-read } " and " { $link read-quot } " generic words." } ;
+
+ARTICLE: "ui-listener-completion" "Word and vocabulary completion"
+"The listener is great"
+;
+
+ARTICLE: "ui-listener" "UI listener"
+"The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds the following features:"
+{ $list
+    "Input history"
+    { "Completion (see " { $link "ui-listener-completion" } ")" }
+    { "Clickable presentations (see " { $link "ui-presentations" } ")" }
+}
+{ $command-map listener-gadget "toolbar" }
+{ $command-map listener-gadget "scrolling" }
+{ $command-map listener-gadget "workflow" }
+{ $command-map listener-gadget "multi-touch" }
+{ $command-map interactor "interactor" }
+{ $command-map source-editor "word" }
+{ $command-map interactor "quotation" }
+{ $heading "Editing commands" }
+"The text editing commands are standard; see " { $link "gadgets-editors" } "."
+{ $heading "Implementation" }
+"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } ")." ;
+
+ABOUT: "ui-listener"
\ No newline at end of file
index 28fdef6cb7ce4d92d18844c0d201e4c05b8a8b3c..f48d87b61da83386d7d5aa0b522d31d303196b5f 100644 (file)
@@ -1,11 +1,94 @@
-USING: continuations documents ui.tools.interactor
+USING: continuations documents
 ui.tools.listener hashtables kernel namespaces parser sequences
 tools.test ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.panes vocabs words tools.test.ui slots.private
 threads arrays generic threads accessors listener math
-calendar ;
+calendar concurrency.promises io ui.tools.common ;
 IN: ui.tools.listener.tests
 
+\ <interactor> must-infer
+
+[
+    [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+    [ ] [ "interactor" get register-self ] unit-test
+
+    [ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
+
+    [ ] [ <promise> "promise" set ] unit-test
+
+    [
+        self "interactor" get (>>thread)
+        "interactor" get stream-read-quot "promise" get fulfill
+    ] "Interactor test" spawn drop
+
+    ! This should not throw an exception
+    [ ] [ "interactor" get evaluate-input ] unit-test
+
+    [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
+
+    [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
+
+    [ ] [ "interactor" get evaluate-input ] unit-test
+
+    [ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
+] with-interactive-vocabs
+
+! Hang
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
+
+[ ] [ [ "interactor" get stream-read-quot drop ] "B" spawn drop ] unit-test
+
+[ ] [ 1 seconds sleep ] unit-test
+
+[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+: text "Hello world.\nThis is a test." ;
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+    [
+        "interactor" get register-self
+        "interactor" get contents "promise" get fulfill
+    ] in-thread
+] unit-test
+
+[ ] [ 100 milliseconds sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ ] [ 100 milliseconds sleep ] unit-test
+    
+[ ] [ "interactor" get interactor-eof ] unit-test
+
+[ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
+
+[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+
+[ ] [ text "interactor" get set-editor-string ] unit-test
+
+[ ] [ <promise> "promise" set ] unit-test
+
+[ ] [
+    [
+        "interactor" get register-self
+        "interactor" get stream-read1 "promise" get fulfill
+    ] in-thread
+] unit-test
+
+[ ] [ 100 milliseconds sleep ] unit-test
+
+[ ] [ "interactor" get evaluate-input ] unit-test
+
+[ CHAR: H ] [ "promise" get 2 seconds ?promise-timeout ] unit-test
+
 [ f ] [ "word" source-editor command-map commands>> empty? ] unit-test
 
 [ ] [ <listener-gadget> [ ] with-grafted-gadget ] unit-test
@@ -54,3 +137,16 @@ IN: ui.tools.listener.tests
 ] with-grafted-gadget
 
 [ ] [ \ + <pane> <interactor> interactor-use use-if-necessary ] unit-test
+
+[ ] [ <listener-gadget> "l" set ] unit-test
+[ ] [ "l" get com-scroll-up ] unit-test
+[ ] [ "l" get com-scroll-down ] unit-test
+[ ] [ "l" get hide-popup ] unit-test
+[ ] [ <gadget> "l" get show-popup ] unit-test
+[ ] [ "l" get hide-popup ] unit-test
+
+[ ] [
+    <gadget> "l" get show-popup
+    <gadget> "l" get show-popup
+    "l" get hide-popup
+] unit-test
\ No newline at end of file
index 7ffbfd273881d115057d298af4b91160d283269e..0f169faf473522692f1a69f5dad88f3c2dfea70c 100644 (file)
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: inspector help help.markup io io.styles kernel models
-namespaces parser quotations sequences vocabs words prettyprint
-listener debugger threads boxes concurrency.flags math arrays
-generic accessors combinators assocs fry ui.commands ui.gadgets
-ui.gadgets.editors ui.gadgets.labelled ui.gadgets.panes
-ui.gadgets.buttons ui.gadgets.scrollers ui.gadgets.packs
-ui.gadgets.tracks ui.gadgets.borders ui.gadgets.frames
-ui.gadgets.grids ui.gestures ui.operations ui.tools.browser
-ui.tools.interactor ui.tools.inspector ui.tools.workspace ;
+strings namespaces parser quotations sequences vocabs words
+continuations prettyprint listener debugger threads boxes
+concurrency.flags math arrays generic accessors combinators
+assocs fry generic.standard.engines.tuple combinators.short-circuit
+tools.vocabs concurrency.mailboxes vocabs.parser calendar
+models.delay documents hashtables sets destructors lexer
+ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.labelled
+ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
+ui.gadgets.packs ui.gadgets.tracks ui.gadgets.borders
+ui.gadgets.frames ui.gadgets.grids ui.gadgets.status-bar
+ui.gestures ui.operations ui.tools.browser
+ui.tools.debugger ui.tools.inspector ui.tools.common ui ;
 IN: ui.tools.listener
 
-TUPLE: listener-gadget < track input output ;
+! If waiting is t, we're waiting for user input, and invoking
+! evaluate-input resumes the thread.
+TUPLE: interactor < source-editor
+output history flag mailbox thread waiting help ;
+
+: register-self ( interactor -- )
+    <mailbox> >>mailbox
+    self >>thread
+    drop ;
+
+: interactor-continuation ( interactor -- continuation )
+    thread>> continuation>> value>> ;
+
+: interactor-busy? ( interactor -- ? )
+    #! We're busy if there's no thread to resume.
+    [ waiting>> ]
+    [ thread>> dup [ thread-registered? ] when ]
+    bi and not ;
+
+: interactor-use ( interactor -- seq )
+    dup interactor-busy? [ drop f ] [
+        use swap
+        interactor-continuation name>>
+        assoc-stack
+    ] if ;
+
+: <help-model> ( interactor -- model ) caret>> 1/3 seconds <delay> ;
+
+: <interactor> ( output -- gadget )
+    interactor new-editor
+        V{ } clone >>history
+        <flag> >>flag
+        dup <help-model> >>help
+        swap >>output ;
+
+M: interactor graft*
+    [ call-next-method ] [ dup help>> add-connection ] bi ;
+
+M: interactor ungraft*
+    [ dup help>> remove-connection ] [ call-next-method ] bi ;
+
+: word-at-loc ( loc interactor -- word )
+    over [
+        [ model>> one-word-elt elt-string ] keep
+        interactor-use assoc-stack
+    ] [
+        2drop f
+    ] if ;
+
+M: interactor model-changed
+    2dup help>> eq? [
+        swap value>> over word-at-loc swap show-summary
+    ] [
+        call-next-method
+    ] if ;
+
+: write-input ( string input -- )
+    <input> presented associate
+    [ H{ { font-style bold } } format ] with-nesting ;
+
+: interactor-input. ( string interactor -- )
+    output>> [
+        dup string? [ dup write-input nl ] [ short. ] if
+    ] with-output-stream* ;
+
+: add-interactor-history ( str interactor -- )
+    over empty? [ 2drop ] [ history>> adjoin ] if ;
+
+: interactor-continue ( obj interactor -- )
+    mailbox>> mailbox-put ;
+
+: interactor-finish ( interactor -- )
+    [ editor-string ] keep
+    [ interactor-input. ] 2keep
+    [ add-interactor-history ] keep
+    clear-editor ;
+
+: interactor-eof ( interactor -- )
+    dup interactor-busy? [
+        f over interactor-continue
+    ] unless drop ;
+
+: evaluate-input ( interactor -- )
+    dup interactor-busy? [
+        dup control-value over interactor-continue
+    ] unless drop ;
+
+: interactor-yield ( interactor -- obj )
+    dup thread>> self eq? [
+        {
+            [ t >>waiting drop ]
+            [ flag>> raise-flag ]
+            [ mailbox>> mailbox-get ]
+            [ f >>waiting drop ]
+        } cleave
+    ] [ drop f ] if ;
+
+: interactor-read ( interactor -- lines )
+    [ interactor-yield ] [ interactor-finish ] bi ;
+
+M: interactor stream-readln
+    interactor-read dup [ first ] when ;
+
+: interactor-call ( quot interactor -- )
+    dup interactor-busy? [
+        2dup interactor-input.
+        2dup interactor-continue
+    ] unless 2drop ;
+
+M: interactor stream-read
+    swap dup zero? [
+        2drop ""
+    ] [
+        [ interactor-read dup [ "\n" join ] when ] dip short head
+    ] if ;
+
+M: interactor stream-read-partial
+    stream-read ;
+
+M: interactor stream-read1
+    dup interactor-read {
+        { [ dup not ] [ 2drop f ] }
+        { [ dup empty? ] [ drop stream-read1 ] }
+        { [ dup first empty? ] [ 2drop CHAR: \n ] }
+        [ nip first first ]
+    } cond ;
+
+M: interactor dispose drop ;
+
+: go-to-error ( interactor error -- )
+    [ line>> 1- ] [ column>> ] bi 2array
+    over set-caret
+    mark>caret ;
+
+TUPLE: listener-gadget < tool input output scroller popup ;
+
+{ 550 700 } listener-gadget set-tool-dim
+
+: find-listener ( gadget -- listener )
+    [ listener-gadget? ] find-parent ;
 
 : listener-streams ( listener -- input output )
-    [ input>> ] [ output>> <pane-stream> ] bi ;
+    [ input>> ] [ output>> ] bi <pane-stream> ;
 
 : <listener-input> ( listener -- gadget )
     output>> <pane-stream> <interactor> ;
 
-: welcome. ( -- )
-    "If this is your first time with Factor, please read the " print
-    "handbook" ($link) ". To see a list of keyboard shortcuts," print
-    "press F1." print nl ;
+: init-listener ( listener -- listener )
+    <scrolling-pane> >>output
+    dup <listener-input> >>input ;
 
-M: listener-gadget focusable-child*
-    input>> ;
+: <listener-scroller> ( listener -- scroller )
+    <frame>
+        over output>> @top grid-add
+        swap input>> @center grid-add
+    <scroller> ;
 
-M: listener-gadget call-tool* ( input listener -- )
-    [ string>> ] dip input>> set-editor-string ;
+: <listener-gadget> ( -- gadget )
+    { 0 1 } listener-gadget new-track
+        add-toolbar
+        init-listener
+        dup <listener-scroller> >>scroller
+        dup scroller>> 1 track-add ;
 
-M: listener-gadget tool-scroller
-    output>> find-scroller ;
+M: listener-gadget focusable-child*
+    [ popup>> ] [ input>> ] bi or ;
 
 : wait-for-listener ( listener -- )
     #! Wait for the listener to start.
     input>> flag>> wait-for-flag ;
 
-: workspace-busy? ( workspace -- ? )
-    listener>> input>> interactor-busy? ;
+: listener-busy? ( listener -- ? )
+    input>> interactor-busy? ;
+
+: listener-window* ( -- listener )
+    <listener-gadget>
+    dup "Listener" open-status-window ;
+
+: listener-window ( -- )
+    [ listener-window* drop ] with-ui ;
+
+\ listener-window H{ { +nullary+ t } } define-command
+
+: (get-listener) ( quot -- listener )
+    find-window
+    [ [ raise-window ] [ gadget-child ] bi ]
+    [ listener-window* ] if* ; inline
+
+: get-listener ( -- listener )
+    [ listener-gadget? ] (get-listener) ;
+
+: show-listener ( -- )
+    get-listener drop ;
+
+\ show-listener H{ { +nullary+ t } } define-command
+
+: get-ready-listener ( -- listener )
+    [
+        {
+            [ listener-gadget? ]
+            [ listener-busy? not ]
+        } 1&&
+    ] (get-listener) ;
+
+GENERIC: listener-input ( obj -- )
 
-: listener-input ( string -- )
-    get-workspace listener>> input>>
+M: input listener-input string>> listener-input ;
+
+M: string listener-input
+    get-listener input>>
     [ set-editor-string ] [ request-focus ] bi ;
 
 : (call-listener) ( quot listener -- )
     input>> interactor-call ;
 
 : call-listener ( quot -- )
-    [ workspace-busy? not ] get-workspace* listener>>
+    get-ready-listener
     '[ _ _ dup wait-for-listener (call-listener) ]
     "Listener call" spawn drop ;
 
@@ -59,8 +242,7 @@ M: listener-operation invoke-command ( target command -- )
     [ hook>> call ] keep operation-quot call-listener ;
 
 : eval-listener ( string -- )
-    get-workspace
-    listener>> input>> [ set-editor-string ] keep
+    get-listener input>> [ set-editor-string ] keep
     evaluate-input ;
 
 : listener-run-files ( seq -- )
@@ -81,26 +263,24 @@ M: listener-operation invoke-command ( target command -- )
 
 GENERIC: word-completion-string ( word -- string )
 
-M: word word-completion-string
-    name>> ;
+M: word word-completion-string name>> ;
 
-M: method-body word-completion-string
+: method-completion-string ( word -- string )
     "method-generic" word-prop word-completion-string ;
 
-USE: generic.standard.engines.tuple
+M: method-body word-completion-string method-completion-string ;
 
-M: engine-word word-completion-string
-    "engine-generic" word-prop word-completion-string ;
+M: engine-word word-completion-string method-completion-string ;
 
 : use-if-necessary ( word seq -- )
-    over vocabulary>> over and [
+    2dup [ vocabulary>> ] dip and [
         2dup [ assoc-stack ] keep = [ 2drop ] [
             [ vocabulary>> vocab-words ] dip push
         ] if
     ] [ 2drop ] if ;
 
 : insert-word ( word -- )
-    get-workspace listener>> input>>
+    get-listener input>>
     [ [ word-completion-string ] dip user-input* drop ]
     [ interactor-use use-if-necessary ]
     2bi ;
@@ -111,21 +291,69 @@ M: engine-word word-completion-string
     [ select-all ]
     2bi ;
 
-: ui-help-hook ( topic -- )
-    browser-gadget call-tool ;
-
-: ui-error-hook ( error listener -- )
-    find-workspace debugger-popup ;
+: hide-popup ( listener -- )
+    dup popup>> track-remove
+    f >>popup
+    request-focus ;
+
+: show-popup ( gadget listener -- )
+    dup hide-popup
+    over >>popup
+    over f track-add drop
+    request-focus ;
+
+: show-titled-popup ( listener gadget title -- )
+    [ find-listener hide-popup ] <closable-gadget>
+    swap show-popup ;
+
+: debugger-popup ( error listener -- )
+    swap dup compute-restarts
+    [ find-listener hide-popup ] <debugger>
+    "Error" show-titled-popup ;
+
+: handle-parse-error ( interactor error -- )
+    dup lexer-error? [ 2dup go-to-error error>> ] when
+    swap find-listener debugger-popup ;
+
+: try-parse ( lines interactor -- quot/error/f )
+    [ drop parse-lines-interactive ] [
+        2nip
+        dup lexer-error? [
+            dup error>> unexpected-eof? [ drop f ] when
+        ] when
+    ] recover ;
+
+: handle-interactive ( lines interactor -- quot/f ? )
+    tuck try-parse {
+        { [ dup quotation? ] [ nip t ] }
+        { [ dup not ] [ drop "\n" swap user-input* drop f f ] }
+        [ handle-parse-error f f ]
+    } cond ;
+
+M: interactor stream-read-quot
+    [ interactor-yield ] keep {
+        { [ over not ] [ drop ] }
+        { [ over callable? ] [ drop ] }
+        [
+            [ handle-interactive ] keep swap
+            [ interactor-finish ] [ nip stream-read-quot ] if
+        ]
+    } cond ;
+
+interactor "interactor" f {
+    { T{ key-down f f "RET" } evaluate-input }
+    { T{ key-down f { C+ } "k" } clear-editor }
+} define-command-map
 
-: ui-inspector-hook ( obj listener -- )
-    find-workspace inspector-gadget
-    swap show-tool inspect-object ;
+: welcome. ( -- )
+    "If this is your first time with Factor, please read the " print
+    "handbook" ($link) ". To see a list of keyboard shortcuts," print
+    "press F1." print nl ;
 
 : listener-thread ( listener -- )
     dup listener-streams [
-        [ ui-help-hook ] help-hook set
-        [ '[ _ ui-error-hook ] error-hook set ]
-        [ '[ _ ui-inspector-hook ] inspector-hook set ] bi
+        [ com-follow ] help-hook set
+        '[ _ debugger-popup ] error-hook set
         welcome.
         listener
     ] with-streams* ;
@@ -143,28 +371,12 @@ M: engine-word word-completion-string
     {
         [ com-end ]
         [ clear-output ]
-        [ input>> clear-input ]
+        [ input>> clear-editor ]
         [ start-listener-thread ]
         [ wait-for-listener ]
     } cleave ;
 
-: init-listener ( listener -- listener )
-    <scrolling-pane> >>output
-    dup <listener-input> >>input ;
-
-: <listener-scroller> ( listener -- scroller )
-    <frame>
-        over output>> @top grid-add
-        swap input>> @center grid-add
-    <scroller> ;
-
-: <listener-gadget> ( -- gadget )
-    { 0 1 } listener-gadget new-track
-        add-toolbar
-        init-listener
-        dup <listener-scroller> 1 track-add ;
-
-: listener-help ( -- ) "ui-listener" help-window ;
+: listener-help ( -- ) "ui-listener" com-follow ;
 
 \ listener-help H{ { +nullary+ t } } define-command
 
@@ -185,12 +397,25 @@ listener-gadget "toolbar" f {
     { T{ key-down f { C+ } "d" } com-end }
 } define-command-map
 
-M: listener-gadget handle-gesture ( gesture gadget -- ? )
-    2dup find-workspace workspace-page handle-gesture
-    [ call-next-method ] [ 2drop f ] if ;
+listener-gadget "scrolling"
+"The listener's scroller can be scrolled from the keyboard."
+{
+    { T{ key-down f { A+ } "UP" } com-scroll-up }
+    { T{ key-down f { A+ } "DOWN" } com-scroll-down }
+    { T{ key-down f { A+ } "PAGE_UP" } com-page-up }
+    { T{ key-down f { A+ } "PAGE_DOWN" } com-page-down }
+} define-command-map
+
+listener-gadget "multi-touch" f {
+    { T{ up-action } refresh-all }
+} define-command-map
+
+listener-gadget "other" f {
+    { T{ key-down f f "ESC" } hide-popup }
+} define-command-map
 
 M: listener-gadget graft*
     [ call-next-method ] [ restart-listener ] bi ;
 
 M: listener-gadget ungraft*
-    [ com-end ] [ call-next-method ] bi ;
+    [ com-end ] [ call-next-method ] bi ;
\ No newline at end of file
index a9405424dc283d72cd1f4f49cce790fb9e5d29b2..43de1a2f61a2f104f6ea41f8e9abce69ad433971 100644 (file)
@@ -1,12 +1,13 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations definitions ui.tools.browser
-ui.tools.interactor ui.tools.listener ui.tools.profiler
-ui.tools.search ui.tools.traceback ui.tools.workspace generic
-help.topics stack-checker summary inspector io.pathnames
-io.styles kernel namespaces parser prettyprint quotations
-tools.annotations editors tools.profiler tools.test tools.time
-tools.walker ui.commands ui.gadgets.editors ui.gestures
+ui.tools.listener ui.tools.profiler
+ui.tools.inspector ui.tools.traceback
+generic help.topics stack-checker
+summary io.pathnames io.styles kernel namespaces parser
+prettyprint quotations tools.annotations editors
+tools.profiler tools.test tools.time tools.walker
+ui.commands ui.gadgets.editors ui.gestures
 ui.operations ui.tools.deploy vocabs vocabs.loader words
 sequences tools.vocabs classes compiler.units accessors
 vocabs.parser ;
@@ -15,9 +16,8 @@ IN: ui.tools.operations
 V{ } clone operations set-global
 
 ! Objects
-[ drop t ] \ inspect H{
+[ drop t ] \ inspector H{
     { +primary+ t }
-    { +listener+ t }
 } define-operation
 
 : com-prettyprint ( obj -- ) . ;
@@ -62,7 +62,7 @@ V{ } clone operations set-global
 : edit-file ( pathname -- ) edit ;
 
 [ pathname? ] \ edit-file H{
-    { +keyboard+ T{ key-down f { C+ } "E" } }
+    { +keyboard+ T{ key-down f { C+ } "e" } }
     { +primary+ t }
     { +secondary+ t }
     { +listener+ t }
@@ -71,7 +71,7 @@ V{ } clone operations set-global
 UNION: definition word method-spec link vocab vocab-link ;
 
 [ definition? ] \ edit H{
-    { +keyboard+ T{ key-down f { C+ } "E" } }
+    { +keyboard+ T{ key-down f { C+ } "e" } }
     { +listener+ t }
 } define-operation
 
@@ -86,19 +86,19 @@ UNION: definition word method-spec link vocab vocab-link ;
 } define-operation
 
 [ topic? ] \ com-follow H{
-    { +keyboard+ T{ key-down f { C+ } "H" } }
+    { +keyboard+ T{ key-down f { C+ } "h" } }
     { +primary+ t }
 } define-operation
 
-: com-usage ( word -- )
-    get-workspace swap show-word-usage ;
+: com-usage ( word -- )
+    get-workspace swap show-word-usage ;
 
-[ word? ] \ com-usage H{
-    { +keyboard+ T{ key-down f { C+ } "U" } }
-} define-operation
+[ word? ] \ com-usage H{
+    { +keyboard+ T{ key-down f { C+ } "U" } }
+} define-operation
 
 [ word? ] \ fix H{
-    { +keyboard+ T{ key-down f { C+ } "F" } }
+    { +keyboard+ T{ key-down f { C+ } "f" } }
     { +listener+ t }
 } define-operation
 
@@ -117,18 +117,18 @@ M: word com-stack-effect def>> com-stack-effect ;
 } define-operation
 
 ! Vocabularies
-: com-vocab-words ( vocab -- )
-    get-workspace swap show-vocab-words ;
+: com-vocab-words ( vocab -- )
+    get-workspace swap show-vocab-words ;
 
-[ vocab? ] \ com-vocab-words H{
-    { +secondary+ t }
-    { +keyboard+ T{ key-down f { C+ } "B" } }
-} define-operation
+[ vocab? ] \ com-vocab-words H{
+    { +secondary+ t }
+    { +keyboard+ T{ key-down f { C+ } "B" } }
+} define-operation
 
 : com-enter-in ( vocab -- ) vocab-name set-in ;
 
 [ vocab? ] \ com-enter-in H{
-    { +keyboard+ T{ key-down f { C+ } "I" } }
+    { +keyboard+ T{ key-down f { C+ } "i" } }
     { +listener+ t }
 } define-operation
 
@@ -140,12 +140,12 @@ M: word com-stack-effect def>> com-stack-effect ;
 } define-operation
 
 [ vocab-spec? ] \ run H{
-    { +keyboard+ T{ key-down f { C+ } "R" } }
+    { +keyboard+ T{ key-down f { C+ } "r" } }
     { +listener+ t }
 } define-operation
 
 [ vocab? ] \ test H{
-    { +keyboard+ T{ key-down f { C+ } "T" } }
+    { +keyboard+ T{ key-down f { C+ } "t" } }
     { +listener+ t }
 } define-operation
 
@@ -167,20 +167,13 @@ M: word com-stack-effect def>> com-stack-effect ;
     { +listener+ t }
 } define-operation
 
-: com-show-profile ( workspace -- )
-    profiler-gadget call-tool ;
-
-: com-profile ( quot -- ) profile f com-show-profile ;
+: com-profile ( quot -- ) profile profiler-window ;
 
 [ quotation? ] \ com-profile H{
     { +keyboard+ T{ key-down f { C+ } "r" } }
     { +listener+ t }
 } define-operation
 
-! Profiler presentations
-[ dup usage-profile? swap vocab-profile? or ]
-\ com-show-profile H{ { +primary+ t } } define-operation
-
 ! Operations -> commands
 source-editor
 "word"
index 7280efe8850a2b3389b5ec391cbca2f55b5687ef..867afbb65f3013f2da8f5844ef3fef0892e66953 100644 (file)
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ui.tools.workspace kernel quotations tools.profiler
-ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
-ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors fry ;
+USING: kernel quotations accessors fry
+assocs present math.order math.vectors arrays locals
+models.search models.sort models sequences vocabs
+tools.profiler words prettyprint ui ui.commands ui.gadgets
+ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
+ui.gadgets.buttons ui.gadgets.tables ui.gadgets.search-tables
+ui.gadgets.labelled ui.gadgets.buttons ui.gadgets.packs
+ui.gadgets.labels ui.gadgets.tabbed ui.gadgets.status-bar
+ui.tools.browser ui.tools.common ;
+FROM: models.filter => <filter> ;
+FROM: models.compose => <compose> ;
 IN: ui.tools.profiler
 
-TUPLE: profiler-gadget < track pane ;
+TUPLE: profiler-gadget < tool
+sort
+vocabs vocab
+words
+methods
+generic class ;
 
-: <profiler-gadget> ( -- gadget )
-    { 0 1 } profiler-gadget new-track
-        add-toolbar
-        <pane> >>pane
-        dup pane>> <scroller> 1 track-add ;
+{ 700 400 } profiler-gadget set-tool-dim
+
+SINGLETON: word-renderer
+
+! Value is a { word count } pair
+M: word-renderer row-columns
+    drop [ [ present ] map ] [ { "All" "" } ] if* ;
+
+M: word-renderer row-value drop first ;
+
+SINGLETON: method-renderer
+
+! Value is a { method-body count } pair
+M: method-renderer row-columns
+    drop [ first synopsis ] [ second present ] bi 2array ;
+
+M: method-renderer row-value drop first ;
+
+: <profiler-model> ( values profiler -- model )
+    [ [ filter-counts ] <filter> ] [ sort>> ] bi* <sort> ;
+
+: <words-model> ( profiler -- model )
+    [
+        [ words>> ] [ vocab>> ] bi
+        [ [ [ first vocabulary>> ] dip = ] when* ] <search>
+    ] keep <profiler-model> ;
+
+: match? ( pair/f str -- ? )
+    swap dup [ first present subseq? ] [ 2drop t ] if ;
+
+: <profiler-table> ( model -- table )
+    [ match? ] <search-table>
+        word-renderer >>renderer
+        { 0 1 } >>column-alignment
+        0 >>filled-column ;
+
+: <profiler-filter-model> ( counts profiler -- model' )
+    [ <model> ] dip <profiler-model> [ f prefix ] <filter> ;
 
-: with-profiler-pane ( gadget quot -- )
-    [ pane>> ] dip with-pane ;
+: <vocabs-model> ( profiler -- model )
+    [ vocab-counters ] dip <profiler-filter-model> ;
 
-: com-full-profile ( gadget -- )
-    [ profile. ] with-profiler-pane ;
+: <generic-model> ( profiler -- model )
+    [ generic-counters ] dip <profiler-filter-model> ;
 
-: com-vocabs-profile ( gadget -- )
-    [ vocabs-profile. ] with-profiler-pane ;
+: <class-model> ( profiler -- model )
+    [ class-counters ] dip <profiler-filter-model> ;
 
-: com-method-profile ( gadget -- )
-    [ method-profile. ] with-profiler-pane ;
+: method-matches? ( method generic class -- ? )
+    [ first ] 2dip
+    [ drop dup [ subwords memq? ] [ 2drop t ] if ]
+    [ nip dup [ swap "method-class" word-prop = ] [ 2drop t ] if ]
+    3bi and ;
 
-: profiler-help ( -- ) "ui-profiler" help-window ;
+: <methods-model> ( profiler -- model )
+    [
+        [ method-counters <model> ] dip
+        [ generic>> ] [ class>> ] bi 3array <compose>
+        [ first3 '[ _ _ method-matches? ] filter ] <filter>
+    ] keep <profiler-model> ;
+
+: sort-options ( -- alist )
+    {
+        { [ [ first ] compare ] "by name" }
+        { [ [ second ] compare invert-comparison ] "by call count" }
+    } ;
+
+: <sort-options> ( model -- gadget )
+    sort-options <radio-buttons> { 1 0 } >>orientation ;
+
+: <profiler-tool-bar> ( profiler -- gadget )
+    <shelf>
+        { 5 5 } >>gap
+        over <toolbar> add-gadget
+        "Sort by:" <label> add-gadget
+        swap sort>> <sort-options> add-gadget ;
+
+:: <words-tab> ( profiler -- gadget )
+    { 1 0 } <track>
+        profiler vocabs>> <profiler-table>
+            profiler vocab>> >>selected-value
+        "Vocabularies" <labelled-gadget>
+    1/2 track-add
+        profiler <words-model> <profiler-table>
+        "Words" <labelled-gadget>
+    1/2 track-add ;
+
+:: <methods-tab> ( profiler -- gadget )
+    { 0 1 } <track>
+        { 1 0 } <track>
+            profiler <generic-model> <profiler-table>
+                profiler generic>> >>selected-value
+            "Generic words" <labelled-gadget>
+        1/2 track-add
+            profiler <class-model> <profiler-table>
+                profiler class>> >>selected-value
+            "Classes" <labelled-gadget>
+        1/2 track-add
+    1/2 track-add
+        profiler methods>> <profiler-table>
+            method-renderer >>renderer
+        "Methods" <labelled-gadget>
+    1/2 track-add ;
+
+: <selection-model> ( -- model ) { f 0 } <model> ;
+
+: <profiler-gadget> ( -- profiler )
+    { 0 1 } profiler-gadget new-track
+        [ [ first ] compare ] <model> >>sort
+        all-words counters <model> >>words
+        <selection-model> >>vocab
+        dup <vocabs-model> >>vocabs
+        <selection-model> >>generic
+        <selection-model> >>class
+        dup <methods-model> >>methods
+        dup <profiler-tool-bar> f track-add
+        <tabbed-gadget>
+            over <words-tab> "Words" add-tab
+            over <methods-tab> "Methods" add-tab
+        1 track-add ;
+
+: profiler-help ( -- ) "ui-profiler" com-follow ;
 
 \ profiler-help H{ { +nullary+ t } } define-command
 
 profiler-gadget "toolbar" f {
-    { f com-full-profile }
-    { f com-vocabs-profile }
-    { f com-method-profile }
     { T{ key-down f f "F1" } profiler-help }
 } define-command-map
 
-GENERIC: profiler-presentation ( obj -- quot )
-
-M: usage-profile profiler-presentation
-    word>> '[ _ usage-profile. ] ;
-
-M: vocab-profile profiler-presentation
-    vocab>> '[ _ vocab-profile. ] ;
-
-M: f profiler-presentation
-    drop [ vocabs-profile. ] ;
+: profiler-window ( -- )
+    <profiler-gadget> "Profiling results" open-status-window ;
 
-M: profiler-gadget call-tool* ( obj gadget -- )
-    swap profiler-presentation with-profiler-pane ;
+MAIN: profiler-window
\ No newline at end of file
diff --git a/basis/ui/tools/search/authors.txt b/basis/ui/tools/search/authors.txt
deleted file mode 100644 (file)
index 1901f27..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/ui/tools/search/search-tests.factor b/basis/ui/tools/search/search-tests.factor
deleted file mode 100644 (file)
index 4f239ba..0000000
+++ /dev/null
@@ -1,56 +0,0 @@
-USING: assocs ui.tools.search help.topics io.pathnames io.styles
-kernel namespaces sequences source-files threads
-tools.test ui.gadgets ui.gestures vocabs accessors
-vocabs.loader words tools.test.ui debugger calendar ;
-IN: ui.tools.search.tests
-
-[ f ] [
-    "no such word with this name exists, certainly"
-    f f <definition-search>
-    T{ key-down f { C+ } "x" } swap search-gesture
-] unit-test
-
-: assert-non-empty ( obj -- ) empty? f assert= ;
-
-: update-live-search ( search -- seq )
-    dup [
-        300 milliseconds sleep
-        list>> control-value
-    ] with-grafted-gadget ;
-
-: test-live-search ( gadget quot -- ? )
-    [ update-live-search dup assert-non-empty ] dip all? ;
-
-[ t ] [
-    "swp" all-words f <definition-search>
-    [ word? ] test-live-search
-] unit-test
-
-[ t ] [
-    "" all-words t <definition-search>
-    dup [
-        { "set-word-prop" } over field>> set-control-value
-        300 milliseconds sleep
-        search-value \ set-word-prop eq?
-    ] with-grafted-gadget
-] unit-test
-
-[ t ] [
-    "quot" <help-search>
-    [ link? ] test-live-search
-] unit-test
-
-[ t ] [
-    "factor" source-files get keys <source-file-search>
-    [ pathname? ] test-live-search
-] unit-test
-
-[ t ] [
-    "kern" <vocab-search>
-    [ vocab-spec? ] test-live-search
-] unit-test
-
-[ t ] [
-    "a" { "a" "b" "aa" } <history-search>
-    [ input? ] test-live-search
-] unit-test
diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor
deleted file mode 100644 (file)
index 9d248e2..0000000
+++ /dev/null
@@ -1,167 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs help help.topics io.pathnames io.styles
-kernel models models.delay models.filter namespaces prettyprint
-quotations sequences sorting source-files definitions strings
-tools.completion tools.crossref classes.tuple vocabs words
-vocabs.loader tools.vocabs unicode.case calendar locals
-ui.tools.interactor ui.tools.listener ui.tools.workspace
-ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists
-ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.borders
-ui.gestures ui.operations ui ;
-IN: ui.tools.search
-
-TUPLE: live-search < track field list ;
-
-: search-value ( live-search -- value )
-    list>> list-value ;
-
-: search-gesture ( gesture live-search -- operation/f )
-    search-value object-operations
-    [ operation-gesture = ] with find nip ;
-
-M: live-search handle-gesture ( gesture live-search -- ? )
-    tuck search-gesture dup [
-        over find-workspace hide-popup
-        [ search-value ] dip invoke-command f
-    ] [
-        2drop t
-    ] if ;
-
-: find-live-search ( gadget -- search )
-    [ live-search? ] find-parent ;
-
-: find-search-list ( gadget -- list )
-    find-live-search list>> ;
-
-TUPLE: search-field < editor ;
-
-: <search-field> ( -- gadget )
-    search-field new-editor ;
-
-search-field H{
-    { T{ key-down f f "UP" } [ find-search-list select-previous ] }
-    { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
-    { T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] }
-    { T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] }
-    { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] }
-} set-gestures
-
-: <search-model> ( live-search producer -- filter )
-    [
-        field>> model>>
-        ui-running? [ 1/5 seconds <delay> ] when
-    ] dip [ "\n" join ] prepend <filter> ;
-
-: init-search-model ( live-search seq limited? -- live-search )
-    [ 2drop ]
-    [ [ limited-completions ] [ completions ] ? curry <search-model> ] 3bi
-    >>model ; inline
-
-: <search-list> ( presenter live-search -- list )
-    [ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* <list> ;
-
-:: <live-search> ( string seq limited? presenter -- gadget )
-    { 0 1 } live-search new-track
-        <search-field> >>field
-        seq limited? init-search-model
-        presenter over <search-list> >>list
-        dup field>> 1 <border> { 1 1 } >>fill f track-add
-        dup list>> <scroller> 1 track-add
-        string over field>> set-editor-string
-        dup field>> end-of-document ;
-
-M: live-search focusable-child* field>> ;
-
-M: live-search pref-dim* drop { 400 200 } ;
-
-: current-word ( workspace -- string )
-    listener>> input>> selected-word ;
-
-: definition-candidates ( words -- candidates )
-    [ dup synopsis >lower ] { } map>assoc sort-values ;
-
-: <definition-search> ( string words limited? -- gadget )
-    [ definition-candidates ] dip [ synopsis ] <live-search> ;
-
-: word-candidates ( words -- candidates )
-    [ dup name>> >lower ] { } map>assoc ;
-
-: <word-search> ( string words limited? -- gadget )
-    [ word-candidates ] dip [ synopsis ] <live-search> ;
-
-: com-words ( workspace -- )
-    dup current-word all-words t <word-search>
-    "Word search" show-titled-popup ;
-
-: show-vocab-words ( workspace vocab -- )
-    [ "" swap words natural-sort f <word-search> ]
-    [ "Words in " swap vocab-name append ]
-    bi show-titled-popup ;
-
-: show-word-usage ( workspace word -- )
-    [ "" swap smart-usage f <definition-search> ]
-    [ "Words and methods using " swap name>> append ]
-    bi show-titled-popup ;
-
-: help-candidates ( seq -- candidates )
-    [ dup >link swap article-title >lower ] { } map>assoc
-    sort-values ;
-
-: <help-search> ( string -- gadget )
-    all-articles help-candidates
-    f [ article-title ] <live-search> ;
-
-: com-search ( workspace -- )
-    "" <help-search> "Help search" show-titled-popup ;
-
-: source-file-candidates ( seq -- candidates )
-    [ dup <pathname> swap >lower ] { } map>assoc ;
-
-: <source-file-search> ( string files -- gadget )
-    source-file-candidates
-    f [ string>> ] <live-search> ;
-
-: all-source-files ( -- seq )
-    source-files get keys natural-sort ;
-
-: com-sources ( workspace -- )
-    "" all-source-files <source-file-search>
-    "Source file search" show-titled-popup ;
-
-: show-vocab-files ( workspace vocab -- )
-    [ "" swap vocab-files <source-file-search> ]
-    [ "Source files in " swap vocab-name append ]
-    bi show-titled-popup ;
-
-: vocab-candidates ( -- candidates )
-    all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ;
-
-: <vocab-search> ( string -- gadget )
-    vocab-candidates f [ vocab-name ] <live-search> ;
-
-: com-vocabs ( workspace -- )
-    dup current-word <vocab-search>
-    "Vocabulary search" show-titled-popup ;
-
-: history-candidates ( seq -- candidates )
-    [ dup <input> swap >lower ] { } map>assoc ;
-
-: <history-search> ( string seq -- gadget )
-    history-candidates
-    f [ string>> ] <live-search> ;
-
-: listener-history ( listener -- seq )
-    input>> history>> <reversed> ;
-
-: com-history ( workspace -- )
-    "" over listener>> listener-history <history-search>
-    "History search" show-titled-popup ;
-
-workspace "toolbar" f {
-    { T{ key-down f { C+ } "p" } com-history }
-    { T{ key-down f f "TAB" } com-words }
-    { T{ key-down f { C+ } "u" } com-vocabs }
-    { T{ key-down f { C+ } "e" } com-sources }
-    { T{ key-down f { C+ } "h" } com-search }
-} define-command-map
diff --git a/basis/ui/tools/search/summary.txt b/basis/ui/tools/search/summary.txt
deleted file mode 100644 (file)
index af5dcef..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Support for graphical completion popups
index 8e1cc8d8f06b592e829a4428ec28dd525ab14bbc..e4bd7a9f135c954742dbfeafb9490fafca7e19c3 100644 (file)
@@ -1,12 +1,26 @@
 USING: editors help.markup help.syntax summary inspector io
 io.styles listener parser prettyprint tools.profiler
-tools.walker ui.commands ui.gadgets.editors ui.gadgets.panes
-ui.gadgets.presentations ui.gadgets.slots ui.operations
-ui.tools.browser ui.tools.interactor ui.tools.inspector
-ui.tools.listener ui.tools.operations ui.tools.profiler
-ui.tools.walker ui.tools.workspace vocabs ;
+tools.walker ui.commands ui.gadgets.panes
+ui.gadgets.presentations ui.operations
+ ui.tools.operations ui.tools.profiler
+ui.tools.common vocabs ;
 IN: ui.tools
 
+ARTICLE: "starting-ui-tools" "Starting the UI tools"
+"The UI tools start automatically where possible:"
+{ $list
+    { "On Windows, the tools start when the Factor executable is run." }
+    { "On X11, the tools start if the " { $snippet "DISPLAY" } " environment variable is set." }
+    { "On Mac OS X, the tools start if the " { $snippet "Factor.app" } " application bundle is run." }
+}
+"In all cases, passing the " { $snippet "-run=listener" } " command line switch starts the terminal listener instead. The UI can be started from the terminal by issuing the following command:"
+{ $code "USE: threads" "[ \"ui.tools\" run ] in-thread" } ;
+
+ARTICLE: "ui-shortcuts" "UI tool keyboard shortcuts"
+"Every UI tool has its own set of keyboard shortcuts; press " { $snippet "F1" } " inside a tool to see help. Some common shortcuts are also supported by all tools:"
+{ $command-map tool "tool-switching" }
+{ $command-map tool "common" } ;
+
 ARTICLE: "ui-presentations" "Presentations in the UI"
 "A " { $emphasis "presentation" } " is a graphical view of an object which is directly linked to the object in some way. The help article links you see in the documentation browser are presentations; and if you " { $link see } " a word in the UI listener, all words in the definition will themselves be presentations."
 $nl
@@ -16,54 +30,18 @@ $nl
 $nl
 "Clicking and holding the right mouse button on a presentation displays a popup menu listing available operations."
 $nl
-"Presentation gadgets can be constructed directly using the " { $link <presentation> } " word, and they can also be written to " { $link pane } " gadgets using the " { $link write-object } " word." ;
-
-ARTICLE: "ui-listener" "UI listener"
-"The graphical listener is based around the terminal listener (" { $link "listener" } ") and adds the following features:"
-{ $list
-    "Input history"
-    { "Completion (see " { $link "ui-completion" } ")" }
-    { "Clickable presentations (see " { $link "ui-presentations" } ")" }
-}
-{ $command-map listener-gadget "toolbar" }
-{ $command-map interactor "interactor" }
-{ $command-map source-editor "word" }
-{ $command-map interactor "quotation" }
-{ $heading "Editing commands" }
-"The text editing commands are standard; see " { $link "gadgets-editors" } "."
-{ $heading "Implementation" }
-"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } ")." ;
-
-ARTICLE: "ui-inspector" "UI inspector"
-"The graphical inspector builds on the terminal inspector (see " { $link "inspector" } ") and provides in-place editing of slot values."
-$nl
-"To display an object in the UI inspector, use the " { $link inspect } " word from the UI listener, or right-click a presentation and choose " { $strong "Inspect" } " from the menu that appears."
-$nl
-"When the UI inspector is running, all of the terminal inspector words are available, such as " { $link &at } " and " { $link &put } ". Changing slot values using terminal inspector words automatically updates the UI inspector display."
-$nl
-"Slots can also be edited graphically. Clicking the ellipsis to the left of the slot's textual representation displays a slot editor gadget. A text representation of the object can be edited in the slot editor. The parser is used to turn the text representation back into an object. Keep in mind that some structure is lost in the conversion; see " { $link "prettyprint-limitations" } "."
-$nl
-"The slot editor's text editing commands are standard; see " { $link "gadgets-editors" } "."
-$nl
-"The slot editor has a toolbar containing various commands."
-{ $command-map slot-editor "toolbar" }
-{ $command-map inspector-gadget "multi-touch" }
-"The following commands are also available."
-{ $command-map source-editor "word" } ;
-
-ARTICLE: "ui-browser" "UI browser"
-"The browser is used to display Factor code, documentation, and vocabularies."
-{ $command-map browser-gadget "toolbar" }
-{ $command-map browser-gadget "multi-touch" }
-"Browsers are instances of " { $link browser-gadget } "." ;
+"For more about presentation gadgets, see " { $link "ui.gadgets.presentations" } "." ;
 
 ARTICLE: "ui-profiler" "UI profiler" 
 "The graphical profiler is based on the terminal profiler (see " { $link "profiling" } ") and adds more convenient browsing of profiler results."
 $nl
 "To use the profiler, enter a piece of code in the listener input area and press " { $operation com-profile } "."
 $nl
-"Vocabulary and word presentations in the profiler pane can be clicked on to show profiler results pertaining to the object in question. Clicking a vocabulary in the profiler yields the same output as the " { $link vocab-profile. } " word, and clicking a word yields the same output as the " { $link usage-profile. } " word. Consult " { $link "profiling" } " for details."
-{ $command-map profiler-gadget "toolbar" } ;
+"Clicking on a vocabulary in the vocabulary list narrows down the word list to only include words from that vocabulary. The sorting options control the order of elements in the vocabulary and word lists. The search fields narrow down the list to only include words or vocabularies whose names contain a substring."
+$nl
+"Consult " { $link "profiling" } " for details about the profiler itself."
+{ $command-map profiler-gadget "toolbar" }
+"The profiler is an instance of " { $link profiler-gadget } "." ;
 
 ARTICLE: "ui-cocoa" "Functionality specific to Mac OS X"
 "On Mac OS X, the Factor UI offers additional features which integrate with this operating system."
@@ -76,49 +54,16 @@ $nl
 
 ;
 
-ARTICLE: "ui-completion-words" "Word completion popup"
-"Clicking a word in the word completion popup displays the word definition in the " { $link "ui-browser" } ". Pressing " { $snippet "RET" } " with a word selected inserts the word name in the listener, along with a " { $link POSTPONE: USE: } " declaration (if necessary)."
-{ $operations \ $operations } ;
-
-ARTICLE: "ui-completion-vocabs" "Vocabulary completion popup"
-"Clicking a vocabulary in the vocabulary completion popup displays a list of words in the vocabulary in another " { $link "ui-completion-words" } ". Pressing " { $snippet "RET" } " adds the vocabulary to the current search path, just as if you invoked " { $link POSTPONE: USE: } "."
-{ $operations "kernel" vocab } ;
-
-ARTICLE: "ui-completion-sources" "Source file completion popup"
-"The source file completion popup lists all source files which have been previously loaded by " { $link run-file } ". Clicking a source file  or pressing " { $snippet "RET" } " opens the source file in your editor with " { $link edit } "."
-{ $operations P" " } ;
-
-ARTICLE: "ui-completion" "UI completion popups"
-"Completion popups allow fast access to aspects of the environment. Completion popups can be invoked by clicking the row of buttons along the bottom of the workspace, or via keyboard commands:"
-{ $command-map workspace "toolbar" }
-"A completion popup instantly updates the list of completions as keys are typed. The list of completions can be navigated from the keyboard with the " { $snippet "UP" } " and " { $snippet "DOWN" } " arrow keys. Every completion has a " { $emphasis "primary action" } " and " { $emphasis "secondary action" } ". The primary action is invoked when clicking a completion, and the secondary action is invoked on the currently-selected completion when pressing " { $snippet "RET" } "."
-$nl
-"The primary and secondary actions, along with additional keyboard shortcuts, are documented for some completion popups in the below sections."
-{ $subsection "ui-completion-words" }
-{ $subsection "ui-completion-vocabs" }
-{ $subsection "ui-completion-sources" } ;
-
-ARTICLE: "ui-workspace-keys" "UI keyboard shortcuts"
-"See " { $link "gesture-differences" } " to find out how your platform's modifier keys map to modifiers in the Factor UI."
-{ $command-map workspace "tool-switching" }
-{ $command-map workspace "scrolling" }
-{ $command-map workspace "workflow" }
-{ $command-map workspace "multi-touch" } ;
-
 ARTICLE: "ui-tools" "UI developer tools"
-"The Factor development environment can seem rather different from what you are used to, because it is very simple and powerful.."
+"The " { $vocab-link "ui.tools" } " vocabulary hierarchy implements a collection of simple developer tools."
 $nl
-"To take full advantage of the UI, you should be using a supported text editor. See " { $link "editor" } "."
-{ $subsection "ui-workspace-keys" }
+"To take full advantage of the UI tools, you should be using a supported text editor. See " { $link "editor" } "."
+{ $subsection "ui-shortcuts" }
 { $subsection "ui-presentations" }
-{ $subsection "ui-completion" }
-{ $heading "Tools" }
-"A single-window " { $emphasis "workspace" } " contains the most frequently-used tools:"
 { $subsection "ui-listener" }
 { $subsection "ui-browser" }
 { $subsection "ui-inspector" }
 { $subsection "ui-profiler" }
-"Additional tools:"
 { $subsection "ui-walker" }
 { $subsection "ui.tools.deploy" }
 "Platform-specific features:"
diff --git a/basis/ui/tools/tools-tests.factor b/basis/ui/tools/tools-tests.factor
deleted file mode 100644 (file)
index 5ce9e4c..0000000
+++ /dev/null
@@ -1,58 +0,0 @@
-USING: ui.tools ui.tools.interactor ui.tools.listener
-ui.tools.search ui.tools.workspace kernel models namespaces
-sequences tools.test ui.gadgets ui.gadgets.buttons
-ui.gadgets.labelled ui.gadgets.presentations
-ui.gadgets.menus ui.gadgets.scrollers vocabs tools.test.ui ui accessors ;
-IN: ui.tools.tests
-
-[ f ]
-[
-    <gadget> 0 <model> >>model <workspace-tabs> children>> empty?
-] unit-test
-
-[ ] [ <workspace> "w" set ] unit-test
-[ ] [ "w" get com-scroll-up ] unit-test
-[ ] [ "w" get com-scroll-down ] unit-test
-[ t ] [
-    "w" get book>> children>>
-    [ tool-scroller ] map sift [ scroller? ] all?
-] unit-test
-[ ] [ "w" get hide-popup ] unit-test
-[ ] [ <gadget> "w" get show-popup ] unit-test
-[ ] [ "w" get hide-popup ] unit-test
-
-[ ] [
-    <gadget> "w" get show-popup
-    <gadget> "w" get show-popup
-    "w" get hide-popup
-] unit-test
-
-[ ] [ <workspace> [ ] with-grafted-gadget ] unit-test
-
-"w" get [
-
-    [ ] [ "w" get "kernel" vocab show-vocab-words ] unit-test
-
-    [ ] [ notify-queued ] unit-test
-
-    [ ] [ "w" get popup>> content>>
-    list>> gadget-child "p" set ] unit-test
-
-    [ t ] [ "p" get presentation? ] unit-test
-
-    [ ] [
-        "p" get [ object>> ] [ dup hook>> curry ] bi
-        <operations-menu> gadget-child gadget-child "c" set
-    ] unit-test
-
-    [ ] [ notify-queued ] unit-test
-
-    [ t ] [ "c" get button? ] unit-test
-
-    [ ] [
-        "w" get listener>> input>>
-        3 handle-parse-error
-    ] unit-test
-
-    [ ] [ notify-queued ] unit-test
-] with-grafted-gadget
index 9927f9e5ae9353683012f132d177cab5d3105b38..0b93807ca88ce5433bfd755ccac920dca514a3c7 100644 (file)
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs debugger ui.tools.workspace
-ui.tools.operations ui.tools.traceback ui.tools.browser
-ui.tools.inspector ui.tools.listener ui.tools.profiler
-ui.tools.operations inspector io kernel math models namespaces
-prettyprint quotations sequences ui ui.commands ui.gadgets
-ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
-ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
-ui.gadgets.presentations ui.gestures words vocabs.loader
-tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
-mirrors fry ;
+USING: memory system kernel tools.vocabs ui.tools.operations
+ui.tools.listener ui.tools.browser ui.tools.common ui.commands
+ui.gestures ui ;
 IN: ui.tools
 
-: <workspace-tabs> ( workspace -- tabs )
-    model>>
-        "tool-switching" workspace command-map commands>>
-        [ command-string ] { } assoc>map <enum> >alist
-    <toggle-buttons> ;
+: main ( -- )
+    restore-windows? [ restore-windows ] [ listener-window ] if ;
 
-: <workspace-book> ( workspace -- gadget )
-        <gadget>
-        <browser-gadget>
-        <inspector-gadget>
-        <profiler-gadget>
-    4array
-    swap model>> <book> ;
-  
-: <workspace> ( -- workspace )
-    { 0 1 } workspace new-track
-        0 <model> >>model
-        <listener-gadget> >>listener
-        dup <workspace-book> >>book
+MAIN: main
 
-        dup <workspace-tabs> f track-add
-        dup book>> 0 track-add
-        dup listener>> 1 track-add
-        add-toolbar ;
+\ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command
 
-: resize-workspace ( workspace -- )
-    dup sizes>> over control-value 0 = [
-        0 over set-second
-        1 swap set-third
-    ] [
-        2/3 over set-second
-        1/3 swap set-third
-    ] if relayout ;
+\ save H{ { +nullary+ t } } define-command
 
-M: workspace model-changed
-    nip
-    dup listener>> output>> scroll>bottom
-    dup resize-workspace
-    request-focus ;
+: com-exit ( -- ) 0 exit ;
 
-[ workspace-window ] ui-hook set-global
+\ com-exit H{ { +nullary+ t } } define-command
 
-: select-tool ( workspace n -- ) swap book>> model>> set-model ;
-
-: com-listener ( workspace -- ) 0 select-tool ;
-
-: com-browser ( workspace -- ) 1 select-tool ;
-
-: com-inspector ( workspace -- ) 2 select-tool ;
-
-: com-profiler ( workspace -- ) 3 select-tool ;
-
-workspace "tool-switching" f {
-    { T{ key-down f { A+ } "1" } com-listener }
-    { T{ key-down f { A+ } "2" } com-browser }
-    { T{ key-down f { A+ } "3" } com-inspector }
-    { T{ key-down f { A+ } "4" } com-profiler }
-} define-command-map
-
-workspace "multi-touch" f {
-    { T{ zoom-out-action } com-listener }
-    { T{ up-action } refresh-all }
+tool "tool-switching" f {
+    { T{ key-down f { A+ } "l" } show-listener }
+    { T{ key-down f { A+ } "L" } listener-window }
+    { T{ key-down f { A+ } "b" } show-browser }
+    { T{ key-down f { A+ } "B" } browser-window }
 } define-command-map
 
-\ workspace-window
-H{ { +nullary+ t } } define-command
-
-\ refresh-all
-H{ { +nullary+ t } { +listener+ t } } define-command
-
-workspace "workflow" f {
-    { T{ key-down f { C+ } "n" } workspace-window }
-    { T{ key-down f f "ESC" } hide-popup }
+tool "common" f {
+    { T{ key-down f { A+ } "s" } save }
+    { T{ key-down f { A+ } "w" } close-window }
+    { T{ key-down f { A+ } "q" } com-exit }
     { T{ key-down f f "F2" } refresh-all }
-} define-command-map
-
-[
-    <workspace> dup "Factor workspace" open-status-window
-] workspace-window-hook set-global
-
-: inspect-continuation ( traceback -- )
-    control-value '[ _ inspect ] call-listener ;
-
-traceback-gadget "toolbar" f {
-    { T{ key-down f f "v" } variables }
-    { T{ key-down f f "n" } inspect-continuation }
-} define-command-map
+} define-command-map
\ No newline at end of file
index 90f1e601c7fa740b43beb58ab28a58844f1904e7..e98787e1019a955c7eef8557e0e5e3d8f744b1f9 100644 (file)
@@ -1,11 +1,10 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors continuations kernel models namespaces
-       prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
-       ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
-       ui.gadgets.status-bar ui.gadgets.scrollers ui.gestures sequences
-       hashtables inspector ;
-
+prettyprint ui ui.commands ui.gadgets ui.gadgets.labelled assocs
+ui.gadgets.tracks ui.gadgets.buttons ui.gadgets.panes
+ui.gadgets.status-bar ui.gadgets.scrollers ui.tools.inspector
+ui.gestures sequences hashtables inspector ;
 IN: ui.tools.traceback
 
 : <callstack-display> ( model -- gadget )
@@ -54,3 +53,11 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
 
 : traceback-window ( continuation -- )
     <model> <traceback-gadget> "Traceback" open-status-window ;
+
+: inspect-continuation ( traceback -- )
+    control-value inspector ;
+
+traceback-gadget "toolbar" f {
+    { T{ key-down f f "v" } variables }
+    { T{ key-down f f "n" } inspect-continuation }
+} define-command-map
\ No newline at end of file
index e6643698c7c26415782855b9f35c2c103318a1d6..c5d6dd7cdc56f4b3a942a5fad695002a19e61af8 100644 (file)
@@ -1,18 +1,20 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel concurrency.messaging inspector
 ui.tools.listener ui.tools.traceback ui.gadgets.buttons
 ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
-models models.filter ui.tools.workspace ui.gestures
+models models.filter ui.tools.browser ui.tools.common ui.gestures
 ui.gadgets.labels ui threads namespaces make tools.walker assocs
 combinators fry ;
 IN: ui.tools.walker
 
-TUPLE: walker-gadget < track
+TUPLE: walker-gadget < tool
 status continuation thread
 traceback
 closing? ;
 
+{ 620 620 } walker-gadget set-tool-dim
+
 : walker-command ( walker msg -- )
     swap
     dup thread>> thread-registered?
@@ -66,7 +68,7 @@ M: walker-gadget focusable-child*
         dup status>> self <thread-status> f track-add
         dup traceback>> 1 track-add ;
     
-: walker-help ( -- ) "ui-walker" help-window ;
+: walker-help ( -- ) "ui-walker" com-follow ;
 
 \ walker-help H{ { +nullary+ t } } define-command
 
diff --git a/basis/ui/tools/workspace/authors.txt b/basis/ui/tools/workspace/authors.txt
deleted file mode 100644 (file)
index 1901f27..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/ui/tools/workspace/summary.txt b/basis/ui/tools/workspace/summary.txt
deleted file mode 100644 (file)
index f7e3245..0000000
+++ /dev/null
@@ -1 +0,0 @@
-Graphical development environment
diff --git a/basis/ui/tools/workspace/tags.txt b/basis/ui/tools/workspace/tags.txt
deleted file mode 100644 (file)
index ef1aab0..0000000
+++ /dev/null
@@ -1 +0,0 @@
-tools
diff --git a/basis/ui/tools/workspace/workspace-tests.factor b/basis/ui/tools/workspace/workspace-tests.factor
deleted file mode 100644 (file)
index 49b14cd..0000000
+++ /dev/null
@@ -1,4 +0,0 @@
-IN: ui.tools.workspace.tests
-USING: tools.test ui.tools ;
-
-\ <workspace> must-infer
diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor
deleted file mode 100644 (file)
index 3b689ee..0000000
+++ /dev/null
@@ -1,104 +0,0 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: classes continuations help help.topics kernel models
-sequences assocs arrays namespaces accessors math.vectors fry ui
-ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
-ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
-ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
-ui.gadgets.presentations ui.gadgets.status-bar ui.commands
-ui.gestures ;
-IN: ui.tools.workspace
-
-TUPLE: workspace < track book listener popup ;
-
-: find-workspace ( gadget -- workspace ) [ workspace? ] find-parent ;
-
-SYMBOL: workspace-window-hook
-
-: workspace-window* ( -- workspace ) workspace-window-hook get call ;
-
-: workspace-window ( -- ) workspace-window* drop ;
-
-GENERIC: call-tool* ( arg tool -- )
-
-GENERIC: tool-scroller ( tool -- scroller )
-
-M: gadget tool-scroller drop f ;
-
-: find-tool ( class workspace -- index tool )
-    book>> children>> [ class eq? ] with find ;
-
-: show-tool ( class workspace -- tool )
-    [ find-tool swap ] keep book>> model>>
-    set-model ;
-
-: get-workspace* ( quot -- workspace )
-    '[ dup workspace? _ [ drop f ] if ] find-window
-    [ dup raise-window gadget-child ]
-    [ workspace-window* ] if* ; inline
-
-: get-workspace ( -- workspace ) [ drop t ] get-workspace* ;
-
-: call-tool ( arg class -- )
-    get-workspace show-tool call-tool* ;
-
-: get-tool ( class -- gadget )
-    get-workspace find-tool nip ;
-
-: <help-pane> ( topic -- pane )
-    <pane> [ [ help ] with-pane ] keep ;
-
-: help-window ( topic -- )
-    [
-        <help-pane> <limited-scroller>
-            { 550 700 } >>max-dim
-    ] [ article-title ] bi
-    open-window ;
-
-: hide-popup ( workspace -- )
-    dup popup>> track-remove
-    f >>popup
-    request-focus ;
-
-: show-popup ( gadget workspace -- )
-    dup hide-popup
-    over >>popup
-    over f track-add drop
-    request-focus ;
-
-: show-titled-popup ( workspace gadget title -- )
-    [ find-workspace hide-popup ] <closable-gadget>
-    swap show-popup ;
-
-: debugger-popup ( error workspace -- )
-    swap dup compute-restarts
-    [ find-workspace hide-popup ] <debugger>
-    "Error" show-titled-popup ;
-
-SYMBOL: workspace-dim
-
-{ 600 700 } workspace-dim set-global
-
-M: workspace pref-dim* call-next-method workspace-dim get vmax ;
-
-M: workspace focusable-child*
-    dup popup>> [ ] [ listener>> ] ?if ;
-
-: workspace-page ( workspace -- gadget )
-    book>> current-page ;
-
-M: workspace tool-scroller ( workspace -- scroller )
-    workspace-page tool-scroller ;
-
-: com-scroll-up ( workspace -- )
-    tool-scroller [ scroll-up-page ] when* ;
-
-: com-scroll-down ( workspace -- )
-    tool-scroller [ scroll-down-page ] when* ;
-
-workspace "scrolling"
-"The current tool's scroll pane can be scrolled from the keyboard."
-{
-    { T{ key-down f { C+ } "PAGE_UP" } com-scroll-up }
-    { T{ key-down f { C+ } "PAGE_DOWN" } com-scroll-down }
-} define-command-map
index 64a98fee0392bec439bb9b6b3207c3824fa0fd3f..e7f2d3e290ba07e8fe44c6878f0f84446ccfde53 100644 (file)
@@ -36,8 +36,10 @@ HELP: unregister-window
 { $description "Removes a window from the global " { $link windows } " variable." }
 { $notes "This word should only be called only by the UI backend, and not user code." } ;
 
-HELP: ui
-{ $description "Starts the Factor UI." } ;
+HELP: (with-ui)
+{ $values { "quot" quotation } }
+{ $contract "Starts the Factor UI." }
+{ $notes "This is a low-level word; user code should call " { $link with-ui } " instead." } ;
 
 HELP: start-ui
 { $description "Called by the UI backend to initialize the platform-independent parts of UI. This word should be called after the backend is ready to start displaying new windows, and before the event loop starts." } ;
@@ -57,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 } } }
@@ -98,7 +103,8 @@ ARTICLE: "gadgets" "Pre-made UI gadgets"
 { $subsection "ui.gadgets.menus" }
 { $subsection "ui.gadgets.panes" }
 { $subsection "ui.gadgets.presentations" }
-{ $subsection "ui.gadgets.lists" } ;
+{ $subsection "ui.gadgets.lists" }
+{ $subsection "ui.gadgets.tables" } ;
 
 ARTICLE: "ui-geometry" "Gadget geometry"
 "The " { $link gadget } " class inherits from the " { $link rect } " class, and thus all gadgets have a bounding box:"
@@ -131,7 +137,7 @@ ARTICLE: "ui-backend" "Developing UI backends"
 "UI backends may implement the " { $link "clipboard-protocol" } "." ;
 
 ARTICLE: "ui-backend-init" "UI initialization and the event loop"
-"An UI backend is required to define a method on the " { $link ui } " word. This word should contain backend initialization, together with some boilerplate:"
+"An UI backend is required to define a method on the " { $link (with-ui) } " word. This word should contain backend initialization, together with some boilerplate:"
 { $code
     "IN: shells"
     ""
@@ -143,7 +149,7 @@ ARTICLE: "ui-backend-init" "UI initialization and the event loop"
 }
 "The above word must call the following:"
 { $subsection start-ui }
-"The " { $link ui } " word must not return until the event loop has stopped and the UI has been shut down." ;
+"The " { $link (with-ui) } " word must not return until the event loop has stopped and the UI has been shut down." ;
 
 ARTICLE: "ui-backend-windows" "UI backend window management"
 "The high-level " { $link open-window } " word eventually calls a low-level word which you must implement:"
@@ -235,16 +241,6 @@ $nl
 { $see-also "ui-layout-impl" } ;
 
 ARTICLE: "starting-ui" "Starting the UI"
-"The UI starts automatically where possible:"
-{ $list
-    { "On Windows, the UI starts when the Factor executable is run." }
-    { "On X11, the UI starts if the " { $snippet "DISPLAY" } " environment variable is set." }
-    { "On Mac OS X, the UI starts if the " { $snippet "Factor.app" } " application bundle is run." }
-}
-"In all cases, passing the " { $snippet "-run=listener" } " command line switch starts the terminal listener instead. The UI can be started from the terminal listener using a word:"
-{ $subsection ui }
-"To run the terminal listener and the UI simultaneously, start the UI in a new thread:"
-{ $code "USING: threads ui ;" "[ ui ] in-thread" }
 "The main word of a vocabulary implementing a UI application should use a combinator to ensure that the application works when run from the command line as well as in the UI listener:"
 { $subsection with-ui } ;
 
index 37ce4ea499316e04f091fc457d7acfe17ca5dcfa..5b270cdf9e43b27d9279b50480be7d12a7663b8e 100644 (file)
@@ -1,10 +1,10 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs io kernel math models namespaces make
-dlists deques sequences threads sequences words ui.gadgets
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend
-ui.render continuations init combinators hashtables
-concurrency.flags sets accessors calendar ;
+dlists deques sequences threads sequences words continuations
+init combinators hashtables concurrency.flags sets accessors
+calendar fry ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
+ui.gestures ui.backend ui.render ;
 IN: ui
 
 ! Assoc mapping aliens to gadgets
@@ -73,8 +73,6 @@ M: world ungraft*
     windows get values
     [ gadget-child swap call ] with find-last nip ; inline
 
-SYMBOL: ui-hook
-
 : init-ui ( -- )
     <dlist> \ graft-queue set-global
     <dlist> \ layout-queue set-global
@@ -96,14 +94,6 @@ SYMBOL: ui-hook
 : restore-world ( world -- )
     dup reset-world restore-gadget ;
 
-: restore-windows ( -- )
-    windows get [ values ] keep delete-all
-    [ restore-world ] each
-    forget-rollover ;
-
-: restore-windows? ( -- ? )
-    windows get empty? not ;
-
 : update-hand ( world -- )
     dup hand-world get-global eq?
     [ hand-loc get-global swap move-hand ] [ drop ] if ;
@@ -181,30 +171,27 @@ HOOK: close-window ui-backend ( gadget -- )
 M: object close-window
     find-world [ ungraft ] when* ;
 
-: start-ui ( -- )
-    restore-windows? [
-        restore-windows
-    ] [
-        init-ui ui-hook get call
-    ] if
-    notify-ui-thread start-ui-thread ;
+: start-ui ( quot -- )
+    call notify-ui-thread start-ui-thread ;
 
 [
     f \ ui-running set-global
     <flag> ui-notify-flag set-global
 ] "ui" add-init-hook
 
-HOOK: ui ui-backend ( -- )
+HOOK: (with-ui) ui-backend ( quot -- )
 
-MAIN: ui
+: restore-windows ( -- )
+    [
+        windows get [ values ] [ delete-all ] bi
+        [ restore-world ] each
+        forget-rollover
+    ] (with-ui) ;
+
+: restore-windows? ( -- ? )
+    windows get empty? not ;
 
 : with-ui ( quot -- )
-    ui-running? [
-        call
-    ] [
-        f windows set-global
-        [
-            ui-hook set
-            ui
-        ] with-scope
-    ] if ;
+    ui-running? [ call ] [ '[ init-ui @ ] (with-ui) ] if ;
+
+HOOK: beep ui-backend ( -- )
\ No newline at end of file
index c22fcb6cbefce746854294b19a1c36c465b0251e..a6e39000bfad4853bd49f3e78b3253b851b9ca3c 100755 (executable)
@@ -1,5 +1,5 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
-! Portions copyright (C) 2007, 2008 Slava Pestov.
+! Portions copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings arrays assocs ui
 ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds
@@ -540,6 +540,7 @@ M: win-base flush-gl-context ( handle -- )
 M: windows-ui-backend (open-offscreen-buffer) ( world -- )
     dup dim>> setup-offscreen-gl <win-offscreen>
     >>handle drop ;
+
 M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
     [ hDC>> DeleteDC drop ]
     [ hBitmap>> DeleteObject drop ] bi ;
@@ -560,18 +561,16 @@ M: windows-ui-backend offscreen-pixels ( world -- alien w h )
     [ (opaque-pixels) ] [ dim>> first2 ] bi ;
 
 M: windows-ui-backend raise-window* ( world -- )
-    handle>> [
-        hWnd>> SetFocus drop
-    ] when* ;
+    handle>> [ hWnd>> SetFocus drop ] when* ;
 
 M: windows-ui-backend set-title ( string world -- )
     handle>>
     dup title>> [ free ] when*
-    [ utf16n malloc-string ] dip
-    2dup (>>title)
-    hWnd>> WM_SETTEXT 0 roll alien-address SendMessage drop ;
+    swap utf16n malloc-string
+    [ >>title ]
+    [ [ hWnd>> WM_SETTEXT 0 ] dip alien-address SendMessage drop ] bi ;
 
-M: windows-ui-backend ui
+M: windows-ui-backend (with-ui)
     [
         [
             init-clipboard
@@ -586,4 +585,4 @@ M: windows-ui-backend beep ( -- )
 
 windows-ui-backend ui-backend set-global
 
-[ "ui" ] main-vocab-hook set-global
+[ "ui.tools" ] main-vocab-hook set-global
index 666ebf2f18b2f8eeb3a634810707f1b2a4550a3c..1c31f0125b74e82128c8d66856479663086e2761 100755 (executable)
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
+! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays ui ui.gadgets
 ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
@@ -277,7 +277,7 @@ M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
 M: x11-ui-backend offscreen-pixels ( world -- alien w h )
     [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
 
-M: x11-ui-backend ui ( -- )
+M: x11-ui-backend (with-ui) ( quot -- )
     [
         f [
             [
@@ -293,5 +293,5 @@ M: x11-ui-backend beep ( -- )
 
 x11-ui-backend ui-backend set-global
 
-[ "DISPLAY" os-env "ui" "listener" ? ]
+[ "DISPLAY" os-env "ui.tools" "listener" ? ]
 main-vocab-hook set-global
index 81ed91290c1236035943716d6d047d6874701b1d..396a5507b5d846535be4ac6c1b032a8c022712bb 100644 (file)
@@ -163,6 +163,7 @@ SYMBOL: interactive-vocabs
     "inspector"
     "io"
     "io.files"
+    "io.pathnames"
     "kernel"
     "listener"
     "math"
@@ -177,7 +178,9 @@ SYMBOL: interactive-vocabs
     "strings"
     "syntax"
     "tools.annotations"
+    "tools.apropos"
     "tools.crossref"
+    "tools.disassembler"
     "tools.memory"
     "tools.profiler"
     "tools.test"
diff --git a/extra/ui/gadgets/lists/authors.txt b/extra/ui/gadgets/lists/authors.txt
new file mode 100644 (file)
index 0000000..1901f27
--- /dev/null
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/extra/ui/gadgets/lists/lists-docs.factor b/extra/ui/gadgets/lists/lists-docs.factor
new file mode 100644 (file)
index 0000000..9003836
--- /dev/null
@@ -0,0 +1,32 @@
+USING: ui.commands help.markup help.syntax ui.gadgets
+ui.gadgets.presentations ui.operations kernel models classes ;
+IN: ui.gadgets.lists
+
+HELP: +secondary+
+{ $description "A key which may be set in the hashtable passed to " { $link define-operation } ". If set to a true value, this operation becomes the default operation performed when " { $snippet "RET" } " is pressed in a " { $link list } " gadget where the current selection is a presentation matching the operation's predicate." } ;
+
+HELP: list
+{ $class-description
+    "A list control is backed by a " { $link model } " holding a sequence of objects, and displays as a list of " { $link presentation } " instances of these objects."
+    $nl
+    "Lists are created by calling " { $link <list> } "."
+    { $command-map list "keyboard-navigation" }
+} ;
+
+HELP: <list>
+{ $values { "hook" { $quotation "( list -- )" } } { "presenter" { $quotation "( object -- label )" } } { "model" model } { "gadget" list } }
+{ $description "Creates a new " { $link list } "."
+$nl
+"The model value must be a sequence. The list displays presentations of elements with labels obtained by applying the " { $snippet "presenter" } " quotation to each object. The " { $snippet "hook" } " quotation is called when a presentation is selected." } ;
+
+HELP: list-value
+{ $values { "list" list } { "object" object } }
+{ $description "Outputs the currently selected list value." } ;
+
+ARTICLE: "ui.gadgets.lists" "List gadgets"
+"The " { $vocab-link "ui.gadgets.lists" } " vocabulary implements lists, which displays a list of presentations (see " { $link "ui.gadgets.presentations" } ")."
+{ $subsection list }
+{ $subsection <list> }
+{ $subsection list-value } ;
+
+ABOUT: "ui.gadgets.lists"
diff --git a/extra/ui/gadgets/lists/lists-tests.factor b/extra/ui/gadgets/lists/lists-tests.factor
new file mode 100644 (file)
index 0000000..bf2ad72
--- /dev/null
@@ -0,0 +1,5 @@
+IN: ui.gadgets.lists.tests
+USING: ui.gadgets.lists models prettyprint math tools.test
+kernel ;
+
+[ ] [ [ drop ] [ 3 + . ] f <model> <list> invoke-value-action ] unit-test
diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor
new file mode 100644 (file)
index 0000000..fbd9137
--- /dev/null
@@ -0,0 +1,128 @@
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.vectors classes.tuple math.geometry.rect colors
+kernel sequences models opengl math math.order namespaces
+ui.commands ui.gestures ui.render ui.gadgets
+ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
+ui.gadgets.theme ;
+IN: ui.gadgets.lists
+
+TUPLE: list < pack index presenter color hook ;
+
+: list-theme ( list -- list )
+    selection-color >>color ; inline
+
+: <list> ( hook presenter model -- gadget )
+    list new-gadget
+        { 0 1 } >>orientation
+        1 >>fill
+        0 >>index
+        swap >>model
+        swap >>presenter
+        swap >>hook
+        list-theme ;
+
+: calc-bounded-index ( n list -- m )
+    control-value length 1- min 0 max ;
+
+: bound-index ( list -- )
+    dup index>> over calc-bounded-index >>index drop ;
+
+: list-presentation-hook ( list -- quot )
+    hook>> [ [ list? ] find-parent ] prepend ;
+
+: <list-presentation> ( hook elt presenter -- gadget )
+    keep [ >label text-theme ] dip
+    <presentation>
+    swap >>hook ; inline
+
+: <list-items> ( list -- seq )
+    [ list-presentation-hook ]
+    [ presenter>> ]
+    [ control-value ]
+    tri [
+        [ 2dup ] dip swap <list-presentation>
+    ] map 2nip ;
+
+M: list model-changed
+    nip
+    dup clear-gadget
+    dup <list-items> add-gadgets
+    bound-index ;
+
+: selected-rect ( list -- rect )
+    dup index>> swap children>> ?nth ;
+
+M: list draw-gadget*
+    origin get [
+        dup color>> gl-color
+        selected-rect [
+            dup loc>> [
+                dim>> gl-fill-rect
+            ] with-translation
+        ] when*
+    ] with-translation ;
+
+M: list focusable-child* drop t ;
+
+: list-value ( list -- object )
+    dup index>> swap control-value ?nth ;
+
+: scroll>selected ( list -- )
+    #! We change the rectangle's width to zero to avoid
+    #! scrolling right.
+    [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
+    scroll>rect ;
+
+: list-empty? ( list -- ? ) control-value empty? ;
+
+: select-index ( n list -- )
+    dup list-empty? [
+        2drop
+    ] [
+        tuck control-value length rem >>index
+        [ relayout-1 ] [ scroll>selected ] bi
+    ] if ;
+
+: select-previous ( list -- )
+    [ index>> 1- ] keep select-index ;
+
+: select-next ( list -- )
+    [ index>> 1+ ] keep select-index ;
+
+: invoke-value-action ( list -- )
+    dup list-empty? [
+        dup hook>> call
+    ] [
+        [ index>> ] keep nth-gadget invoke-secondary
+    ] if ;
+
+: select-gadget ( gadget list -- )
+    tuck children>> index
+    [ swap select-index ] [ drop ] if* ;
+
+: clamp-loc ( point max -- point )
+    vmin { 0 0 } vmax ;
+
+: select-at ( point list -- )
+    [ rect-dim clamp-loc ] keep
+    [ pick-up ] keep
+    select-gadget ;
+
+: list-page ( list vec -- )
+    [ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
+    v* v+ swap select-at ;
+
+: list-page-up ( list -- ) { 0 -1 } list-page ;
+
+: list-page-down ( list -- ) { 0 1 } list-page ;
+
+list "keyboard-navigation" "Lists can be navigated from the keyboard." {
+    { T{ button-down } request-focus }
+    { T{ key-down f f "UP" } select-previous }
+    { T{ key-down f f "DOWN" } select-next }
+    { T{ key-down f f "PAGE_UP" } list-page-up }
+    { T{ key-down f f "PAGE_DOWN" } list-page-down }
+    { T{ key-down f f "RET" } invoke-value-action }
+} define-command-map
diff --git a/extra/ui/gadgets/lists/summary.txt b/extra/ui/gadgets/lists/summary.txt
new file mode 100644 (file)
index 0000000..f0b84e7
--- /dev/null
@@ -0,0 +1 @@
+List gadgets display a keyboard-navigatable list of presentations