basis: Fix Windows 10 select-all for emojis.

This is @kusumotonorio's patch but his branch is not up to date so there
are a ton of merge conflicts so I'm just pulling his changes into a new
patch. Sorry for my lack of git to do this cleanly while maintaining his
credit for this patch.

diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index 9a6ae6d958401bf2da1f0b05ecb77427202de74b..ff60eea97b5cc3cb53b47890e6a63542694b77c4 100644 (file)
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -9,7 +9,9 @@ threads ui ui.backend ui.clipboards ui.event-loop ui.gadgets
 ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
 ui.private windows.dwmapi windows.errors windows.gdi32
 windows.kernel32 windows.messages windows.offscreen windows.opengl32
 ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
 ui.private windows.dwmapi windows.errors windows.gdi32
 windows.kernel32 windows.messages windows.offscreen windows.opengl32

-windows.types windows.user32 assocs.extras byte-arrays ;
+windows.types windows.user32 assocs.extras byte-arrays
+io.encodings.string ;
+FROM: unicode => upper-surrogate? under-surrogate? ;

 SPECIALIZED-ARRAY: POINT
 QUALIFIED-WITH: alien.c-types c
 IN: ui.backend.windows
 SPECIALIZED-ARRAY: POINT
 QUALIFIED-WITH: alien.c-types c
 IN: ui.backend.windows


@@ -347,11 +349,26 @@ CONSTANT: exclude-keys-wm-char
 : handle-wm-keydown ( hWnd uMsg wParam lParam -- )
     \ send-key-down (handle-wm-keydown/up) ;
 
 : handle-wm-keydown ( hWnd uMsg wParam lParam -- )
     \ send-key-down (handle-wm-keydown/up) ;
 

+SYMBOL: upper-surrogate-wm-char
+

 :: handle-wm-char ( hWnd uMsg wParam lParam -- )
     wParam exclude-key-wm-char? [
 :: handle-wm-char ( hWnd uMsg wParam lParam -- )
     wParam exclude-key-wm-char? [

-       ctrl? alt? xor [ ! enable AltGr combination inputs
-           wParam 1string hWnd window user-input
-       ] unless
+        ctrl? alt? xor [ ! enable AltGr combination inputs
+            wParam {
+                { [ dup upper-surrogate? ] [
+                      upper-surrogate-wm-char set-global ]
+                }
+                { [ dup under-surrogate? ] [
+                      drop
+                      upper-surrogate-wm-char get-global [
+                          1string wParam 1string 2array "" join
+                          utf16n encode utf16n decode hWnd window user-input
+                      ] when* ]
+                }
+                [ 1string hWnd window user-input
+                  f upper-surrogate-wm-char set-global ]
+            } cond
+        ] unless

     ] unless ;
 
 : handle-wm-keyup ( hWnd uMsg wParam lParam -- )
     ] unless ;
 
 : handle-wm-keyup ( hWnd uMsg wParam lParam -- )

diff --git a/basis/unicode/unicode.factor b/basis/unicode/unicode.factor
index abeacc52000dab391101fa66016231bbf52a0f76..64cfb600316d9421057756ecbb9fada018435b2e 100644 (file)
--- a/basis/unicode/unicode.factor
+++ b/basis/unicode/unicode.factor
@@ -217,6 +217,10 @@ PRIVATE>
 : string<=> ( str1 str2 -- <=> )
     [ collation-key/nfd 2array ] compare ;
 
 : string<=> ( str1 str2 -- <=> )
     [ collation-key/nfd 2array ] compare ;
 

+: upper-surrogate? ( ch -- ? ) 0xD800 0xDBFF between? ; inline
+
+: under-surrogate? ( ch -- ? ) 0xDC00 0xDFFF between? ; inline
+

 CONSTANT: unicode-supported {
     "collation"
 }
 CONSTANT: unicode-supported {
     "collation"
 }

diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
index 77bdc94fc3e553b6453fb9c36aad1f842fd96dde..1f609246a5a00c9adf6ea613005fcea12966a1f1 100644 (file)
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -16,36 +16,37 @@ TUPLE: script-string < disposable font string metrics ssa size image ;
 
 CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
 
 
 CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
 

+:: >codepoint-index ( str utf16-index -- codepoint-index )
+    0 utf16-index 2 * str utf16n encode subseq utf16n decode length ;
+    
+:: >utf16-index ( str codepoint-index -- utf16-index )
+    0 codepoint-index str subseq utf16n encode length 2 / >integer ;
+
+PRIVATE>
+

 :: line-offset>x ( n script-string -- x )
 :: line-offset>x ( n script-string -- x )

-    n script-string
-    2dup string>> length = [
-        ssa>> ! ssa
-        ! swap 1 - ! icp
-        swap 0 swap script-string string>> subseq
-        utf16n encode length 2 / >integer 1 - ! icp
+    script-string string>> n >utf16-index :> n-utf16
+    script-string ssa>> ! ssa
+    n script-string string>> length = [
+        n-utf16 1 - ! icp

         TRUE ! fTrailing
     ] [
         TRUE ! fTrailing
     ] [

-        ssa>>
-        ! swap ! icp
-        swap 0 swap script-string string>> subseq
-        utf16n encode length 2 / >integer ! icp
+        n-utf16 ! icp

         FALSE ! fTrailing
     ] if
     { int } [ ScriptStringCPtoX check-ole32-error ] with-out-parameters ;
 
 :: x>line-offset ( x script-string -- n trailing )
         FALSE ! fTrailing
     ] if
     { int } [ ScriptStringCPtoX check-ole32-error ] with-out-parameters ;
 
 :: x>line-offset ( x script-string -- n trailing )

-    x script-string
-    ssa>> ! ssa
-    swap ! iX
+    script-string ssa>> ! ssa
+    x ! iX

     { int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters
     { int int } [ ScriptStringXtoCP check-ole32-error ] with-out-parameters

-    swap 2 * 0 swap script-string string>> utf16n encode subseq
-    utf16n decode length
+    swap dup 0 < [ script-string string>> swap >codepoint-index ] unless

     swap ;
 
     swap ;
 

+<PRIVATE
+

 : make-ssa ( dc script-string -- ssa )
     dup selection? [ string>> ] when
 : make-ssa ( dc script-string -- ssa )
     dup selection? [ string>> ] when

-    !    [ utf16n encode ] ! pString
-    !    [ length ] bi ! cString

     utf16n encode ! pString
     dup length 2 / >integer ! cString
     dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
     utf16n encode ! pString
     dup length 2 / >integer ! cString
     dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"


@@ -84,7 +85,14 @@ CONSTANT: ssa-dwFlags flags{ SSA_GLYPHS SSA_FALLBACK SSA_TAB }
         ETO_OPAQUE ! uOptions
     ]
     [ [ { 0 0 } ] dip <RECT> ]
         ETO_OPAQUE ! uOptions
     ]
     [ [ { 0 0 } ] dip <RECT> ]

-    [ selection-start/end ] tri*
+    [
+        [let :> str str selection-start/end
+         [
+             str string>> dup selection? [ string>> ] when
+             swap >utf16-index
+         ] bi@
+        ]
+    ] tri*

     ! iMinSel
     ! iMaxSel
     FALSE ! fDisabled
     ! iMinSel
     ! iMaxSel
     FALSE ! fDisabled


@@ -161,5 +169,5 @@ SYMBOL: cached-script-strings
         ] with-memory-dc
     ] unless image>> ;
 
         ] with-memory-dc
     ] unless image>> ;
 

-[ <cache-assoc> cached-script-strings set-global ]
+[ <cache-assoc> &dispose cached-script-strings set-global ]

 "windows.uniscribe" add-startup-hook
 "windows.uniscribe" add-startup-hook