Search gadget improvements

TODO.FACTOR.txt

@@ -1,7 +1,6 @@
 - auto-invoke code gc
 - fix alien-callback/SEH bug on win32
 - list mouse gestures
-- search gadget should use list
 - maybe simplify list into displaying list a sequence of strings
 - the mouse button overload sucks, use popup menus instead
 - nested presentation mouse over is not right
@@ -12,10 +11,8 @@
 - better help result ranking
 - minibuffer should show a title
 - browser: toolbar is missing
-- new search gadget:
-  - field does not move caret properly
-  - use it instead of the old search gadget
 - listener: 'edit a file' feature
+- viewport sizing issue
 
 + ui:
 

library/help/markup.factor

@@ -135,11 +135,14 @@ M: f print-element drop ;
 ! Some links
 : >link ( obj -- obj ) dup link? [ <link> ] unless ;
 
-: $link ( element -- )
+: ($link) ( article -- )
-    first link-style [
+    link-style [
         dup article-title swap >link write-object
     ] with-style ;
 
+: $link ( element -- )
+    first ($link) ;
+
 : $vocab-link ( element -- )
     first link-style [
         dup <vocab-link> write-object

library/syntax/parser.factor

@@ -107,7 +107,7 @@ TUPLE: bad-escape ;
 global [
     {
         "scratchpad" "syntax" "arrays" "compiler" "definitions"
-        "errors" "generic" "hashtables" "help" "inference"
+        "errors" "generic" "hashtables" "inference"
         "io" "kernel" "listener" "math"
         "memory" "modules" "namespaces" "parser" "prettyprint"
         "sequences" "shells" "strings" "styles" "test"

library/ui/load.factor

@@ -33,15 +33,14 @@ PROVIDE: library/ui {
     "text/elements.factor"
     "text/editor.factor"
     "text/commands.factor"
-    "text/field.factor"
     "text/interactor.factor"
     "gadgets/presentations.factor"
     "ui.factor"
     "tools/tools.factor"
+    "tools/search.factor"
     "tools/messages.factor"
     "tools/listener.factor"
     "tools/walker.factor"
-    "tools/search.factor"
     "tools/browser.factor"
     "tools/help.factor"
     "tools/dataflow.factor"
@@ -52,7 +51,6 @@ PROVIDE: library/ui {
     "test/models.factor"
     "test/document.factor"
     "test/rectangles.factor"
-    "test/fields.factor"
     "test/commands.factor"
     "test/panes.factor"
     "test/editor.factor"

library/ui/test/fields.factor

@@ -1,7 +0,0 @@
-IN: temporary
-USING: gadgets-text kernel models namespaces test ;
-
-[ ] [ f <model> dup "model" set <field> "field" set ] unit-test
-[ ] [ "Hello world" "field" get set-editor-text ] unit-test
-[ "Hello world" ] [ "field" get field-commit ] unit-test
-[ "Hello world" ] [ "model" get model-value ] unit-test

library/ui/text/editor.factor

@@ -123,7 +123,8 @@ M: editor model-changed
     ] when drop ;
 
 M: loc-monitor model-changed
-    loc-monitor-editor control-self scroll>caret ;
+    loc-monitor-editor control-self
+    dup relayout-1 scroll>caret ;
 
 : draw-caret ( -- )
     editor get editor-focused? [

library/ui/text/field.factor

@@ -1,21 +0,0 @@
-! Copyright (C) 2006 Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-IN: gadgets-text
-USING: gadgets generic kernel models sequences gadgets-theme ;
-
-TUPLE: field model ;
-
-C: field ( model -- field )
-    <editor> over set-delegate
-    [ set-field-model ] keep
-    dup dup set-control-self ;
-
-: field-commit ( field -- string )
-    [ editor-text ] keep
-    [ field-model [ dupd set-model ] when* ] keep
-    select-all ;
-
-field "Field commands" {
-    { "Clear input" T{ key-down f { C+ } "k" } [ control-model clear-doc ] }
-    { "Accept input" T{ key-down f f "RETURN" } [ field-commit drop ] }
-} define-commands

library/ui/text/interactor.factor

@@ -60,4 +60,5 @@ M: interactor stream-readln
 
 interactor "Interactor commands" {
     { "Evaluate" T{ key-down f f "RETURN" } [ interactor-commit ] }
+    { "Clear input" T{ key-down f { C+ } "k" } [ control-model clear-doc ] }
 } define-commands

library/ui/tools/browser.factor

@@ -45,7 +45,7 @@ TUPLE: tile definition gadget ;
     <default-border> dup faint-boundary ;
 
 C: tile ( definition -- gadget )
-    2dup { tile } <toolbar>
+    2dup { tile } "Word commands" <toolbar>
     <tile-content> over set-gadget-delegate
     [ set-tile-definition ] keep ;
 
@@ -87,9 +87,24 @@ C: navigator ( -- gadget )
 
 C: browser ( -- gadget )
     {
-        { [ <navigator> ] set-browser-navigator f 1/5 }
+        {
-        { [ <definitions> ] set-browser-definitions [ <scroller> ] 3/5 }
+            [ <navigator> ]
-        { [ [ apropos ] <search-gadget> ] set-browser-search f 1/5 }
+            set-browser-navigator
+            f
+            1/5
+        }
+        {
+            [ <definitions> ]
+            set-browser-definitions
+            [ <scroller> ]
+            3/5
+        }
+        {
+            [ "" [ browser call-tool ] <word-search> ]
+            set-browser-search
+            f
+            1/5
+        }
     } { 0 1 } make-track* ;
 
 M: browser focusable-child* browser-search ;

library/ui/tools/help.factor

@@ -22,8 +22,18 @@ TUPLE: help-gadget pane history search ;
 
 C: help-gadget ( -- gadget )
     dup init-history {
-        { [ <help-pane> ] set-help-gadget-pane [ <scroller> ] 4/5 }
+        {
-        { [ [ search-help. ] <search-gadget> ] set-help-gadget-search f 1/5 }
+            [ <help-pane> ]
+            set-help-gadget-pane
+            [ <scroller> ]
+            4/5
+        }
+        {
+            [ "" [ help-gadget call-tool ] <help-search> ]
+            set-help-gadget-search
+            f
+            1/5
+        }
     } { 0 1 } make-track* ;
 
 M: help-gadget focusable-child* help-gadget-search ;

library/ui/tools/listener.factor

@@ -128,7 +128,7 @@ M: listener-gadget tool-help
 
 : insert-completion ( completion -- )
     find-listener [
-        >r peek word-name r> listener-gadget-input user-input
+        >r word-name r> listener-gadget-input user-input
     ] keep hide-minibuffer ;
 
 listener-gadget "Toolbar" {

library/ui/tools/search.factor

@@ -6,39 +6,12 @@ gadgets-panes gadgets-scrolling gadgets-text gadgets-theme
 generic help tools kernel models sequences words
 gadgets-borders gadgets-lists namespaces ;
 
-TUPLE: search-gadget input ;
-
-: <search-pane> ( model quot -- )
-    [ over empty? [ 2drop ] [ call ] if ] curry
-    <pane-control> ;
-
-: <search-bar> ( field -- gadget )
-    {
-        { [ "Search: " <label> ] f f @left }
-        { f f f @center }
-    } make-frame ;
-
-C: search-gadget ( quot -- )
-    >r f <model> dup r> {
-        { [ <field> ] set-search-gadget-input [ <search-bar> ] @top }
-        { [ swap <search-pane> <scroller> ] f f @center }
-    } make-frame* ;
-
-M: search-gadget focusable-child* search-gadget-input ;
-
-
-! Here is the new one
 TUPLE: live-search field list model producer action presenter ;
 
 : find-live-search [ live-search? ] find-parent ;
 
 : find-search-list find-live-search live-search-list ;
 
-: update-live-search ( live-search -- )
-    dup live-search-field editor-text
-    over live-search-producer call
-    swap live-search-model set-model ;
-
 TUPLE: search-field ;
 
 C: search-field ( string -- gadget )
@@ -46,18 +19,19 @@ C: search-field ( string -- gadget )
     dup dup set-control-self
     [ set-editor-text ] keep ;
 
-M: search-field model-changed
-    dup find-live-search update-live-search
-    delegate model-changed ;
-
 search-field H{
     { T{ key-down f f "UP" } [ find-search-list select-prev ] }
     { T{ key-down f f "DOWN" } [ find-search-list select-next ] }
     { T{ key-down f f "RETURN" } [ find-search-list call-action ] }
 } set-gestures
 
+: <search-model> ( -- model )
+    gadget get dup live-search-field control-model
+    swap live-search-producer [ "\n" join ] swap append
+    <filter> ;
+
 : <search-list>
-    gadget get live-search-model
+    <search-model>
     gadget get live-search-presenter
     gadget get live-search-action
     <list> ;
@@ -66,7 +40,6 @@ C: live-search ( string action producer presenter -- gadget )
     [ set-live-search-presenter ] keep
     [ set-live-search-producer ] keep
     [ set-live-search-action ] keep
-    f <model> over set-live-search-model
     {
         {
             [ <search-field> ]
@@ -90,3 +63,9 @@ M: live-search focusable-child* live-search-field ;
     [ completions ] curry
     [ [ completion. ] make-pane ]
     <live-search> ;
+
+: <help-search> ( string action -- gadget )
+    \ first add*
+    [ search-help ]
+    [ [ ($link) ] make-pane ]
+    <live-search> ;

library/ui/tools/workspace.factor

@@ -11,8 +11,18 @@ gadgets-scrolling gadgets-panes gadgets-messages ;
 
 C: tool ( gadget -- tool )
     {
-        { [ dup dup class tool 2array <toolbar> ] f f @top }
+        {
-        { [ ] set-tool-gadget f @center }
+            [ dup dup class tool 2array "Toolbar" <toolbar> ]
+            f
+            f
+            @top
+        }
+        {
+            f
+            set-tool-gadget
+            f
+            @center
+        }
     } make-frame* ;
 
 M: tool focusable-child* tool-gadget ;

library/ui/ui.factor

@@ -119,8 +119,9 @@ C: titled-gadget ( gadget title -- )
 : restore-windows? ( -- ? )
     windows get [ empty? not ] [ f ] if* ;
 
-: <toolbar> ( target classes -- toolbar )
+: <toolbar> ( target classes group -- toolbar )
-    [ commands "Toolbar" swap hash ] map concat
+    swap
+    [ commands hash ] map-with concat
     [ <command-presentation> ] map-with
     make-shelf ;