libs/tty/tty-ekey.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; THIS IS NOT MULTITHREAD-SAFE!
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 [IFNDEF] tty " tty-low.f" tload [ENDIF]
   9
  10 also tty definitions
  11
  12 false constant (ekey-debug?)
  13
  14
  15 (ekey-debug?) [IF]
  16 : (.keycode)  ( keycode -- )
  17   dup 33 127 within if emit
  18   else ." 0x" dup 0xffff u> if .hex8 else .hex2 endif
  19   endif
  20 ;
  21
  22 : wait-key-dbg  ( tout -- keycode )
  23   wait-key
  24   endcr ."  key: " dup (.keycode) cr
  25 ;
  26 [ELSE]
  27 alias wait-key wait-key-dbg
  28 [ENDIF]
  29
  30 100 value esc-timeout
  31
  32
  33 : (ekey-esc-read?)  ( key -- key false // 27 true )
  34   dup 0< over 27 = or dup if 2drop 27 true endif
  35 ;
  36
  37 : (ekey-fix-ctrl-letter)  ( chcode -- keycode )
  38   dup 1 27 within if
  39     dup 9 = over 13 = or ifnot
  40       [ [CHAR] A 1- K-CTRL-MASK or ] literal +
  41       ;; xterm has it reversed
  42     endif
  43   endif
  44   term-type term-xterm = if
  45     ;; xterm has it reversed
  46     dup K-BACKSPACE = if drop K-^H exit endif
  47     dup K-^H = if drop K-BACKSPACE exit endif
  48   endif
  49 ;
  50
  51
  52 0 var (ekey-csi-count)
  53 0 var (ekey-csi-array) 2 cells allot
  54
  55 0x1000 constant (ekey-csi-flag-mouse)
  56 0x2000 constant (ekey-csi-flag-linux)
  57 0 var (ekey-csi-endchar)  ;; with flags
  58
  59 : (ekey-parse-csi-init)  ( -- )
  60   (ekey-csi-count) 0! (ekey-csi-endchar) 0! (ekey-csi-array) 3 cells erase
  61 ;
  62
  63 ;; "false" means "stop parsing"
  64 : (ekey-parse-csi-firstchar)  ( -- ch true // ch false )
  65   ;; get first char
  66   esc-timeout wait-key-dbg (ekey-esc-read?) if false exit endif
  67   case
  68     [char] I of K-FOCUS-IN false exit endof
  69     [char] O of K-FOCUS-OUT false exit endof
  70     [char] < of (ekey-csi-flag-mouse) (ekey-csi-endchar) ! -1 endof
  71     [char] [ of (ekey-csi-flag-linux) (ekey-csi-endchar) ! -1 endof
  72     otherwise  ;; keep the code
  73   endcase
  74   dup -if drop esc-timeout wait-key-dbg (ekey-esc-read?) if false exit endif endif
  75   true
  76 ;
  77
  78 ;; "false" means "we're done"
  79 : (ekey-parse-csi-check-firstchar)  ( char -- char true // false )
  80   ;; if it is not a digit and not a semi, we have no args
  81   dup 10 digit ifnot
  82     dup [char] ; = ifnot (ekey-csi-endchar) or! false exit endif
  83   endif
  84   drop true
  85 ;
  86
  87 : (ekey-parse-csi-with-args)  ( char -- true // keycode false )
  88   begin
  89     ;; digit?
  90     dup 10 digit if
  91       nip  ;; drop keycode
  92       (ekey-csi-count) @ dup 3 < if
  93         (ekey-csi-array) cells^
  94         dup @ 10 * rot + 32767 min swap !
  95       else
  96         2drop
  97       endif
  98     else
  99       (ekey-csi-count) 1+!
 100       dup [char] ; = if drop
 101         (ekey-csi-count) @ 16 > if K-UNKNOWN false exit endif
 102       else
 103         ;; end of csi
 104         (ekey-csi-endchar) or!
 105         true exit
 106       endif
 107     endif
 108     ;; get next char
 109     esc-timeout wait-key-dbg (ekey-esc-read?) if false exit endif
 110   again
 111 ;
 112
 113 : (ekey-parse-csi)  ( -- true // keycode false )
 114   (ekey-parse-csi-init)
 115   (ekey-parse-csi-firstchar) ifnot false exit endif
 116   (ekey-parse-csi-check-firstchar) ifnot true exit endif
 117   (ekey-parse-csi-with-args)
 118   (*
 119     endcr ." CSI: n=" (ekey-csi-count) @ .
 120     ." n0=" (ekey-csi-array) @ .
 121     ." n1=" (ekey-csi-array) cell+ @ .
 122     ." n2=" (ekey-csi-array) 2 +cells @ .
 123     ." endchar=" (ekey-csi-endchar) @ (.keycode)
 124     ."  xterm-mods=" (ekey-csi-array) cell+ @ (ekey-xterm-mods) .hex8
 125     cr
 126   *)
 127 ;
 128
 129
 130 : (ekey-xterm-mods)  ( csicode -- modflags )
 131   case
 132     2 of K-SHIFT-MASK endof
 133     3 of K-ALT-MASK endof
 134     4 of [ K-ALT-MASK K-SHIFT-MASK or ] literal endof
 135     5 of K-CTRL-MASK endof
 136     6 of [ K-CTRL-MASK K-SHIFT-MASK or ] literal endof
 137     7 of [ K-CTRL-MASK K-ALT-MASK or ] literal endof
 138     8 of [ K-CTRL-MASK K-ALT-MASK or K-SHIFT-MASK or ] literal endof
 139     otherwise drop 0
 140   endcase
 141 ;
 142
 143 : (ekey-xterm-special)  ( upcase-letter -- keycode )
 144   case
 145     [char] A of K-UP endof
 146     [char] B of K-DOWN endof
 147     [char] C of K-RIGHT endof
 148     [char] D of K-LEFT endof
 149     [char] E of K-PAD5 endof
 150     [char] H of K-HOME endof
 151     [char] F of K-END endof
 152     [char] P of K-F1 endof
 153     [char] Q of K-F2 endof
 154     [char] R of K-F3 endof
 155     [char] S of K-F4 endof
 156     [char] Z of K-F1 K-SHIFT-MASK or endof
 157     otherwise drop K-UNKNOWN
 158   endcase
 159 ;
 160
 161
 162 : (ekey-csi-linux-special)  ( chcode -- keycode )
 163   case
 164     [char] A of K-F1 endof
 165     [char] B of K-F1 endof
 166     [char] C of K-F2 endof
 167     [char] D of K-F3 endof
 168     otherwise drop K-UNKNOWN
 169   endcase
 170 ;
 171
 172 : (ekey-csi-xterm-special)  ( chcode -- keycode )
 173   (ekey-xterm-special)
 174 ;
 175
 176 : (ekey-csi-special)  ( csiarg0 -- keycode )
 177   case
 178     1 of K-HOME endof  ;; xterm
 179     2 of K-INSERT endof
 180     3 of K-DELETE endof
 181     4 of K-END endof
 182     5 of K-PRIOR endof ;; pageup
 183     6 of K-NEXT endof  ;; pagedown
 184     7 of K-HOME endof  ;; rxvt
 185     8 of K-END endof
 186     [ 1 10 + ] literal of K-F1 endof
 187     [ 2 10 + ] literal of K-F2 endof
 188     [ 3 10 + ] literal of K-F3 endof
 189     [ 4 10 + ] literal of K-F4 endof
 190     [ 5 10 + ] literal of K-F5 endof
 191     [ 6 11 + ] literal of K-F6 endof
 192     [ 7 11 + ] literal of K-F7 endof
 193     [ 8 11 + ] literal of K-F8 endof
 194     [ 9 11 + ] literal of K-F9 endof
 195     [ 10 11 + ] literal of K-F10 endof
 196     [ 11 12 + ] literal of K-F11 endof
 197     [ 12 12 + ] literal of K-F12 endof
 198     otherwise drop K-UNKNOWN
 199   endcase
 200 ;
 201
 202 : (ekey-csi-args-0)  ( -- chcode )
 203   (ekey-csi-endchar) @ dup 0xff and swap (ekey-csi-flag-linux) and
 204   if (ekey-csi-linux-special) else (ekey-csi-xterm-special) endif
 205 ;
 206
 207 : (ekey-csi-args-1-tilda)  ( -- chcode true // false )
 208   (ekey-csi-array) @ case
 209     23 of [ K-SHIFT-MASK K-F1 or ] literal true endof
 210     24 of [ K-SHIFT-MASK K-F2 or ] literal true endof
 211     25 of [ K-SHIFT-MASK K-F3 or ] literal true endof
 212     26 of [ K-SHIFT-MASK K-F4 or ] literal true endof
 213     28 of [ K-SHIFT-MASK K-F5 or ] literal true endof
 214     29 of [ K-SHIFT-MASK K-F6 or ] literal true endof
 215     31 of [ K-SHIFT-MASK K-F7 or ] literal true endof
 216     32 of [ K-SHIFT-MASK K-F8 or ] literal true endof
 217     33 of [ K-SHIFT-MASK K-F9 or ] literal true endof
 218     34 of [ K-SHIFT-MASK K-F10 or ] literal true endof
 219     200 of K-PASTE-START true endof
 220     201 of K-PASTE-END true endof
 221     otherwise drop false
 222   endcase
 223 ;
 224
 225 : (ekey-csi-args-1-xterm)  ( chcode -- chcode )
 226   (ekey-csi-array) @ (ekey-xterm-mods) swap (ekey-xterm-special)
 227   dup K-UNKNOWN <> if or else drop endif  ;; apply mask
 228 ;
 229
 230 : (ekey-csi-args-1-mask)  ( chcode -- mask true // false )
 231   case
 232     [char] ^ of K-CTRL-MASK true endof
 233     [char] $ of K-SHIFT-MASK true endof
 234     [char] @ of [ K-CTRL-MASK K-SHIFT-MASK or ] literal true endof
 235     otherwise drop false
 236   endcase
 237 ;
 238
 239 : (ekey-csi-args-1)  ( -- chcode )
 240   (ekey-csi-endchar) @ dup 0xff and [char] ~ = if
 241     drop (ekey-csi-args-1-tilda) if exit endif
 242     0  ;; mask
 243   else
 244     dup [char] A [char] Z bounds? if (ekey-csi-args-1-xterm) exit endif
 245     (ekey-csi-args-1-mask) ifnot K-UNKNOWN exit endif
 246   endif
 247   ;; ( mask )
 248   (ekey-csi-array) @ (ekey-csi-special)
 249   dup K-UNKNOWN <> if or else drop endif  ;; apply mask
 250 ;
 251
 252 : (ekey-csi-args-2)  ( -- chcode )
 253   (ekey-csi-array) cell+ @ (ekey-xterm-mods) ?dup ifnot K-UNKNOWN exit endif
 254   (ekey-csi-endchar) @ 0xff and
 255   (ekey-csi-array) @ 1 = if (ekey-xterm-special)
 256   else [char] ~ = if (ekey-csi-array) @ (ekey-csi-special)
 257   else K-UNKNOWN
 258   endif endif
 259   dup K-UNKNOWN <> if or else drop endif  ;; apply mask
 260 ;
 261
 262 : (ekey-csi)  ( -- keycode )
 263   (ekey-parse-csi) ifnot exit endif
 264   ;; this seems to be a csi; check for valid argcount
 265   (ekey-csi-count) @ 2 > if K-UNKNOWN exit endif
 266   ;; mouse events are not here yet -- {\e}[<0;58;32M (button;x;y;[Mm])
 267   (ekey-csi-endchar) @ (ekey-csi-flag-mouse) and if K-UNKNOWN exit endif
 268   ;; specials
 269   (ekey-csi-count) @ case
 270     0 of (ekey-csi-args-0) endof
 271     1 of (ekey-csi-args-1) endof
 272     2 of (ekey-csi-args-2) endof
 273     otherwise drop K-UNKNOWN
 274   endcase
 275 ;
 276
 277 : (ekey-rxvt-keypad)  ( char -- newchar true // oldchar false )
 278   dup case
 279     [char] j of drop [char] * true endof
 280     [char] k of drop [char] + true endof
 281     [char] m of drop [char] - true endof
 282     [char] n of drop K-DELETE true endof
 283     [char] o of drop [char] / true endof
 284     [char] p of drop K-INSERT true endof
 285     [char] q of drop K-END true endof
 286     [char] r of drop K-DOWN true endof
 287     [char] s of drop K-PRIOR true endof
 288     [char] t of drop K-LEFT true endof
 289     [char] u of drop K-PAD5 true endof
 290     [char] v of drop K-RIGHT true endof
 291     [char] w of drop K-HOME true endof
 292     [char] x of drop K-UP true endof
 293     [char] y of drop K-NEXT true endof
 294     [char] M of drop K-ENTER true endof
 295     otherwise drop false
 296   endcase
 297 ;
 298
 299
 300 ;; to: -1 is infinite; 0 is no wait
 301 : wait-ekey  ( mstimeout -- key // -1 )
 302   get-winch if drop K-WINCH exit endif
 303   wait-key-dbg dup 27 = ifnot (ekey-fix-ctrl-letter) exit endif
 304   ;; esc sequence
 305   drop esc-timeout wait-key-dbg (ekey-esc-read?) if exit endif
 306   ;; xterm stupidity
 307   dup [char] O = if
 308     drop esc-timeout wait-key-dbg dup 0> if
 309       (ekey-esc-read?) if exit endif
 310       (ekey-rxvt-keypad) ifnot
 311         (* dup upcase-char (ekey-xterm-special)
 312         swap dup upcase-char <> if K-SHIFT-MASK or endif *)
 313         (ekey-xterm-special)
 314       endif
 315       exit
 316     else drop [char] O endif
 317   endif
 318   ;; csi
 319   dup [char] [ = if drop (ekey-csi)
 320   else
 321     ;; ctrl mask for non-control keys
 322     dup [char] A >= over [char] Z <= and if K-SHIFT-MASK or else upcase-char (ekey-fix-ctrl-letter) endif
 323     K-ALT-MASK or
 324   endif
 325 ;
 326
 327 : ekey?  ( -- flag )  0 wait-key? ;
 328
 329
 330 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 331 : ekey>fkey  ( keycode -- keycode ekeyflag )
 332   dup bl < over 127 = or over 255 > or
 333 ;
 334
 335 : ekey>char  ( keycode -- keycode false // char true )
 336   ekey>fkey not
 337 ;
 338
 339
 340 previous definitions