diff --git a/basis/regexp/regexp-tests.factor b/basis/regexp/regexp-tests.factor index 4878b67d0f..d01f0c5548 100644 --- a/basis/regexp/regexp-tests.factor +++ b/basis/regexp/regexp-tests.factor @@ -326,26 +326,26 @@ IN: regexp-tests ! "a(?#bcdefg)bcd" "abcdefg" over first-match ! "a(?:bcdefg)" "abcdefg" over first-match -[ { 0 1 } ] [ "ac" "a(?!b)" first-match ] unit-test +[ "a" ] [ "ac" "a(?!b)" first-match >string ] unit-test [ f ] [ "ab" "a(?!b)" first-match ] unit-test ! "a(?<=b)" "caba" over first-match -[ { 0 1 } ] [ "ab" "a(?=b)(?=b)" first-match ] unit-test -[ { 1 2 } ] [ "ba" "a(?<=b)(?<=b)" first-match ] unit-test -[ { 1 2 } ] [ "cab" "a(?=b)(?<=c)" first-match ] unit-test +[ "a" ] [ "ab" "a(?=b)(?=b)" first-match >string ] unit-test +[ "a" ] [ "ba" "a(?<=b)(?<=b)" first-match >string ] unit-test +[ "a" ] [ "cab" "a(?=b)(?<=c)" first-match >string ] unit-test ! capture group 1: "aaaa" 2: "" ! "aaaa" "(a*)(a*)" match* ! "aaaa" "(a*)(a+)" match* -[ { 0 2 } ] [ "ab" "(a|ab)(bc)?" first-match ] unit-test -[ { 0 3 } ] [ "abc" "(a|ab)(bc)?" first-match ] unit-test +[ "ab" ] [ "ab" "(a|ab)(bc)?" first-match >string ] unit-test +[ "abc" ] [ "abc" "(a|ab)(bc)?" first-match >string ] unit-test -[ { 0 2 } ] [ "ab" "(ab|a)(bc)?" first-match ] unit-test -[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" first-match ] unit-test +[ "ab" ] [ "ab" "(ab|a)(bc)?" first-match >string ] unit-test +[ "abc" ] [ "abc" "(ab|a)(bc)?" first-match >string ] unit-test -[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" first-match ] unit-test +[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" first-match >string ] unit-test [ t ] [ "a:b" ".+:?" matches? ] unit-test diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index c9a1d2f47d..32c3695f32 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators kernel math math.ranges sequences +USING: accessors combinators kernel math sequences sets assocs prettyprint.backend make lexer namespaces parser arrays fry regexp.backend regexp.utils regexp.parser regexp.nfa regexp.dfa regexp.traversal regexp.transition-tables ; @@ -25,17 +25,20 @@ IN: regexp [ ] } cleave ; -: match ( string regexp -- pair ) - do-match return-match ; +: (match) ( string regexp -- dfa-traverser ) + do-match ; inline -: match* ( string regexp -- pair captured-groups ) - do-match [ return-match ] [ captured-groups>> ] bi ; +: match ( string regexp -- slice/f ) + (match) return-match ; + +: match* ( string regexp -- slice/f captured-groups ) + (match) [ return-match ] [ captured-groups>> ] bi ; : matches? ( string regexp -- ? ) dupd match - [ [ length ] [ length>> 1- ] bi* = ] [ drop f ] if* ; + [ [ length ] bi@ = ] [ drop f ] if* ; -: match-head ( string regexp -- end/f ) match [ length>> 1- ] [ f ] if* ; +: match-head ( string regexp -- end/f ) match [ length ] [ f ] if* ; : match-at ( string m regexp -- n/f finished? ) [ @@ -50,7 +53,7 @@ IN: regexp ] if ; : first-match ( string regexp -- pair/f ) - 0 swap match-range dup [ 2array ] [ 2drop f ] if ; + dupd 0 swap match-range rot over [ ] [ 3drop f ] if ; : re-cut ( string regexp -- end/f start ) dupd first-match @@ -66,9 +69,7 @@ IN: regexp : next-match ( string regexp -- end/f match/f ) dupd first-match dup - [ [ second tail-slice ] keep ] - [ 2drop f f ] - if ; + [ [ length 1+ tail-slice ] keep ] [ 2drop f f ] if ; : all-matches ( string regexp -- seq ) [ dup ] swap '[ _ next-match ] [ ] produce nip ; diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index c9e8a54348..86d315ee2f 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators kernel math math.ranges +USING: accessors assocs combinators kernel math quotations sequences regexp.parser regexp.classes fry arrays combinators.short-circuit regexp.utils prettyprint regexp.nfa shuffle ; @@ -144,7 +144,10 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) [ increment-state do-match ] when* ] unless ; -: return-match ( dfa-traverser -- interval/f ) +: return-match ( dfa-traverser -- slice/f ) dup matches>> [ drop f ] - [ [ start-index>> ] [ peek ] bi* 1 ] if-empty ; + [ + [ [ text>> ] [ start-index>> ] bi ] + [ peek ] bi* rot + ] if-empty ; diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor old mode 100644 new mode 100755 index fc22f30e0a..512930d06d --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -6,9 +6,10 @@ ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel math math.vectors namespaces make sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types -windows.nt windows threads libc combinators continuations -command-line shuffle opengl ui.render unicode.case ascii -math.bitwise locals symbols accessors math.geometry.rect ; +windows.nt windows threads libc combinators +combinators.short-circuit continuations command-line shuffle +opengl ui.render ascii math.bitwise locals symbols accessors +math.geometry.rect math.order ascii ; IN: ui.windows SINGLETON: windows-ui-backend @@ -144,11 +145,6 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; : alt? ( -- ? ) left-alt? right-alt? or ; : caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ; -: switch-case ( seq -- seq ) - dup first CHAR: a >= [ >upper ] [ >lower ] if ; - -: switch-case? ( -- ? ) shift? caps-lock? xor not ; - : key-modifiers ( -- seq ) [ shift? [ S+ , ] when @@ -179,33 +175,53 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; : exclude-key-wm-char? ( n -- bool ) exclude-keys-wm-char key? ; -: keystroke>gesture ( n -- mods sym ? ) - dup wm-keydown-codes at* [ - nip >r key-modifiers r> t - ] [ - drop 1string >r key-modifiers r> - C+ pick member? >r A+ pick member? r> or [ - shift? [ >lower ] unless f - ] [ - switch-case? [ switch-case ] when t - ] if - ] if ; +: keystroke>gesture ( n -- mods sym ) + wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ; + +: send-key-gesture ( sym action? quot hWnd -- ) + [ [ key-modifiers ] 3dip call ] dip + window-focus propagate-gesture ; inline + +: send-key-down ( sym action? hWnd -- ) + [ [ ] ] dip send-key-gesture ; + +: send-key-up ( sym action? hWnd -- ) + [ [ ] ] dip send-key-gesture ; + +: key-sym ( wParam -- string/f action? ) + { + { + [ dup LETTER? ] + [ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ] + } + { [ dup digit? ] [ 1string f ] } + [ wm-keydown-codes at t ] + } cond ; :: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) wParam exclude-key-wm-keydown? [ - wParam keystroke>gesture - hWnd window-focus propagate-gesture + wParam key-sym over [ + dup ctrl? alt? xor or [ + hWnd send-key-down + ] [ 2drop ] if + ] [ 2drop ] if ] unless ; :: handle-wm-char ( hWnd uMsg wParam lParam -- ) - wParam exclude-key-wm-char? ctrl? alt? xor or [ - wParam 1string - hWnd window-focus user-input + wParam exclude-key-wm-char? [ + ctrl? alt? xor [ + wParam 1string + [ f hWnd send-key-down ] + [ hWnd window-focus user-input ] bi + ] unless ] unless ; :: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) - wParam keystroke>gesture - hWnd window-focus propagate-gesture ; + wParam exclude-key-wm-keydown? [ + wParam key-sym over [ + hWnd send-key-up + ] [ 2drop ] if + ] unless ; :: set-window-active ( hwnd uMsg wParam lParam ? -- n ) ? hwnd window (>>active?) @@ -241,20 +257,20 @@ M: windows-ui-backend (close-window) : message>button ( uMsg -- button down? ) { - { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] } - { [ dup WM_LBUTTONUP = ] [ drop 1 f ] } - { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] } - { [ dup WM_MBUTTONUP = ] [ drop 2 f ] } - { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] } - { [ dup WM_RBUTTONUP = ] [ drop 3 f ] } + { WM_LBUTTONDOWN [ 1 t ] } + { WM_LBUTTONUP [ 1 f ] } + { WM_MBUTTONDOWN [ 2 t ] } + { WM_MBUTTONUP [ 2 f ] } + { WM_RBUTTONDOWN [ 3 t ] } + { WM_RBUTTONUP [ 3 f ] } - { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] } - { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] } - { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] } - { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] } - { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] } - { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] } - } cond ; + { WM_NCLBUTTONDOWN [ 1 t ] } + { WM_NCLBUTTONUP [ 1 f ] } + { WM_NCMBUTTONDOWN [ 2 t ] } + { WM_NCMBUTTONUP [ 2 f ] } + { WM_NCRBUTTONDOWN [ 3 t ] } + { WM_NCRBUTTONUP [ 3 f ] } + } case ; ! If the user clicks in the window border ("non-client area") ! Windows sends us an NC[LMR]BUTTONDOWN message; but if the