From 2620a101071c345c329e868da316ad362a45170e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 20:34:49 -0600 Subject: [PATCH 01/19] Display help in browser tool --- basis/help/help-docs.factor | 9 +++++++-- basis/help/help.factor | 9 ++++++++- basis/ui/tools/browser/browser.factor | 19 ++++++++++--------- 3 files changed, 25 insertions(+), 12 deletions(-) diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor index 277d965e39..4a06235c69 100644 --- a/basis/help/help-docs.factor +++ b/basis/help/help-docs.factor @@ -129,12 +129,17 @@ HELP: $title { $values { "topic" "a help article name or a word" } } { $description "Prints a help article's title, or a word's " { $link summary } ", depending on the type of " { $snippet "topic" } "." } ; +HELP: print-topic +{ $values { "topic" "an article name or a word" } } +{ $description + "Displays a help topic on " { $link output-stream } "." +} ; + HELP: help { $values { "topic" "an article name or a word" } } { $description - "Displays a help article or documentation associated to a word on " { $link output-stream } "." + "Displays a help topic." } ; - HELP: about { $values { "vocab" "a vocabulary specifier" } } { $description diff --git a/basis/help/help.factor b/basis/help/help.factor index 686578f1b6..f9775e2668 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -89,10 +89,17 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ] with-nesting ] with-style nl ; -: help ( topic -- ) +: print-topic ( topic -- ) last-element off dup $title article-content print-content nl ; +SYMBOL: help-hook + +help-hook global [ [ print-topic ] or ] change-at + +: help ( topic -- ) + help-hook get call ; + : about ( vocab -- ) dup require dup vocab [ ] [ diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 83a3b7ff68..b717bbb2f9 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -4,17 +4,17 @@ 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 ; +accessors fry combinators.short-circuit ; IN: ui.tools.browser TUPLE: browser-gadget < track pane history ; : show-help ( link help -- ) - dup history>> add-history - >r >link r> history>> set-model ; + history>> dup add-history + [ >link ] dip set-model ; : ( browser-gadget -- gadget ) - history>> [ [ help ] curry try ] ; + history>> [ '[ _ print-topic ] try ] ; : init-history ( browser-gadget -- ) "handbook" >link >>history drop ; @@ -22,7 +22,7 @@ TUPLE: browser-gadget < track pane history ; : ( -- gadget ) { 0 1 } browser-gadget new-track dup init-history - dup f track-add + add-toolbar dup >>pane dup pane>> 1 track-add ; @@ -38,10 +38,11 @@ M: browser-gadget ungraft* [ call-next-method ] [ remove-definition-observer ] bi ; : showing-definition? ( defspec assoc -- ? ) - [ key? ] 2keep - [ >r dup word-link? [ name>> ] when r> key? ] 2keep - >r dup vocab-link? [ vocab ] when r> key? - or or ; + { + [ key? ] + [ [ dup word-link? [ name>> ] when ] dip key? ] + [ [ dup vocab-link? [ vocab ] when ] dip key? ] + } 2|| ; M: browser-gadget definitions-changed ( assoc browser -- ) history>> From 98d109a9a8caf8bc1d62a9f964c46cc6c6ce381b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 20:35:01 -0600 Subject: [PATCH 02/19] Rename do-what-i-mean? to auto-use? --- core/parser/parser.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 007120fd19..414e9ea499 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -82,17 +82,20 @@ ERROR: no-word-error name ; SYMBOL: amended-use? -SYMBOL: do-what-i-mean? +SYMBOL: auto-use? : no-word-restarted ( restart-value -- word ) - dup word? - [ amended-use? on dup vocabulary>> (use+) ] - [ create-in ] - if ; + dup word? [ + amended-use? on + dup vocabulary>> + [ (use+) ] [ + "Added ``" swap "'' vocabulary to search path" 3append note. + ] bi + ] [ create-in ] if ; : no-word ( name -- newword ) dup words-named [ forward-reference? not ] filter - dup length 1 = do-what-i-mean? get and + dup length 1 = auto-use? get and [ nip first no-word-restarted ] [ throw-restarts no-word-restarted ] if ; From 00869b6ad4df23591182d6ad677a267ad61ace35 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 20:35:58 -0600 Subject: [PATCH 03/19] Documentation update --- basis/prettyprint/prettyprint-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/prettyprint/prettyprint-docs.factor b/basis/prettyprint/prettyprint-docs.factor index 159421c18c..3c004e5b30 100644 --- a/basis/prettyprint/prettyprint-docs.factor +++ b/basis/prettyprint/prettyprint-docs.factor @@ -17,7 +17,8 @@ ARTICLE: "prettyprint-stacks" "Prettyprinting stacks" "Prettyprinting any stack:" { $subsection stack. } "Prettyprinting any call stack:" -{ $subsection callstack. } ; +{ $subsection callstack. } +"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." ; ARTICLE: "prettyprint-variables" "Prettyprint control variables" "The following variables affect the " { $link . } " and " { $link pprint } " words if set in the current dynamic scope:" From 25ec44b0b31ee774b2b7d65bfb5d6945bcc44a64 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 20:37:34 -0600 Subject: [PATCH 04/19] Listener now displays stacks and can watch variables --- basis/listener/listener-docs.factor | 25 +++++++----- basis/listener/listener.factor | 59 +++++++++++++++++++++++------ 2 files changed, 62 insertions(+), 22 deletions(-) diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index beea9005b4..9b2903970a 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -1,34 +1,39 @@ USING: help.markup help.syntax kernel io system prettyprint ; IN: listener +ARTICLE: "listener-watch" "Watching variables in the listener" +"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:" +{ $subsection visible-vars } +"To add or remove a single variable:" +{ $subsection watch-var } +{ $subsection unwatch-var } +"To add and remove multiple variables:" +{ $subsection watch-vars } +{ $subsection unwatch-vars } ; + ARTICLE: "listener" "The listener" "The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it." $nl "The classical first program can be run in the listener:" { $example "\"Hello, world\" print" "Hello, world" } -"Multi-line phrases are supported:" +"Multi-line expressions are supported:" { $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" } "The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them." -$nl -"A very common operation is to inspect the contents of the data stack in the listener:" -{ $subsection .s } -"Note that calls to " { $link .s } " can also be included inside words as a debugging aid, however a more convenient way to achieve this is to use the annotation facility. See " { $link "tools.annotations" } "." -$nl +{ $subsection "listener-watch" } "You can start a nested listener or exit a listener using the following words:" { $subsection listener } { $subsection bye } -"The following variables can be rebound inside a nested scope to customize the behavior of a listener; this can be done to create a development tool with a custom interaction loop:" -{ $subsection listener-hook } "Finally, the multi-line expression reading word can be used independently of the rest of the listener:" { $subsection read-quot } ; ABOUT: "listener" + HELP: read-quot { $values { "quot/f" "a parsed quotation, or " { $link f } " indicating end of file" } } diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index feddbdc042..ee16f6369a 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -3,16 +3,10 @@ USING: arrays hashtables io kernel math math.parser memory namespaces parser lexer sequences strings io.styles vectors words generic system combinators continuations debugger -definitions compiler.units accessors colors ; - +definitions compiler.units accessors colors prettyprint fry +sets ; IN: listener -SYMBOL: quit-flag - -SYMBOL: listener-hook - -[ ] listener-hook set-global - GENERIC: stream-read-quot ( stream -- quot/f ) : parse-lines-interactive ( lines -- quot/f ) @@ -38,18 +32,57 @@ M: object stream-read-quot : read-quot ( -- quot/f ) input-stream get stream-read-quot ; + + : bye ( -- ) quit-flag on ; -: prompt. ( -- ) - "( " in get " )" 3append - H{ { background T{ rgba f 1 0.7 0.7 1 } } } format bl flush ; +SYMBOL: visible-vars + +: watch-var ( sym -- ) visible-vars [ swap suffix ] change ; + +: watch-vars ( seq -- ) visible-vars [ swap union ] change ; + +: unwatch-var ( sym -- ) visible-vars [ remove ] change ; + +: unwatch-vars ( seq -- ) visible-vars [ swap diff ] change ; SYMBOL: error-hook [ print-error-and-restarts ] error-hook set-global + + : listener ( -- ) [ until-quit ] with-interactive-vocabs ; From 3b037c89474341fcfff8eddfea52714758fcd59c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 21:54:07 -0600 Subject: [PATCH 05/19] Fix load error in tools.deploy.shaker --- basis/tools/deploy/shaker/shaker.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 1992dbcda3..f5778e410f 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -266,8 +266,7 @@ IN: tools.deploy.shaker layouts:tag-numbers layouts:type-numbers lexer-factory - listener:listener-hook - parser:print-use-hook + print-use-hook root-cache vocab-roots vocabs:dictionary From 786ca76d02245480b5cb28a0f8acab6379b005be Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 21:54:28 -0600 Subject: [PATCH 06/19] Listener now displays stacks and watched variables --- basis/listener/listener-docs.factor | 8 ++++---- basis/listener/listener.factor | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/basis/listener/listener-docs.factor b/basis/listener/listener-docs.factor index 9b2903970a..8ef49ca0d9 100644 --- a/basis/listener/listener-docs.factor +++ b/basis/listener/listener-docs.factor @@ -5,11 +5,11 @@ ARTICLE: "listener-watch" "Watching variables in the listener" "The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:" { $subsection visible-vars } "To add or remove a single variable:" -{ $subsection watch-var } -{ $subsection unwatch-var } +{ $subsection show-var } +{ $subsection hide-var } "To add and remove multiple variables:" -{ $subsection watch-vars } -{ $subsection unwatch-vars } ; +{ $subsection show-vars } +{ $subsection hide-vars } ; ARTICLE: "listener" "The listener" "The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it." diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index ee16f6369a..5d58cafe29 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -42,13 +42,13 @@ PRIVATE> SYMBOL: visible-vars -: watch-var ( sym -- ) visible-vars [ swap suffix ] change ; +: show-var ( sym -- ) visible-vars [ swap suffix ] change ; -: watch-vars ( seq -- ) visible-vars [ swap union ] change ; +: show-vars ( seq -- ) visible-vars [ swap union ] change ; -: unwatch-var ( sym -- ) visible-vars [ remove ] change ; +: hide-var ( sym -- ) visible-vars [ remove ] change ; -: unwatch-vars ( seq -- ) visible-vars [ swap diff ] change ; +: hide-vars ( seq -- ) visible-vars [ swap diff ] change ; SYMBOL: error-hook From 2e2856b9a490e80a568cdebbba8e389535619d5f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 21:54:38 -0600 Subject: [PATCH 07/19] Document auto-use? feature --- core/parser/parser-docs.factor | 20 +++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d3c2cff19d..92e5922802 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -41,13 +41,15 @@ $nl } "The " { $vocab-link "qualified" } " vocabulary contains some tools for helping with shadowing." ; -ARTICLE: "vocabulary-search-errors" "Word lookup errors" -"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies. Then, one of three things happen:" -{ $list - { "If there are no words having this name at all, an error is thrown and parsing stops." } - { "If there are vocabularies which contain words with this name, a restartable error is thrown, with a restart for each vocabulary in question. The restarts add the vocabulary to the search path and continue parsing." } -} -"When writing a new vocabulary, one approach is to ignore " { $link POSTPONE: USING: } " declarations altogether, then to load the vocabulary and observe any parser notes and restarts and use this information to write the correct " { $link POSTPONE: USING: } " declaration." ; +ARTICLE: "vocabulary-search-errors" "Word lookup errors" +"If the parser cannot not find a word in the current vocabulary search path, it attempts to look for the word in all loaded vocabularies." +$nl +"If " { $link auto-use? } " mode is off, a restartable error is thrown with a restart for each vocabulary in question, together with a restart which defers the word in the current vocabulary, as if " { $link POSTPONE: DEFER: } " was used." +$nl +"If " { $link auto-use? } " mode is on and only one vocabulary has a word with this name, the vocabulary is added to the search path and parsing continues." +$nl +"If any restarts were invoked, or if " { $link auto-use? } " is on, the parser will print the correct " { $link POSTPONE: USING: } " after parsing completes. This form can be copy and pasted back into the source file." +{ $subsection auto-use? } ; ARTICLE: "vocabulary-search" "Vocabulary search path" "When the parser reads a token, it attempts to look up a word named by that token. The lookup is performed by searching each vocabulary in the search path, in order." @@ -353,3 +355,7 @@ HELP: staging-violation { $description "Throws a " { $link staging-violation } " error." } { $error-description "Thrown by the parser if a parsing word is used in the same compilation unit as where it was defined; see " { $link "compilation-units" } "." } { $notes "One possible workaround is to use the " { $link POSTPONE: << } " word to execute code at parse time. However, executing words defined in the same source file at parse time is still prohibited." } ; + +HELP: auto-use? +{ $var-description "If set to a true value, the behavior of the parser when encountering an unknown word name is changed. If only one loaded vocabulary has a word with this name, instead of throwing an error, the parser adds the vocabulary to the search path and prints a parse note. Off by default." } +{ $notes "This feature is intended to help during development. To generate a " { $link POSTPONE: USING: } " form automatically, enable " { $link auto-use? } ", load the source file, and copy and paste the " { $link POSTPONE: USING: } " form printed by the parser back into the file, then disable " { $link auto-use? } ". See " { $link "vocabulary-search-errors" } "." } ; From 2eac58c271e2eaaeacb25931905ef87e2ecc292d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 21:57:56 -0600 Subject: [PATCH 08/19] Fix '0 track-add' --- basis/ui/gadgets/tracks/tracks-tests.factor | 7 +++++++ basis/ui/gadgets/tracks/tracks.factor | 8 ++++++-- 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/basis/ui/gadgets/tracks/tracks-tests.factor b/basis/ui/gadgets/tracks/tracks-tests.factor index 93f2d14528..5381eebb01 100644 --- a/basis/ui/gadgets/tracks/tracks-tests.factor +++ b/basis/ui/gadgets/tracks/tracks-tests.factor @@ -14,3 +14,10 @@ IN: ui.gadgets.tracks.tests { 100 100 } >>dim 1 track-add pref-dim ] unit-test + +[ { 10 10 } ] [ + { 0 1 } + { 10 10 } >>dim 1 track-add + { 10 10 } >>dim 0 track-add + pref-dim +] unit-test diff --git a/basis/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor index 771c489ce3..dc176b5bf7 100644 --- a/basis/ui/gadgets/tracks/tracks.factor +++ b/basis/ui/gadgets/tracks/tracks.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors io kernel namespaces fry math math.vectors math.geometry.rect math.order -sequences words ui.gadgets ui.gadgets.packs ; +sequences words ui.gadgets ui.gadgets.packs ui.gadgets.buttons ; IN: ui.gadgets.tracks @@ -41,7 +41,8 @@ M: track layout* ( track -- ) dup track-layout pack-layout ; : track-pref-dims-2 ( track -- dim ) [ [ children>> pref-dims ] [ normalized-sizes ] bi - [ [ v/n ] when* ] 2map max-dim [ >fixnum ] map + [ dup { 0 f } memq? [ drop ] [ v/n ] if ] 2map + max-dim [ >fixnum ] map ] [ [ gap>> ] [ children>> length 1 [-] ] bi v*n ] bi v+ ; @@ -56,6 +57,9 @@ M: track pref-dim* ( gadget -- dim ) : track-add ( track gadget constraint -- track ) pick sizes>> push add-gadget ; +: add-toolbar ( track -- track ) + dup f track-add ; + : track-remove ( track gadget -- track ) dupd dup [ [ swap children>> index ] From f27ebdd1ef225344101fe9793a6013cee2b62a49 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 21:58:30 -0600 Subject: [PATCH 09/19] Use add-toolbar word in a few places --- basis/ui/gadgets/slots/slots.factor | 2 +- basis/ui/tools/debugger/debugger.factor | 2 +- basis/ui/tools/inspector/inspector.factor | 2 +- basis/ui/tools/profiler/profiler.factor | 2 +- basis/ui/tools/search/search.factor | 72 ++++++++++++----------- basis/ui/tools/traceback/traceback.factor | 2 +- basis/ui/tools/walker/walker.factor | 4 +- basis/ui/tools/workspace/workspace.factor | 18 +++--- 8 files changed, 53 insertions(+), 51 deletions(-) diff --git a/basis/ui/gadgets/slots/slots.factor b/basis/ui/gadgets/slots/slots.factor index 1cf23e2d06..ff2220b60e 100644 --- a/basis/ui/gadgets/slots/slots.factor +++ b/basis/ui/gadgets/slots/slots.factor @@ -71,7 +71,7 @@ M: value-ref finish-editing : ( ref -- gadget ) { 0 1 } slot-editor new-track swap >>ref - dup f track-add + add-toolbar >>text dup text>> 1 track-add dup revert ; diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index 1f019fca7c..641763c0b1 100644 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -25,7 +25,7 @@ TUPLE: debugger < track restarts ; : ( error restarts restart-hook -- gadget ) { 0 1 } debugger new-track - dup f track-add + add-toolbar -rot >>restarts dup restarts>> rot 1 track-add ; diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor index dcb3a3f8ad..579210325b 100644 --- a/basis/ui/tools/inspector/inspector.factor +++ b/basis/ui/tools/inspector/inspector.factor @@ -17,7 +17,7 @@ TUPLE: inspector-gadget < track object pane ; : ( -- gadget ) { 0 1 } inspector-gadget new-track - dup f track-add + add-toolbar >>pane dup pane>> 1 track-add ; diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor index c60d0dac09..05d1ccdb82 100644 --- a/basis/ui/tools/profiler/profiler.factor +++ b/basis/ui/tools/profiler/profiler.factor @@ -9,7 +9,7 @@ TUPLE: profiler-gadget < track pane ; : ( -- gadget ) { 0 1 } profiler-gadget new-track - dup f track-add + add-toolbar >>pane dup pane>> 1 track-add ; diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor index 3081eb1cdc..033aacc1b3 100644 --- a/basis/ui/tools/search/search.factor +++ b/basis/ui/tools/search/search.factor @@ -1,14 +1,14 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs ui.tools.interactor ui.tools.listener -ui.tools.workspace help help.topics io.files io.styles kernel -models models.delay models.filter namespaces prettyprint +USING: accessors assocs help help.topics io.files io.styles +kernel models models.delay models.filter namespaces prettyprint quotations sequences sorting source-files definitions strings -tools.completion tools.crossref classes.tuple ui.commands -ui.gadgets ui.gadgets.editors ui.gadgets.lists -ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations -vocabs words vocabs.loader tools.vocabs unicode.case calendar ui -; +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 ; @@ -23,7 +23,7 @@ TUPLE: live-search < track field list ; M: live-search handle-gesture ( gesture live-search -- ? ) tuck search-gesture dup [ over find-workspace hide-popup - >r search-value r> invoke-command f + [ search-value ] dip invoke-command f ] [ 2drop t ] if ; @@ -47,27 +47,29 @@ search-field H{ { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] } } set-gestures -: ( live-search producer -- live-search filter ) - >r dup field>> model>> - ui-running? [ 1/5 seconds ] when - [ "\n" join ] r> append ; +: ( live-search producer -- filter ) + [ + field>> model>> + ui-running? [ 1/5 seconds ] when + ] dip [ "\n" join ] prepend ; -: ( live-search seq limited? presenter -- live-search list ) - >r - [ limited-completions ] [ completions ] ? curry - - >r [ find-workspace hide-popup ] r> r> - swap ; +: init-search-model ( live-search seq limited? -- live-search ) + [ 2drop ] + [ [ limited-completions ] [ completions ] ? curry ] 3bi + >>model ; inline -: ( string seq limited? presenter -- gadget ) +: ( presenter live-search -- list ) + [ [ find-workspace hide-popup ] ] [ ] [ model>> ] tri* ; + +:: ( string seq limited? presenter -- gadget ) { 0 1 } live-search new-track >>field - dup field>> f track-add - -roll >>list + seq limited? init-search-model + presenter over >>list + dup field>> 1 { 0 0 } >>align f track-add dup list>> 1 track-add - swap - over field>> set-editor-string - dup field>> end-of-document ; + string over field>> set-editor-string + dup field>> end-of-document ; M: live-search focusable-child* field>> ; @@ -80,26 +82,27 @@ M: live-search pref-dim* drop { 400 200 } ; [ dup synopsis >lower ] { } map>assoc sort-values ; : ( string words limited? -- gadget ) - >r definition-candidates r> [ synopsis ] ; + [ definition-candidates ] dip [ synopsis ] ; : word-candidates ( words -- candidates ) [ dup name>> >lower ] { } map>assoc ; : ( string words limited? -- gadget ) - >r word-candidates r> [ synopsis ] ; + [ word-candidates ] dip [ synopsis ] ; : com-words ( workspace -- ) dup current-word all-words t "Word search" show-titled-popup ; : show-vocab-words ( workspace vocab -- ) - "" over words natural-sort f - "Words in " rot vocab-name append show-titled-popup ; + [ "" swap words natural-sort f ] + [ "Words in " swap vocab-name append ] + bi show-titled-popup ; : show-word-usage ( workspace word -- ) - "" over smart-usage f - "Words and methods using " rot name>> append - show-titled-popup ; + [ "" swap smart-usage f ] + [ "Words and methods using " swap name>> append ] + bi show-titled-popup ; : help-candidates ( seq -- candidates ) [ dup >link swap article-title >lower ] { } map>assoc @@ -127,8 +130,9 @@ M: live-search pref-dim* drop { 400 200 } ; "Source file search" show-titled-popup ; : show-vocab-files ( workspace vocab -- ) - "" over vocab-files - "Source files in " rot vocab-name append show-titled-popup ; + [ "" swap vocab-files ] + [ "Source files in " swap vocab-name append ] + bi show-titled-popup ; : vocab-candidates ( -- candidates ) all-vocabs-seq [ dup vocab-name >lower ] { } map>assoc ; diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor index 7e2158e0e9..45f15b1ffc 100644 --- a/basis/ui/tools/traceback/traceback.factor +++ b/basis/ui/tools/traceback/traceback.factor @@ -36,7 +36,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ; dup model>> 2/3 track-add - dup f track-add ; + add-toolbar ; : ( model -- gadget ) [ [ name>> namestack. ] when* ] diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor index 7bc42ea676..9c825d4920 100644 --- a/basis/ui/tools/walker/walker.factor +++ b/basis/ui/tools/walker/walker.factor @@ -62,9 +62,9 @@ M: walker-gadget focusable-child* swap >>status dup continuation>> >>traceback - dup f track-add + add-toolbar dup status>> self f track-add - dup traceback>> 1 track-add ; + dup traceback>> 1 track-add ; : walker-help ( -- ) "ui-walker" help-window ; diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor index f06e0aae26..6536cb8c7d 100644 --- a/basis/ui/tools/workspace/workspace.factor +++ b/basis/ui/tools/workspace/workspace.factor @@ -1,12 +1,12 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: classes continuations help help.topics kernel models - sequences 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 assocs arrays namespaces accessors ; - +sequences assocs arrays namespaces accessors math.vectors 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 ; @@ -32,8 +32,6 @@ M: gadget tool-scroller drop f ; [ find-tool swap ] keep book>> model>> set-model ; -: select-tool ( workspace class -- ) swap show-tool drop ; - : get-workspace* ( quot -- workspace ) [ >r dup workspace? r> [ drop f ] if ] curry find-window [ dup raise-window gadget-child ] @@ -81,7 +79,7 @@ SYMBOL: workspace-dim { 600 700 } workspace-dim set-global -M: workspace pref-dim* drop workspace-dim get ; +M: workspace pref-dim* call-next-method workspace-dim get vmax ; M: workspace focusable-child* dup popup>> [ ] [ listener>> ] ?if ; From 08f7e02a3be61e64a4743771fa1b01a3102c7b17 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 21:59:22 -0600 Subject: [PATCH 10/19] Remove stack display from listener tool, and tweak appearance --- basis/ui/tools/interactor/interactor.factor | 4 - basis/ui/tools/listener/listener.factor | 86 ++++++++++----------- basis/ui/tools/tools-docs.factor | 2 +- basis/ui/tools/tools.factor | 25 +++--- 4 files changed, 54 insertions(+), 63 deletions(-) diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index a36610a7f5..36ce67e57b 100644 --- a/basis/ui/tools/interactor/interactor.factor +++ b/basis/ui/tools/interactor/interactor.factor @@ -178,10 +178,6 @@ M: interactor stream-read-quot ] } cond ; -M: interactor pref-dim* - [ line-height 4 * 0 swap 2array ] [ call-next-method ] bi - vmax ; - interactor "interactor" f { { T{ key-down f f "RET" } evaluate-input } { T{ key-down f { C+ } "k" } clear-input } diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 49ce5203d3..4e2cb0b1e9 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -1,20 +1,21 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: inspector ui.tools.interactor ui.tools.inspector -ui.tools.workspace help.markup io io.styles -kernel models namespaces parser quotations sequences ui.commands +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.tracks ui.gestures ui.operations vocabs words -prettyprint listener debugger threads boxes concurrency.flags -math arrays generic accessors combinators assocs ; +ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations +ui.tools.browser ui.tools.interactor ui.tools.inspector +ui.tools.workspace ; IN: ui.tools.listener -TUPLE: listener-gadget < track input output stack ; +TUPLE: listener-gadget < track input output ; : listener-output, ( listener -- listener ) - >>output - dup output>> "Output" 1 track-add ; + + [ >>output ] [ 1 track-add ] bi ; : listener-streams ( listener -- input output ) [ input>> ] [ output>> ] bi ; @@ -23,17 +24,13 @@ TUPLE: listener-gadget < track input output stack ; output>> ; : listener-input, ( listener -- listener ) - dup >>input - dup input>> - - { 0 100 } >>min-dim - { 1/0. 100 } >>max-dim - "Input" - f track-add ; + dup + [ >>input ] [ 1 { 0 0 } >>align f track-add ] bi ; : welcome. ( -- ) "If this is your first time with Factor, please read the " print - "handbook" ($link) "." print nl ; + "handbook" ($link) ". To see a list of keyboard shortcuts," print + "press F1." print nl ; M: listener-gadget focusable-child* input>> ; @@ -60,7 +57,7 @@ M: listener-gadget tool-scroller : call-listener ( quot -- ) [ workspace-busy? not ] get-workspace* listener>> - [ dup wait-for-listener (call-listener) ] 2curry + '[ _ _ dup wait-for-listener (call-listener) ] "Listener call" spawn drop ; M: listener-command invoke-command ( target command -- ) @@ -76,7 +73,7 @@ M: listener-operation invoke-command ( target command -- ) : listener-run-files ( seq -- ) [ - [ [ run-file ] each ] curry call-listener + '[ _ [ run-file ] each ] call-listener ] unless-empty ; : com-end ( listener -- ) @@ -122,20 +119,8 @@ M: engine-word word-completion-string [ select-all ] 2bi ; -TUPLE: stack-display < track ; - -: ( workspace -- gadget ) - listener>> - { 0 1 } stack-display new-track - over f track-add - swap stack>> [ [ stack. ] curry try ] t "Data stack" - 1 track-add ; - -M: stack-display tool-scroller - find-workspace listener>> tool-scroller ; - -: ui-listener-hook ( listener -- ) - >r datastack r> stack>> set-model ; +: ui-help-hook ( topic -- ) + browser-gadget call-tool ; : ui-error-hook ( error listener -- ) find-workspace debugger-popup ; @@ -146,17 +131,20 @@ M: stack-display tool-scroller : listener-thread ( listener -- ) dup listener-streams [ - [ [ ui-listener-hook ] curry listener-hook set ] - [ [ ui-error-hook ] curry error-hook set ] - [ [ ui-inspector-hook ] curry inspector-hook set ] tri + [ ui-help-hook ] help-hook set + [ '[ _ ui-error-hook ] error-hook set ] + [ '[ _ ui-inspector-hook ] inspector-hook set ] bi welcome. listener ] with-streams* ; : start-listener-thread ( listener -- ) - [ - [ input>> register-self ] [ listener-thread ] bi - ] curry "Listener" spawn drop ; + '[ + _ + [ input>> register-self ] + [ listener-thread ] + bi + ] "Listener" spawn drop ; : restart-listener ( listener -- ) #! Returns when listener is ready to receive input. @@ -168,12 +156,9 @@ M: stack-display tool-scroller [ wait-for-listener ] } cleave ; -: init-listener ( listener -- ) - f >>stack drop ; - : ( -- gadget ) { 0 1 } listener-gadget new-track - dup init-listener + add-toolbar listener-output, listener-input, ; @@ -181,12 +166,21 @@ M: stack-display tool-scroller \ listener-help H{ { +nullary+ t } } define-command +: com-auto-use ( -- ) + auto-use? [ not ] change ; + +\ com-auto-use H{ { +nullary+ t } { +listener+ t } } define-command + +listener-gadget "misc" "Miscellaneous commands" { + { T{ key-down f f "F1" } listener-help } +} define-command-map + listener-gadget "toolbar" f { { f restart-listener } - { T{ key-down f { A+ } "c" } clear-output } - { T{ key-down f { A+ } "C" } clear-stack } + { T{ key-down f { A+ } "a" } com-auto-use } + { T{ key-down f { A+ } "c" } clear-output } + { T{ key-down f { A+ } "C" } clear-stack } { T{ key-down f { C+ } "d" } com-end } - { T{ key-down f f "F1" } listener-help } } define-command-map M: listener-gadget handle-gesture ( gesture gadget -- ? ) diff --git a/basis/ui/tools/tools-docs.factor b/basis/ui/tools/tools-docs.factor index f54e1e4041..6368737460 100644 --- a/basis/ui/tools/tools-docs.factor +++ b/basis/ui/tools/tools-docs.factor @@ -32,7 +32,7 @@ ARTICLE: "ui-listener" "UI listener" { $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 } "), and a stack display kept up to date using a " { $link listener-hook } "." ; +"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." diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor index aed4b9d675..3310a3e0a5 100644 --- a/basis/ui/tools/tools.factor +++ b/basis/ui/tools/tools.factor @@ -19,8 +19,7 @@ IN: ui.tools ; : ( workspace -- gadget ) - dup - + @@ -34,14 +33,14 @@ IN: ui.tools dup >>book dup f track-add - dup book>> 1/5 track-add - dup listener>> 4/5 track-add - dup f track-add ; + dup book>> 0 track-add + dup listener>> 1 track-add + add-toolbar ; : resize-workspace ( workspace -- ) - dup sizes>> over control-value zero? [ - 1/5 over set-second - 4/5 swap set-third + dup sizes>> over control-value 0 = [ + 0 over set-second + 1 swap set-third ] [ 2/3 over set-second 1/3 swap set-third @@ -55,13 +54,15 @@ M: workspace model-changed [ workspace-window ] ui-hook set-global -: com-listener ( workspace -- ) stack-display select-tool ; +: select-tool ( workspace n -- ) swap book>> model>> set-model ; -: com-browser ( workspace -- ) browser-gadget select-tool ; +: com-listener ( workspace -- ) 0 select-tool ; -: com-inspector ( workspace -- ) inspector-gadget select-tool ; +: com-browser ( workspace -- ) 1 select-tool ; -: com-profiler ( workspace -- ) profiler-gadget 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 } From f24036834ef29ab7678c92b8afc357a7957adc0d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 22:13:24 -0600 Subject: [PATCH 11/19] Usability fix --- basis/ui/tools/listener/listener.factor | 2 +- basis/ui/tools/search/search.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 4e2cb0b1e9..250fc371c7 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -25,7 +25,7 @@ TUPLE: listener-gadget < track input output ; : listener-input, ( listener -- listener ) dup - [ >>input ] [ 1 { 0 0 } >>align f track-add ] bi ; + [ >>input ] [ 1 { 1 1 } >>fill f track-add ] bi ; : welcome. ( -- ) "If this is your first time with Factor, please read the " print diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor index 033aacc1b3..cf980cfc23 100644 --- a/basis/ui/tools/search/search.factor +++ b/basis/ui/tools/search/search.factor @@ -66,7 +66,7 @@ search-field H{ >>field seq limited? init-search-model presenter over >>list - dup field>> 1 { 0 0 } >>align f track-add + dup field>> 1 { 1 1 } >>fill f track-add dup list>> 1 track-add string over field>> set-editor-string dup field>> end-of-document ; From 17b2566017ddd378c57a6fc12a8becb54848836d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 22:13:32 -0600 Subject: [PATCH 12/19] Blinking cursor --- basis/ui/gadgets/editors/editors.factor | 95 ++++++++++++++++--------- 1 file changed, 61 insertions(+), 34 deletions(-) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index a1c4f3d04e..2ab39ada31 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -2,17 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays documents io kernel math models namespaces make opengl opengl.gl sequences strings io.styles -math.vectors sorting colors combinators assocs math.order -ui.clipboards ui.commands ui.gadgets ui.gadgets.borders -ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers -ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures -math.geometry.rect ; +math.vectors sorting colors combinators assocs math.order fry +calendar alarms ui.clipboards ui.commands ui.gadgets +ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels +ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.wrappers +ui.render ui.gestures math.geometry.rect ; IN: ui.gadgets.editors TUPLE: editor < gadget font color caret-color selection-color caret mark -focused? ; +focused? blink blink-alarm ; : ( -- loc ) { 0 0 } ; @@ -64,14 +64,14 @@ M: editor ungraft* caret>> set-model ; : change-caret ( editor quot -- ) - over >r >r dup editor-caret* swap model>> r> call r> + [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] [ drop ] 2bi set-caret ; inline : mark>caret ( editor -- ) - dup editor-caret* swap mark>> set-model ; + [ editor-caret* ] [ mark>> ] bi set-model ; : change-caret&mark ( editor quot -- ) - over >r change-caret r> mark>caret ; inline + [ change-caret ] [ drop mark>caret ] 2bi ; inline : editor-line ( n editor -- str ) control-value nth ; @@ -85,8 +85,8 @@ M: editor ungraft* : point>loc ( point editor -- loc ) [ - >r first2 r> tuck y>line dup , - >r dup editor-font* r> + [ first2 ] dip tuck y>line dup , + [ dup editor-font* ] dip rot editor-line x>offset , ] { } make ; @@ -94,11 +94,35 @@ M: editor ungraft* [ hand-rel ] keep point>loc ; : click-loc ( editor model -- ) - >r clicked-loc r> set-model ; + [ clicked-loc ] dip set-model ; -: focus-editor ( editor -- ) t >>focused? relayout-1 ; +: blink-caret ( editor -- ) + [ not ] change-blink relayout-1 ; -: unfocus-editor ( editor -- ) f >>focused? relayout-1 ; +: start-blinking ( editor -- ) + t >>blink + dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ; + +: stop-blinking ( editor -- ) + blink-alarm>> cancel-alarm ; + +: restart-blinking ( editor -- ) + dup focused?>> [ + [ stop-blinking ] + [ start-blinking ] + [ relayout-1 ] + tri + ] [ drop ] if ; + +: focus-editor ( editor -- ) + dup start-blinking + t >>focused? + relayout-1 ; + +: unfocus-editor ( editor -- ) + dup stop-blinking + f >>focused? + relayout-1 ; : (offset>x) ( font col# str -- x ) swap head-slice string-width ; @@ -106,7 +130,7 @@ M: editor ungraft* : offset>x ( col# line# editor -- x ) [ editor-line ] keep editor-font* -rot (offset>x) ; -: loc>x ( loc editor -- x ) >r first2 swap r> offset>x ; +: loc>x ( loc editor -- x ) [ first2 swap ] dip offset>x ; : line>y ( lines# editor -- y ) line-height * ; @@ -126,7 +150,7 @@ M: editor ungraft* ] [ drop ] if ; : draw-caret ( -- ) - editor get focused?>> [ + editor get [ focused?>> ] [ blink>> ] bi and [ editor get [ caret-color>> gl-color ] [ @@ -143,7 +167,7 @@ M: editor ungraft* line-translation gl-translate ; : draw-line ( editor str -- ) - >r font>> r> { 0 0 } draw-string ; + [ font>> ] dip { 0 0 } draw-string ; : first-visible-line ( editor -- n ) clip get rect-loc second origin get second - @@ -169,7 +193,7 @@ M: editor ungraft* rot control-value ; : with-editor-translation ( n quot -- ) - >r line-translation origin get v+ r> with-translation ; + [ line-translation origin get v+ ] dip with-translation ; inline : draw-lines ( -- ) @@ -199,7 +223,7 @@ M: editor ungraft* editor get selection-start/end over first [ 2dup [ - >r 2dup r> draw-selected-line + [ 2dup ] dip draw-selected-line 1 translate-lines ] each-line 2drop ] with-editor-translation ; @@ -217,7 +241,7 @@ M: editor pref-dim* drop relayout ; : caret/mark-changed ( model editor -- ) - nip [ relayout-1 ] [ scroll>caret ] bi ; + nip [ restart-blinking ] [ scroll>caret ] bi ; M: editor model-changed { @@ -247,7 +271,9 @@ M: editor user-input* M: editor gadget-text* editor-string % ; : extend-selection ( editor -- ) - dup request-focus dup caret>> click-loc ; + dup request-focus + dup restart-blinking + dup caret>> click-loc ; : mouse-elt ( -- element ) hand-click# get { @@ -259,14 +285,15 @@ M: editor gadget-text* editor-string % ; editor-mark* before? ; : drag-selection-caret ( loc editor element -- loc ) - >r [ drag-direction? ] 2keep - model>> - r> prev/next-elt ? ; + [ + [ drag-direction? ] 2keep model>> + ] dip prev/next-elt ? ; : drag-selection-mark ( loc editor element -- loc ) - >r [ drag-direction? not ] 2keep - nip dup editor-mark* swap model>> - r> prev/next-elt ? ; + [ + [ drag-direction? not ] keep + [ editor-mark* ] [ model>> ] bi + ] dip prev/next-elt ? ; : drag-caret&mark ( editor -- caret mark ) dup clicked-loc swap mouse-elt @@ -285,15 +312,16 @@ M: editor gadget-text* editor-string % ; over gadget-selection? [ drop nip remove-selection ] [ - over >r >r dup editor-caret* swap model>> - r> call r> model>> remove-doc-range + [ [ [ editor-caret* ] [ model>> ] bi ] dip call ] + [ drop model>> ] + 2bi remove-doc-range ] if ; inline : editor-delete ( editor elt -- ) - swap [ over >r rot next-elt r> swap ] delete/backspace ; + swap [ over [ rot next-elt ] dip swap ] delete/backspace ; : editor-backspace ( editor elt -- ) - swap [ over >r rot prev-elt r> ] delete/backspace ; + swap [ over [ rot prev-elt ] dip ] delete/backspace ; : editor-select-prev ( editor elt -- ) swap [ rot prev-elt ] change-caret ; @@ -311,9 +339,8 @@ M: editor gadget-text* editor-string % ; tuck caret>> set-model mark>> set-model ; : select-elt ( editor elt -- ) - over >r - >r dup editor-caret* swap model>> r> prev/next-elt - r> editor-select ; + [ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi + editor-select ; : start-of-document ( editor -- ) T{ doc-elt } editor-prev ; From decdcbe120487fec050b2fe8de070c20a087734d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 22:14:35 -0600 Subject: [PATCH 13/19] Stop blinking in ungraft just in case --- basis/ui/gadgets/editors/editors.factor | 37 +++++++++++++------------ 1 file changed, 19 insertions(+), 18 deletions(-) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 2ab39ada31..ebe092aa10 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -45,6 +45,24 @@ focused? blink blink-alarm ; dup deactivate-model swap model>> remove-loc ; +: blink-caret ( editor -- ) + [ not ] change-blink relayout-1 ; + +: start-blinking ( editor -- ) + t >>blink + dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ; + +: stop-blinking ( editor -- ) + blink-alarm>> cancel-alarm ; + +: restart-blinking ( editor -- ) + dup focused?>> [ + [ stop-blinking ] + [ start-blinking ] + [ relayout-1 ] + tri + ] [ drop ] if ; + M: editor graft* dup dup caret>> activate-editor-model @@ -52,6 +70,7 @@ M: editor graft* M: editor ungraft* dup + dup stop-blinking dup caret>> deactivate-editor-model dup mark>> deactivate-editor-model ; @@ -96,24 +115,6 @@ M: editor ungraft* : click-loc ( editor model -- ) [ clicked-loc ] dip set-model ; -: blink-caret ( editor -- ) - [ not ] change-blink relayout-1 ; - -: start-blinking ( editor -- ) - t >>blink - dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ; - -: stop-blinking ( editor -- ) - blink-alarm>> cancel-alarm ; - -: restart-blinking ( editor -- ) - dup focused?>> [ - [ stop-blinking ] - [ start-blinking ] - [ relayout-1 ] - tri - ] [ drop ] if ; - : focus-editor ( editor -- ) dup start-blinking t >>focused? From 53646a076b21d2c03578d6e94689036b74915895 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 22:15:07 -0600 Subject: [PATCH 14/19] Set blink-alarm to f after we stop it --- basis/ui/gadgets/editors/editors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index ebe092aa10..e8b79bed72 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -53,7 +53,7 @@ focused? blink blink-alarm ; dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ; : stop-blinking ( editor -- ) - blink-alarm>> cancel-alarm ; + [ [ cancel-alarm ] when* f ] change-blink-alarm drop ; : restart-blinking ( editor -- ) dup focused?>> [ From 5911ad913f305d26bf6a4016052417b65719788e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 23:29:16 -0600 Subject: [PATCH 15/19] Make blink interval configurable --- basis/ui/gadgets/editors/editors.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index e8b79bed72..b5d30dd2d6 100644 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -48,9 +48,13 @@ focused? blink blink-alarm ; : blink-caret ( editor -- ) [ not ] change-blink relayout-1 ; +SYMBOL: blink-interval + +750 milliseconds blink-interval set-global + : start-blinking ( editor -- ) t >>blink - dup '[ _ blink-caret ] 750 milliseconds every >>blink-alarm drop ; + dup '[ _ blink-caret ] blink-interval get every >>blink-alarm drop ; : stop-blinking ( editor -- ) [ [ cancel-alarm ] when* f ] change-blink-alarm drop ; From 9d68d5882a9d746745115659301fee7688c3df5e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Nov 2008 23:54:27 -0600 Subject: [PATCH 16/19] Fix circularity --- basis/ui/gadgets/buttons/buttons.factor | 34 ++++++++++++------------- basis/ui/gadgets/tracks/tracks.factor | 5 +--- 2 files changed, 17 insertions(+), 22 deletions(-) diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index d74284cbd6..6b687f7e20 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -2,10 +2,11 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays kernel math models namespaces sequences strings quotations assocs combinators classes colors -classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets -ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme -ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures -ui.render math.geometry.rect locals alien.c-types ; +classes.tuple locals alien.c-types fry opengl opengl.gl +math.vectors ui.commands ui.gadgets ui.gadgets.borders +ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks +ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render +math.geometry.rect ; IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; @@ -27,7 +28,7 @@ TUPLE: button < border pressed? selected? quot ; relayout-1 ; : if-clicked ( button quot -- ) - >r dup button-update dup button-rollover? r> [ drop ] if ; + [ dup button-update dup button-rollover? ] dip [ drop ] if ; : button-clicked ( button -- ) dup quot>> if-clicked ; @@ -219,9 +220,8 @@ M: radio-control model-changed over value>> = >>selected? relayout-1 ; -: ( parent model assoc quot -- parent ) - #! quot has stack effect ( value model label -- ) - swapd [ swapd call add-gadget ] 2curry assoc-each ; inline +: ( assoc model parent quot: ( value model label -- ) -- parent ) + '[ _ swap _ call add-gadget ] assoc-each ; inline : radio-button-theme ( gadget -- gadget ) { 5 5 } >>gap @@ -232,8 +232,7 @@ M: radio-control model-changed : ( model assoc -- gadget ) - -rot - [ ] + spin [ ] { 5 5 } >>gap ; : ( value model label -- gadget ) @@ -241,20 +240,19 @@ M: radio-control model-changed : ( model assoc -- gadget ) - -rot - [ ] ; + spin [ ] ; : command-button-quot ( target command -- quot ) - [ invoke-command drop ] 2curry ; + '[ _ _ invoke-command drop ] ; : ( target gesture command -- button ) - [ command-string ] keep - swapd - command-button-quot - ; + [ command-string swap ] keep command-button-quot ; : ( target -- toolbar ) swap "toolbar" over class command-map commands>> swap - [ -rot add-gadget ] curry assoc-each ; + '[ [ _ ] 2dip add-gadget ] assoc-each ; + +: add-toolbar ( track -- track ) + dup f track-add ; diff --git a/basis/ui/gadgets/tracks/tracks.factor b/basis/ui/gadgets/tracks/tracks.factor index dc176b5bf7..ddc7cf18fd 100644 --- a/basis/ui/gadgets/tracks/tracks.factor +++ b/basis/ui/gadgets/tracks/tracks.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors io kernel namespaces fry math math.vectors math.geometry.rect math.order -sequences words ui.gadgets ui.gadgets.packs ui.gadgets.buttons ; +sequences words ui.gadgets ui.gadgets.packs ; IN: ui.gadgets.tracks @@ -57,9 +57,6 @@ M: track pref-dim* ( gadget -- dim ) : track-add ( track gadget constraint -- track ) pick sizes>> push add-gadget ; -: add-toolbar ( track -- track ) - dup f track-add ; - : track-remove ( track gadget -- track ) dupd dup [ [ swap children>> index ] From 1addde156769f22131d0cc4ebf699c466fbdd43a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Nov 2008 00:18:25 -0600 Subject: [PATCH 17/19] If 'search' was called outside of the parser, note. might be called, which would fail if no lexer was set --- core/parser/parser-tests.factor | 2 ++ core/parser/parser.factor | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index d2d407e147..f621cbb84a 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -496,3 +496,5 @@ DEFER: blah [ "IN: parser.tests USE: kernel TUPLE: blah < tuple ; : blah ; TUPLE: blah < tuple ; : blah ;" eval ] [ error>> error>> def>> \ blah eq? ] must-fail-with + +[ ] [ f lexer set f file set "Hello world" note. ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 414e9ea499..1728b471e2 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -25,7 +25,7 @@ t parser-notes set-global : note. ( str -- ) parser-notes? [ file get [ path>> write ":" write ] when* - lexer get line>> number>string write ": " write + lexer get [ line>> number>string write ": " write ] when* "Note: " write dup print ] when drop ; From 27503bf67f2af840d150c8f3e830d9759999daa9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Nov 2008 01:54:45 -0600 Subject: [PATCH 18/19] Faster /mod and /i primitives --- vm/math.c | 43 ++++++++++++++++++++++++++++--------------- 1 file changed, 28 insertions(+), 15 deletions(-) diff --git a/vm/math.c b/vm/math.c index c6b91bc8f7..6a0acf7180 100644 --- a/vm/math.c +++ b/vm/math.c @@ -33,18 +33,18 @@ void primitive_float_to_fixnum(void) #define POP_FIXNUMS(x,y) \ F_FIXNUM y = untag_fixnum_fast(dpop()); \ - F_FIXNUM x = untag_fixnum_fast(dpop()); + F_FIXNUM x = untag_fixnum_fast(dpeek()); void primitive_fixnum_add(void) { POP_FIXNUMS(x,y) - box_signed_cell(x + y); + drepl(allot_integer(x + y)); } void primitive_fixnum_subtract(void) { POP_FIXNUMS(x,y) - box_signed_cell(x - y); + drepl(allot_integer(x - y)); } /* Multiply two integers, and trap overflow. @@ -54,20 +54,20 @@ void primitive_fixnum_multiply(void) POP_FIXNUMS(x,y) if(x == 0 || y == 0) - dpush(tag_fixnum(0)); + drepl(tag_fixnum(0)); else { F_FIXNUM prod = x * y; /* if this is not equal, we have overflow */ if(prod / x == y) - box_signed_cell(prod); + drepl(allot_integer(prod)); else { F_ARRAY *bx = fixnum_to_bignum(x); REGISTER_BIGNUM(bx); F_ARRAY *by = fixnum_to_bignum(y); UNREGISTER_BIGNUM(bx); - dpush(tag_bignum(bignum_multiply(bx,by))); + drepl(tag_bignum(bignum_multiply(bx,by))); } } } @@ -75,14 +75,27 @@ void primitive_fixnum_multiply(void) void primitive_fixnum_divint(void) { POP_FIXNUMS(x,y) - box_signed_cell(x / y); + F_FIXNUM result = x / y; + if(result == -FIXNUM_MIN) + drepl(allot_integer(-FIXNUM_MIN)); + else + drepl(tag_fixnum(result)); } void primitive_fixnum_divmod(void) { - POP_FIXNUMS(x,y) - box_signed_cell(x / y); - dpush(tag_fixnum(x % y)); + F_FIXNUM y = get(ds); + F_FIXNUM x = get(ds - CELLS); + if(y == -1 && x == tag_fixnum(FIXNUM_MIN)) + { + put(ds - CELLS,allot_integer(-FIXNUM_MIN)); + put(ds,tag_fixnum(0)); + } + else + { + put(ds - CELLS,tag_fixnum(x / y)); + put(ds,x % y); + } } /* @@ -96,15 +109,15 @@ void primitive_fixnum_shift(void) if(x == 0 || y == 0) { - dpush(tag_fixnum(x)); + drepl(tag_fixnum(x)); return; } else if(y < 0) { if(y <= -WORD_SIZE) - dpush(x < 0 ? tag_fixnum(-1) : tag_fixnum(0)); + drepl(x < 0 ? tag_fixnum(-1) : tag_fixnum(0)); else - dpush(tag_fixnum(x >> -y)); + drepl(tag_fixnum(x >> -y)); return; } else if(y < WORD_SIZE - TAG_BITS) @@ -112,12 +125,12 @@ void primitive_fixnum_shift(void) F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y)); if((x > 0 && (x & mask) == 0) || (x & mask) == mask) { - dpush(tag_fixnum(x << y)); + drepl(tag_fixnum(x << y)); return; } } - dpush(tag_bignum(bignum_arithmetic_shift( + drepl(tag_bignum(bignum_arithmetic_shift( fixnum_to_bignum(x),y))); } From 79bffecc2ec2733a0a9745b096e2b941793428a2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 21 Nov 2008 01:54:56 -0600 Subject: [PATCH 19/19] Add type function for /mod --- .../tree/propagation/known-words/known-words.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 3b698e0001..f6e2bc0940 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -138,6 +138,12 @@ most-negative-fixnum most-positive-fixnum [a,b] \ mod [ [ interval-mod ] [ real-valued ] binary-op ] each-derived-op \ rem [ [ interval-rem ] [ may-overflow real-valued ] binary-op ] each-derived-op +{ /mod fixnum/mod } [ + \ /i \ mod + [ "outputs" word-prop ] bi@ + '[ _ _ 2bi ] "outputs" set-word-prop +] each + \ shift [ [ interval-shift-safe ] [ may-overflow integer-valued ] binary-op ] each-derived-op \ shift [ [ interval-shift-safe ] [ integer-valued ] binary-op ] each-fast-derived-op