urflibs/linore.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrForth/C Forth Engine!
   4 ;; Copyright (C) 2023 Ketmar Dark // Invisible Vector
   5 ;; GPLv3 ONLY
   6 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   7 ;; simple line-oriented editor
   8 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   9
  10 (*
  11   usage:
  12     LINORE:RESET
  13       reset input line (make it empty)
  14
  15     LINORE:EDIT-LINE
  16       edit line without redrawing the prompt.
  17       result is in LINORE:ACCEPT-RESULT.
  18       default is:
  19         1 for enter, -1 on esc/^C/^D
  20
  21     LINORE:LINE  ( -- addr count )
  22       get edited line.
  23
  24     " abc" LINORE:LINE!
  25       set line to edit.
  26 *)
  27
  28 vocabulary linore
  29
  30 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31 ;; helper public API
  32 ;;
  33 also-defs: linore
  34
  35 ;; it will be filled later
  36 simple-vocabulary osc-actions
  37
  38 -3 constant result-^D
  39 -2 constant result-^C
  40 -1 constant result-esc
  41  1 constant result-enter
  42
  43 ;; if set, LINORE will switch to raw mode on entering
  44 ;; edit loop, and then switch back.
  45 true value tty-set/reset
  46
  47 ;; set this to non-zero in key handler to exit edit loop.
  48 ;; can be checked after editing.
  49 0 value accept-result
  50
  51 ;; start x position for line drawing.
  52 0 value start-x
  53 ;; total line width.
  54 80 value draw-width
  55 ;; when cursor is out of visible line part, make at
  56 ;; least this number of chars visible before/after the cursor.
  57 ;; do not set to zero or negative.
  58 10 value visible-amount
  59
  60 ;; reset input buffer (i.e. make it empty).
  61 ;; defined here, because we need it in the code.
  62 defer reset
  63
  64
  65 ;; use this from key processors to exit with this code.
  66 : finish-it!  ( code -- )  to accept-result ;
  67
  68 ;; called for normal keys (non-OSC).
  69 ;; drop `ch` and return TRUE if you handled it.
  70 ;; you can replace char code here.
  71 ;; negative `ch` means that this is "ESC something" sequence (not OSC).
  72 : key-processor  ( ch FALSE -- ch FALSE / TRUE )  ... ;
  73
  74 ;; called for OSC keys. string is OSC without "\e[".
  75 ;; drop string and return TRUE if you handled it.
  76 ;; you can replace string here.
  77 : osc-key-processor  ( addr count FALSE -- addr count FALSE / TRUE )  ... ;
  78
  79 ;; called before redrawing the input line.
  80 ;; return TRUE to prevent redraw.
  81 : on-before-draw  ( FALSE -- FALSE / TRUE )  ... ;
  82
  83 ;; called after redrawing the input line.
  84 : on-after-draw  ( -- )  ... ;
  85
  86 ;; this is called after screen switching
  87 : on-start-editing  ( -- ) ... ;
  88
  89 ;; this is called before screen switching
  90 : on-end-editing  ( -- ) ... ;
  91
  92 prev-defs
  93
  94
  95 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96 ;; LINORE internals
  97 ;;
  98
  99 also-defs: linore
 100 vocabulary linore-internal
 101 also-defs: linore-internal
 102
 103 ;; input buffer
 104 (user-tib) value buf
 105 (user-tib-size) 1- value buf-size
 106 0 value buf-len
 107 0 value draw-ofs
 108 0 value cur-ofs
 109
 110 ;; if set, first input will erase the line
 111 0 value first-input
 112
 113
 114 ;; OSC buffer (without first 2 chars)
 115 32 constant keybuf-size
 116 0 value keybuf-len
 117 create keybuf keybuf-size allot create;
 118
 119
 120 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 121 ;; working with cursor position
 122 ;;
 123
 124 : norm-cursor-pos  ( -- )  cur-ofs buf-len min 0 max to cur-ofs ;
 125
 126 : curvis-at-left  ( -- )
 127   cur-ofs visible-amount - 0 max to draw-ofs
 128 ;
 129
 130 : curvis-at-right  ( -- )
 131   \ " goo!" error
 132   cur-ofs draw-width - visible-amount + 0 max
 133   buf-len visible-amount - 0 max
 134   min to draw-ofs
 135 ;
 136
 137 : make-cursor-visible  ( -- )
 138   norm-cursor-pos
 139   case
 140     cur-ofs draw-ofs < if-of curvis-at-left endof
 141     cur-ofs draw-ofs - draw-width >= if-of curvis-at-right endof
 142   otherwise endcase
 143 ;
 144
 145
 146 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 147 ;; drawing the edit line
 148 ;;
 149
 150 : .osc-1  ( n cmd-char -- )
 151   " \e[" tty:raw-type
 152   swap <# #s #> tty:raw-type
 153   tty:raw-emit
 154 ;
 155
 156 : goto-x  ( x -- )
 157   1+ [char] g .osc-1
 158 ;
 159
 160 : to-start-x  ( -- )
 161   start-x goto-x
 162 ;
 163
 164 : higlight-first-input  ( -- )
 165   first-input if " \e[0;4m" else " \e[0m" endif
 166   tty:raw-type
 167 ;
 168
 169 : draw-line  ( -- )
 170   higlight-first-input
 171   buf draw-ofs +  buf-len draw-ofs - draw-width min  tty:raw-type
 172   " \e[0m\e[K" tty:raw-type
 173 ;
 174
 175 : pos-cursor  ( -- )
 176   start-x cur-ofs draw-ofs - + goto-x
 177 ;
 178
 179 : draw  ( -- )
 180   make-cursor-visible
 181   to-start-x draw-line pos-cursor
 182   tty:raw-flush
 183 ;
 184
 185
 186 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 187 ;; line editing helper words
 188 ;;
 189
 190 ;; -1 when out of bounds
 191 : CUR-C@  ( -- ch )
 192   cur-ofs 0 buf-len within if buf cur-ofs + c@
 193   else -1 endif
 194 ;
 195
 196 : (go-left-right)  ( mdir cmp-cfa -- mdir )
 197   >r BEGIN
 198     cur-c@ 0>=
 199   while
 200     cur-c@ bl r@ execute
 201   while
 202     dup +to cur-ofs
 203   repeat rdrop
 204 ;
 205
 206 : (go-word-left-right)  ( mdir -- )
 207   norm-cursor-pos
 208   dup 0< if -1-to cur-ofs endif
 209   cur-c@ 0>= if
 210     cur-c@ bl <= if ['] <= else ['] > endif
 211     (go-left-right)
 212     0< if +1-to cur-ofs endif
 213   else 0< if +1-to cur-ofs endif
 214   endif
 215 ;
 216
 217 prev-defs   ;; in LINORE again
 218
 219
 220 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 221 ;; line editing words
 222 ;;
 223
 224 simple-vocabulary linore-edit-api
 225 also linore-internal
 226 also-defs: linore-edit-api
 227
 228 : reset-first-input  ( -- )  false to first-input ;
 229
 230 : left  ( -- )  reset-first-input -1-to cur-ofs ;
 231 : right  ( -- )  reset-first-input +1-to cur-ofs ;
 232 : home  ( -- )  reset-first-input 0-to cur-ofs ;
 233 : end  ( -- )  reset-first-input buf-len to cur-ofs ;
 234
 235 : word-left  ( -- )  reset-first-input -1 (go-word-left-right) ;
 236 : word-right  ( -- )  reset-first-input +1 (go-word-left-right) ;
 237
 238 : delete  ( -- )
 239   reset-first-input
 240   norm-cursor-pos
 241   cur-ofs buf-len < if
 242     buf cur-ofs + dup 1+ swap
 243     buf-len cur-ofs - move
 244     -1-to buf-len
 245   endif
 246 ;
 247
 248 : backspace  ( -- )
 249   reset-first-input
 250   norm-cursor-pos
 251   cur-ofs if left delete endif
 252 ;
 253
 254 : ins-char  ( ch -- )
 255   first-input if linore:reset reset-first-input endif
 256   norm-cursor-pos
 257   buf cur-ofs +  dup 1+
 258   buf-len cur-ofs - move
 259   buf cur-ofs + c!
 260   +1-to buf-len
 261   right
 262 ;
 263
 264 prev-defs   ;; in LINORE-INTERNAL again
 265
 266
 267 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 268 ;; input handling
 269 ;;
 270
 271 ;; [0..31]
 272 create (ctrl-keys-handlers) 32 cells allot create;
 273 ;; default is "do nothing"
 274 (ctrl-keys-handlers) 32 cells erase
 275
 276 : set-ctrl-handler  ( cfa code -- )
 277   dup 0 32 within " invalid ctrl code" ?not-error
 278   cells (ctrl-keys-handlers) + !
 279 ;
 280
 281 :noname  ( -- )  result-^C linore:finish-it! ; 3 set-ctrl-handler  ;; ^C
 282 :noname  ( -- )  result-^D linore:finish-it! ; 4 set-ctrl-handler  ;; ^D
 283
 284 :noname  ( -- )  result-esc linore:finish-it! ; 27 set-ctrl-handler  ;; ESC
 285
 286 :noname  ( -- )  result-enter linore:finish-it! ;
 287 dup 10 set-ctrl-handler
 288 dup 13 set-ctrl-handler
 289 drop
 290
 291 ' linore-edit-api:backspace 8 set-ctrl-handler  ;; ^H
 292 ' linore:reset 25 set-ctrl-handler  ;; ^Y
 293
 294
 295 ;; collect OSC (without first 2 chars)
 296 : (collect-osc)  ( -- )
 297   0-to keybuf-len 0
 298   begin
 299     drop tty:raw-readch dup bl >
 300   while
 301     keybuf-len keybuf-size = if break endif
 302     dup keybuf keybuf-len + c!  +1-to keybuf-len
 303     dup [char] A >=
 304   until drop
 305 ;
 306
 307 : (edit-process-osc)  ( -- )
 308   (collect-osc)
 309   keybuf keybuf-len false linore:osc-key-processor
 310   ifnot
 311     vocid: linore:osc-actions find-word-in-voc
 312     if execute endif
 313   endif
 314 ;
 315
 316 : (edit-process-other)  ( ch -- )
 317   false linore:key-processor ifnot
 318     dup 0 32 within if
 319       cells (ctrl-keys-handlers) + @ ?dup if execute endif
 320     else
 321       dup 127 = if drop linore-edit-api:backspace
 322       else dup bl >= if linore-edit-api:ins-char else drop endif
 323       endif
 324     endif
 325   endif
 326 ;
 327
 328 : (edit-process-esc)  ( ch -- )
 329   drop ;; it is always 27
 330   tty:raw-readch dup [char] [ = if  ;; OSC start
 331     drop (edit-process-osc)
 332   else  ;; esc+something; negate keycode
 333     dup 27 <> if ( not esc-esc ) negate endif
 334     (edit-process-other)
 335   endif
 336 ;
 337
 338 prev-defs   ;; in LINORE again
 339
 340
 341
 342 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 343 ;; default OSC handlers
 344 ;;
 345
 346 also-defs: osc-actions
 347
 348 : D  linore-edit-api:left ;
 349 : C  linore-edit-api:right ;
 350 : 7~  linore-edit-api:home ;
 351 : 8~  linore-edit-api:end ;
 352 : 3~  linore-edit-api:delete ;
 353 : 1;5D  linore-edit-api:word-left ;
 354 : 1;5C  linore-edit-api:word-right ;
 355
 356 prev-defs   ;; in LINORE again
 357
 358
 359 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 360 ;; public API
 361 ;;
 362
 363 also linore-internal
 364 also linore-edit-api
 365
 366 ;; set "RESET" API
 367 :noname  ( -- )  0-to buf-len  0-to draw-ofs  0-to cur-ofs ;
 368 to linore:reset
 369
 370 : line  ( -- addr count )  buf buf-len ;
 371
 372 : line!  ( addr count -- )
 373   buf-size min dup to buf-len buf swap move
 374   buf-len to cur-ofs
 375 ;
 376
 377 : edit-line  ( -- )
 378   tty-set/reset if tty:set-raw " fuck!" ?not-error endif
 379   0 to accept-result  true to first-input
 380   on-start-editing
 381   begin
 382     false on-before-draw ifnot draw endif on-after-draw
 383     tty:raw-readch dup 0>=
 384   while
 385     dup 27 = if (edit-process-esc)
 386     else (edit-process-other)
 387     endif
 388   accept-result until
 389   on-end-editing
 390   tty-set/reset if tty:set-cooked drop endif
 391 ;
 392
 393
 394 ;; we're done
 395 previous previous prev-defs