Merge branch 'master' of git://factorcode.org/git/factor

core/quotations/quotations-docs.factor

@@ -22,7 +22,7 @@ $nl
 ABOUT: "quotations"
 
 HELP: callable
-{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations, " { $link f } " (which behaves like an empty quotation), and composed quotations built up with " { $link curry } "." } ;
+{ $class-description "The class whose instances can be passed to " { $link call } ". This includes quotations and composed quotations built up with " { $link curry } " or " { $link compose } "." } ;
 
 HELP: quotation
 { $description "The class of quotations. See " { $link "syntax-quots" } " for syntax and " { $link "quotations" } " for general information." } ;

extra/documents/documents.factor

@@ -167,6 +167,12 @@ M: char-elt prev-elt
 M: char-elt next-elt
     drop [ drop 1 +col ] (next-char) ;
 
+TUPLE: one-char-elt ;
+
+M: one-char-elt prev-elt 2drop ;
+
+M: one-char-elt next-elt 2drop ;
+
 : (word-elt) ( loc document quot -- loc )
     pick >r
     >r >r first2 swap r> doc-line r> call

extra/macros/macros.factor

@@ -19,7 +19,7 @@ IN: macros
 : MACRO:
     (:) (MACRO:) ; parsing
 
-PREDICATE: word macro
+PREDICATE: compound macro
     "macro" word-prop >boolean ;
 
 M: macro definer drop \ MACRO: \ ; ;

extra/tools/test/ui/ui.factor

@@ -1,5 +1,5 @@
 USING: dlists ui.gadgets kernel ui namespaces io.streams.string
-io ui.private ;
+io ;
 IN: tools.test.ui
 
 ! We can't print to stdio here because that might be a pane

extra/ui/gadgets/editors/editors-tests.factor

@@ -1,5 +1,5 @@
 USING: ui.gadgets.editors tools.test kernel io io.streams.plain
-definitions namespaces ui.gadgets ui.private
+definitions namespaces ui.gadgets
 ui.gadgets.grids prettyprint documents ui.gestures
 tools.test.inference tools.test.ui models ;
 

extra/ui/gadgets/editors/editors.factor

@@ -4,7 +4,7 @@ USING: arrays documents ui.clipboards ui.commands ui.gadgets
 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
 ui.gadgets.scrollers ui.gadgets.theme ui.render ui.gestures io
 kernel math models namespaces opengl opengl.gl sequences strings
-io.styles math.vectors sorting colors combinators ;
+io.styles math.vectors sorting colors combinators assocs ;
 IN: ui.gadgets.editors
 
 TUPLE: editor
@@ -94,8 +94,11 @@ M: editor ungraft*
         rot editor-line x>offset ,
     ] { } make ;
 
+: clicked-loc ( editor -- loc )
+    [ hand-rel ] keep point>loc ;
+
 : click-loc ( editor model -- )
-    >r [ hand-rel ] keep point>loc r> set-model ;
+    >r clicked-loc r> set-model ;
 
 : focus-editor ( editor -- )
     t over set-editor-focused? relayout-1 ;
@@ -244,11 +247,37 @@ M: editor user-input*
 
 M: editor gadget-text* editor-string % ;
 
-: start-selection ( editor -- )
-    dup editor-caret click-loc ;
-
 : extend-selection ( editor -- )
-    dup request-focus start-selection ;
+    dup request-focus dup editor-caret click-loc ;
+
+: mouse-elt ( -- elelement )
+    hand-click# get {
+        { 2 T{ one-word-elt } }
+        { 3 T{ one-line-elt } }
+    } at T{ one-char-elt } or ;
+
+: drag-direction? ( loc editor -- ? )
+    editor-mark* <=> 0 < ;
+
+: drag-selection-caret ( loc editor element -- loc )
+    >r [ drag-direction? ] 2keep
+    gadget-model
+    r> prev/next-elt ? ;
+
+: drag-selection-mark ( loc editor element -- loc )
+    >r [ drag-direction? not ] 2keep
+    nip dup editor-mark* swap gadget-model
+    r> prev/next-elt ? ;
+
+: drag-caret&mark ( editor -- caret mark )
+    dup clicked-loc swap mouse-elt
+    [ drag-selection-caret ] 3keep
+    drag-selection-mark ;
+
+: drag-selection ( editor -- )
+    dup drag-caret&mark
+    pick editor-mark set-model
+    swap editor-caret set-model ;
 
 : editor-cut ( editor clipboard -- )
     dupd gadget-copy remove-selection ;
@@ -296,17 +325,10 @@ M: editor gadget-text* editor-string % ;
         dup T{ one-word-elt } select-elt
     ] unless gadget-selection ;
 
-: (position-caret) ( editor -- )
-    dup extend-selection
-    dup editor-mark click-loc ;
-
 : position-caret ( editor -- )
-    hand-click# get {
+    mouse-elt dup T{ one-char-elt } =
-        { 1 [ (position-caret) ] }
+    [ drop dup extend-selection dup editor-mark click-loc ]
-        { 2 [ T{ one-word-elt } select-elt ] }
+    [ select-elt ] if ;
-        { 3 [ T{ one-line-elt } select-elt ] }
-        [ 2drop ]
-    } case ;
 
 : insert-newline "\n" swap user-input ;
 
@@ -408,7 +430,7 @@ editor "caret-motion" f {
 
 editor "selection" f {
     { T{ button-down f { S+ } } extend-selection }
-    { T{ drag } start-selection }
+    { T{ drag } drag-selection }
     { T{ gain-focus } focus-editor }
     { T{ lose-focus } unfocus-editor }
     { T{ delete-action } remove-selection }

extra/ui/gadgets/gadgets-tests.factor

@@ -2,7 +2,7 @@ IN: temporary
 USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
 namespaces models kernel tools.test.inference dlists math
 math.parser ui sequences hashtables assocs io arrays
-prettyprint io.streams.string ui.private ;
+prettyprint io.streams.string ;
 
 [ T{ rect f { 10 10 } { 20 20 } } ]
 [

extra/ui/gadgets/scrollers/scrollers-tests.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: ui.gadgets ui.gadgets.scrollers ui.private
+USING: ui.gadgets ui.gadgets.scrollers
 namespaces tools.test kernel models ui.gadgets.viewports
 ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames
 ui.gadgets.sliders math math.vectors arrays sequences

extra/ui/gestures/gestures.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel math models namespaces
 sequences words strings system hashtables math.parser
-math.vectors tuples classes ui.gadgets timers ;
+math.vectors tuples classes ui.gadgets timers combinators.lib ;
 IN: ui.gestures
 
 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
@@ -176,9 +176,22 @@ drag-timer construct-empty drag-timer set-global
 : hand-click-rel ( gadget -- loc )
     hand-click-loc get-global swap screen-loc v- ;
 
+: multi-click-timeout? ( -- ? )
+    millis hand-last-time get - double-click-timeout get <= ;
+
+: multi-click-button? ( button -- button ? )
+    dup hand-last-button get = ;
+
+: multi-click-position? ( -- ? )
+    hand-loc get hand-click-loc get v- norm 10 <= ;
+
 : multi-click? ( button -- ? )
-    millis hand-last-time get - double-click-timeout get <=
+    {
-    swap hand-last-button get = and ;
+        [ multi-click-timeout? ]
+        [ multi-click-button? ]
+        [ multi-click-position? ]
+        [ multi-click-position? ]
+    } && nip ;
 
 : update-click# ( button -- )
     global [

extra/ui/tools/browser/browser-tests.factor

@@ -1,6 +1,6 @@
 IN: temporary
 USING: tools.test tools.test.ui ui.tools.browser
-tools.test.inference ui.private ;
+tools.test.inference ;
 
 { 0 1 } [ <browser-gadget> ] unit-test-effect
 [ ] [ <browser-gadget> [ ] with-grafted-gadget ] unit-test

extra/ui/tools/listener/listener-tests.factor

@@ -1,7 +1,7 @@
 USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
 timers tools.test ui.commands ui.gadgets ui.gadgets.editors
-ui.gadgets.panes vocabs words tools.test.ui ui.private ;
+ui.gadgets.panes vocabs words tools.test.ui ;
 IN: temporary
 
 timers [ init-timers ] unless

extra/ui/tools/search/search-tests.factor

@@ -1,6 +1,6 @@
 USING: assocs ui.tools.search help.topics io.files io.styles
 kernel namespaces sequences source-files threads timers
-tools.test ui.gadgets ui.gestures ui.private vocabs
+tools.test ui.gadgets ui.gestures vocabs
 vocabs.loader words tools.test.ui debugger ;
 IN: temporary
 

extra/ui/tools/tools-tests.factor

@@ -2,7 +2,7 @@ USING: ui.tools ui.tools.interactor ui.tools.listener
 ui.tools.search ui.tools.workspace kernel models namespaces
 sequences timers tools.test ui.gadgets ui.gadgets.buttons
 ui.gadgets.labelled ui.gadgets.presentations
-ui.gadgets.scrollers vocabs tools.test.ui ui ui.private ;
+ui.gadgets.scrollers vocabs tools.test.ui ui ;
 IN: temporary
 
 [

extra/ui/tools/walker/walker-tests.factor

@@ -1,6 +1,6 @@
 USING: arrays continuations ui.tools.listener ui.tools.walker
 ui.tools.workspace inspector kernel namespaces sequences threads
-listener tools.test ui ui.gadgets ui.gadgets.worlds ui.private
+listener tools.test ui ui.gadgets ui.gadgets.worlds
 ui.gadgets.packs vectors ui.tools tools.interpreter
 tools.interpreter.debug tools.test.inference tools.test.ui ;
 IN: temporary

extra/ui/ui.factor

@@ -28,8 +28,6 @@ SYMBOL: windows
 : unregister-window ( handle -- )
     windows global [ [ first = not ] curry* subset ] change-at ;
 
-<PRIVATE
-
 : raised-window ( world -- )
     windows get-global [ second eq? ] curry* find drop
     windows get-global [ length 1- ] keep exchange ;
@@ -67,8 +65,6 @@ M: world ungraft*
     dup world-handle (close-window)
     reset-world ;
 
-PRIVATE>
-
 : open-world-window ( world -- )
     dup pref-dim over set-gadget-dim dup relayout graft ;
 
@@ -90,8 +86,6 @@ SYMBOL: ui-hook
     <dlist> \ layout-queue set-global
     V{ } clone windows set-global ;
 
-<PRIVATE
-
 : restore-gadget-later ( gadget -- )
     dup gadget-graft-state {
         { { f f } [ ] }
@@ -133,7 +127,7 @@ SYMBOL: ui-hook
     ] { } make ;
 
 : redraw-worlds ( seq -- )
-    [ dup update-hand draw-world ] each ;
+    [ dup update-hand [ draw-world ] time ] each ;
 
 : notify ( gadget -- )
     dup gadget-graft-state {
@@ -146,8 +140,6 @@ SYMBOL: ui-hook
 : notify-queued ( -- )
     graft-queue [ notify ] dlist-slurp ;
 
-PRIVATE>
-
 : ui-step ( -- )
     [
         do-timers

extra/ui/windows/windows.factor

@@ -397,8 +397,10 @@ M: windows-ui-backend (close-window)
     GetDoubleClickTime double-click-timeout set-global ;
 
 : cleanup-win32-ui ( -- )
-    class-name-ptr get-global f UnregisterClass drop
+    class-name-ptr get-global [
-    class-name-ptr get-global [ free ] when*
+        dup f UnregisterClass drop
+        free
+    ] when*
     f class-name-ptr set-global ;
 
 : setup-pixel-format ( hdc -- )

extra/webapps/article-manager/furnace/article.furnace

@@ -1,4 +1,4 @@
-<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database ; %>
+<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
     <div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
     <% f "navigation" render-template %>
     <div id="article">

extra/webapps/article-manager/furnace/tag.furnace

@@ -1,4 +1,4 @@
-<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager ; %>
+<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
 
 	<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
     <% f "navigation" render-template %>