-{
- 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>
<?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>
: 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
<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
! 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 ;
: 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 )
{
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 ;
: ((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+ ;
[ 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
drop
[ [ f ] 2dip (next-word) ] (word-elt) ;
-TUPLE: word-elt ;
+SINGLETON: word-elt
M: word-elt prev-elt
drop
[ [ ((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 ;
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 ;
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 } ;
[ 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
-! 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 ;
: 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
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
: 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
! 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.
: ($long-link) ( object -- )
[ article-title ] [ >link ] bi write-link ;
+: $long-link ( object -- )
+ first ($long-link) ;
+
: ($subsection) ( element quot -- )
[
subsection-style get [
"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
GENERIC: elements* ( elt-type element -- )
-M: simple-element elements* [ elements* ] with each ;
+M: simple-element elements*
+ [ elements* ] with each ;
M: object elements* 2drop ;
: 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 ;
-! 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
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
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
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"
{ $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
$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:"
$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" }
-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"
{ $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."
"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." } ;
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." } ;
[ "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
-! 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 ;
: :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 ;
: &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 ;
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
-! 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 ;
! Presentation
SYMBOL: presented
-SYMBOL: presented-path
-SYMBOL: presented-printer
SYMBOL: href
--- /dev/null
+! 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
--- /dev/null
+! 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
{ $subsection "opengl-geometric-primitives" }
{ $subsection "opengl-modeling-transformations" } ;
-ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
+ARTICLE: "opengl-specifying-vertices" "Specifying vertices"
{ $subsection glVertex2d }
{ $subsection glVertex2f }
{ $subsection glVertex4iv }
{ $subsection glVertex4sv } ;
-ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
+ARTICLE: "opengl-geometric-primitives" "OpenGL geometric primitives"
{ $table
{ { $link GL_POINTS } "individual points" }
{ $link GL_LINE }
{ $link GL_FILL } } } } } ;
-ARTICLE: "opengl-modeling-transformations" "Modeling Transformations"
+ARTICLE: "opengl-modeling-transformations" "Modeling transformations"
{ $subsection glTranslatef }
{ $subsection glTranslated }
{ $subsection glRotatef }
: .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
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 ;
--- /dev/null
+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." } ;
--- /dev/null
+IN: tools.apropos.tests
+USING: tools.apropos tools.test ;
+
+[ ] [ "swp" apropos ] unit-test
--- /dev/null
+! 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 ;
! 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
] [
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
ARTICLE: "tools.crossref" "Cross-referencing tools"
{ $subsection usage. }
-{ $subsection apropos }
{ $see-also "definitions" "words" see see-methods } ;
ABOUT: "tools.crossref"
{ $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." } ;
-! 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. ;
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. ( -- )
"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. ;
+++ /dev/null
-IN: tools.test.tests
-USING: completion words sequences test ;
-
-[ ] [ "swp" apropos ] unit-test
-[ f ] [ "swp" words-matching empty? ] unit-test
ARTICLE: "vocab-index" "Vocabulary index"
{ $subsection "vocab-tags" }
{ $subsection "vocab-authors" }
-{ $describe-vocab "" } ;
+{ $vocab "" } ;
HELP: words.
{ $values { "vocab" "a vocabulary name" } }
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
: 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 ;
] 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 [
[
[ <$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
"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) ;
[ <$link> 1array ] map $table
] unless-empty ;
-: describe-words ( vocab -- )
- words [
+: $words ( words -- )
+ [
"Words" $heading
natural-sort
: words. ( vocab -- )
last-element off
- vocab-name describe-words ;
+ words $words ;
: describe-metadata ( vocab -- )
[
] { } 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 ;
[ 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 ;
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" ;
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
-! 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
[ "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
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
-! 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 -- )
[ [ 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" }
[ 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 ( -- )
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"
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 ;
{ $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> } ;
{ $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> }
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 ;
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
"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" }
<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
<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
\ <editor> must-infer
-"hello" <model> <field> "field" set
+"hello" <model> <model-field> "field" set
"field" get [
[ "hello" ] [ "field" get field-model>> value>> ] unit-test
! 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
: 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? ;
[ [ [ 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 }
dup selection-start/end drop
over set-caret mark>caret
] [
- T{ char-elt } editor-prev
+ char-elt editor-prev
] if ;
: next-character ( editor -- )
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 }
{ 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?
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 }
{ 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 }
: <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 }
: <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
{ 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
{ <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:"
{ <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> }
+++ /dev/null
-Slava Pestov
+++ /dev/null
-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"
+++ /dev/null
-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
+++ /dev/null
-! 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
+++ /dev/null
-List gadgets display a keyboard-navigatable list of presentations
{ 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> }
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 ;
] 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." ;
-! 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
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
: 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 ;
{ $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"
{ $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:"
--- /dev/null
+! 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
{ <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> }
-! 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 ;
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 }
} 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
{ 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 ;
--- /dev/null
+! 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* ;
--- /dev/null
+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
--- /dev/null
+! 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
--- /dev/null
+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
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
-! 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 ;
} 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
{ 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
--- /dev/null
+! 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 ;
-! 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 )
close-window ;
: com-help ( -- )
- "ui.tools.deploy" help-window ;
+ "ui.tools.deploy" com-follow ;
\ com-help H{
{ +nullary+ t }
--- /dev/null
+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
--- /dev/null
+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
-! 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-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." } ;
+++ /dev/null
-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
+++ /dev/null
-! 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
+++ /dev/null
-Interactors are used to input Factor code
--- /dev/null
+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
-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
] 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
-! 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 ;
[ 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 -- )
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 ;
[ 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* ;
{
[ 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
{ 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
-! 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 ;
V{ } clone operations set-global
! Objects
-[ drop t ] \ inspect H{
+[ drop t ] \ inspector H{
{ +primary+ t }
- { +listener+ t }
} define-operation
: com-prettyprint ( obj -- ) . ;
: 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 }
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
} 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
} 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
} 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
{ +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"
-! 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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-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
+++ /dev/null
-! 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
+++ /dev/null
-Support for graphical completion popups
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
$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."
;
-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:"
+++ /dev/null
-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
-! 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
-! 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 )
: 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
-! 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?
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
+++ /dev/null
-Slava Pestov
+++ /dev/null
-Graphical development environment
+++ /dev/null
-IN: ui.tools.workspace.tests
-USING: tools.test ui.tools ;
-
-\ <workspace> must-infer
+++ /dev/null
-! 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
{ $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." } ;
{ $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 } } }
{ $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:"
"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"
""
}
"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:"
{ $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 } ;
-! 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
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
: 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 ;
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
! 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
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 ;
[ (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
windows-ui-backend ui-backend set-global
-[ "ui" ] main-vocab-hook set-global
+[ "ui.tools" ] main-vocab-hook set-global
-! 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
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 [
[
x11-ui-backend ui-backend set-global
-[ "DISPLAY" os-env "ui" "listener" ? ]
+[ "DISPLAY" os-env "ui.tools" "listener" ? ]
main-vocab-hook set-global
"inspector"
"io"
"io.files"
+ "io.pathnames"
"kernel"
"listener"
"math"
"strings"
"syntax"
"tools.annotations"
+ "tools.apropos"
"tools.crossref"
+ "tools.disassembler"
"tools.memory"
"tools.profiler"
"tools.test"
--- /dev/null
+Slava Pestov
--- /dev/null
+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"
--- /dev/null
+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
--- /dev/null
+! 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
--- /dev/null
+List gadgets display a keyboard-navigatable list of presentations