Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
ec0d4717ca
|
|
@ -326,26 +326,26 @@ IN: regexp-tests
|
|||
! "a(?#bcdefg)bcd" <regexp> "abcdefg" over first-match
|
||||
! "a(?:bcdefg)" <regexp> "abcdefg" over first-match
|
||||
|
||||
[ { 0 1 } ] [ "ac" "a(?!b)" <regexp> first-match ] unit-test
|
||||
[ "a" ] [ "ac" "a(?!b)" <regexp> first-match >string ] unit-test
|
||||
[ f ] [ "ab" "a(?!b)" <regexp> first-match ] unit-test
|
||||
|
||||
! "a(?<=b)" <regexp> "caba" over first-match
|
||||
|
||||
[ { 0 1 } ] [ "ab" "a(?=b)(?=b)" <regexp> first-match ] unit-test
|
||||
[ { 1 2 } ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match ] unit-test
|
||||
[ { 1 2 } ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match ] unit-test
|
||||
[ "a" ] [ "ab" "a(?=b)(?=b)" <regexp> first-match >string ] unit-test
|
||||
[ "a" ] [ "ba" "a(?<=b)(?<=b)" <regexp> first-match >string ] unit-test
|
||||
[ "a" ] [ "cab" "a(?=b)(?<=c)" <regexp> first-match >string ] unit-test
|
||||
|
||||
! capture group 1: "aaaa" 2: ""
|
||||
! "aaaa" "(a*)(a*)" <regexp> match*
|
||||
! "aaaa" "(a*)(a+)" <regexp> match*
|
||||
|
||||
[ { 0 2 } ] [ "ab" "(a|ab)(bc)?" <regexp> first-match ] unit-test
|
||||
[ { 0 3 } ] [ "abc" "(a|ab)(bc)?" <regexp> first-match ] unit-test
|
||||
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
|
||||
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
|
||||
|
||||
[ { 0 2 } ] [ "ab" "(ab|a)(bc)?" <regexp> first-match ] unit-test
|
||||
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
|
||||
[ "ab" ] [ "ab" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
|
||||
[ "abc" ] [ "abc" "(ab|a)(bc)?" <regexp> first-match >string ] unit-test
|
||||
|
||||
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
|
||||
[ "b" ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match >string ] unit-test
|
||||
|
||||
[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
<dfa-traverser> do-match return-match ;
|
||||
: (match) ( string regexp -- dfa-traverser )
|
||||
<dfa-traverser> do-match ; inline
|
||||
|
||||
: match* ( string regexp -- pair captured-groups )
|
||||
<dfa-traverser> 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 [ <slice> ] [ 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 ;
|
||||
|
|
|
|||
|
|
@ -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 <range> ] if-empty ;
|
||||
[
|
||||
[ [ text>> ] [ start-index>> ] bi ]
|
||||
[ peek ] bi* rot <slice>
|
||||
] if-empty ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
[ [ <key-down> ] ] dip send-key-gesture ;
|
||||
|
||||
: send-key-up ( sym action? hWnd -- )
|
||||
[ [ <key-up> ] ] 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 <key-down>
|
||||
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 <key-up>
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in New Issue