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   CUR-OFS DRAW-OFS < IF CURVIS-AT-LEFT
 140   ELSE CUR-OFS DRAW-OFS - DRAW-WIDTH >= IF CURVIS-AT-RIGHT
 141   ENDIF ENDIF
 142 ;
 143
 144
 145 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 146 ;; drawing the edit line
 147 ;;
 148
 149 : .OSC-1  ( n cmd-char -- )
 150   " \e[" TTY:RAW-TYPE
 151   SWAP <# #S #> TTY:RAW-TYPE
 152   TTY:RAW-EMIT
 153 ;
 154
 155 : GOTO-X  ( x -- )
 156   1+ [CHAR] G .OSC-1
 157 ;
 158
 159 : TO-START-X  ( -- )
 160   START-X GOTO-X
 161 ;
 162
 163 : HIGLIGHT-FIRST-INPUT  ( -- )
 164   FIRST-INPUT IF
 165     " \e[0;4m"
 166   ELSE
 167     " \e[0m"
 168   ENDIF
 169   TTY:RAW-TYPE
 170 ;
 171
 172 : DRAW-LINE  ( -- )
 173   HIGLIGHT-FIRST-INPUT
 174   BUF DRAW-OFS +  BUF-LEN DRAW-OFS - DRAW-WIDTH MIN  TTY:RAW-TYPE
 175   " \e[0m\e[K" TTY:RAW-TYPE
 176 ;
 177
 178 : POS-CURSOR  ( -- )
 179   START-X CUR-OFS DRAW-OFS - + GOTO-X
 180 ;
 181
 182 : DRAW  ( -- )
 183   MAKE-CURSOR-VISIBLE
 184   TO-START-X DRAW-LINE POS-CURSOR
 185   TTY:RAW-FLUSH
 186 ;
 187
 188
 189 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 190 ;; line editing helper words
 191 ;;
 192
 193 ;; -1 when out of bounds
 194 : CUR-C@  ( -- ch )
 195   CUR-OFS 0 BUF-LEN WITHIN IF BUF CUR-OFS + C@
 196   ELSE -1
 197   ENDIF
 198 ;
 199
 200 : (GO-LEFT-RIGHT)  ( mdir cmp-cfa -- mdir )
 201   >R BEGIN
 202     CUR-C@ 0>=
 203   WHILE
 204     CUR-C@ BL R@ EXECUTE
 205   WHILE
 206     DUP +TO CUR-OFS
 207   REPEAT RDROP
 208 ;
 209
 210 : (GO-WORD-LEFT-RIGHT)  ( mdir -- )
 211   NORM-CURSOR-POS
 212   DUP 0< IF -1-TO CUR-OFS ENDIF
 213   CUR-C@ 0>= IF
 214     CUR-C@ BL <= IF ['] <= ELSE ['] > ENDIF
 215     (GO-LEFT-RIGHT)
 216     0< IF +1-TO CUR-OFS ENDIF
 217   ELSE 0< IF +1-TO CUR-OFS ENDIF
 218   ENDIF
 219 ;
 220
 221 PREV-DEFS   ;; in LINORE again
 222
 223
 224 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 225 ;; line editing words
 226 ;;
 227
 228 SIMPLE-VOCABULARY LINORE-EDIT-API
 229 ALSO LINORE-INTERNAL
 230 ALSO-DEFS: LINORE-EDIT-API
 231
 232 : RESET-FIRST-INPUT  ( -- )  FALSE TO FIRST-INPUT ;
 233
 234 : LEFT  ( -- )  RESET-FIRST-INPUT -1-TO CUR-OFS ;
 235 : RIGHT  ( -- )  RESET-FIRST-INPUT +1-TO CUR-OFS ;
 236 : HOME  ( -- )  RESET-FIRST-INPUT 0-TO CUR-OFS ;
 237 : END  ( -- )  RESET-FIRST-INPUT BUF-LEN TO CUR-OFS ;
 238
 239 : WORD-LEFT  ( -- )  RESET-FIRST-INPUT -1 (GO-WORD-LEFT-RIGHT) ;
 240 : WORD-RIGHT  ( -- )  RESET-FIRST-INPUT +1 (GO-WORD-LEFT-RIGHT) ;
 241
 242 : DELETE  ( -- )
 243   RESET-FIRST-INPUT
 244   NORM-CURSOR-POS
 245   CUR-OFS BUF-LEN < IF
 246     BUF CUR-OFS + DUP 1+ SWAP
 247     BUF-LEN CUR-OFS - MOVE
 248     -1-TO BUF-LEN
 249   ENDIF
 250 ;
 251
 252 : BACKSPACE  ( -- )
 253   RESET-FIRST-INPUT
 254   NORM-CURSOR-POS
 255   CUR-OFS IF LEFT DELETE ENDIF
 256 ;
 257
 258 : INS-CHAR  ( ch -- )
 259   FIRST-INPUT IF LINORE:RESET RESET-FIRST-INPUT ENDIF
 260   NORM-CURSOR-POS
 261   BUF CUR-OFS +  DUP 1+
 262   BUF-LEN CUR-OFS - MOVE
 263   BUF CUR-OFS + C!
 264   +1-TO BUF-LEN
 265   RIGHT
 266 ;
 267
 268 PREV-DEFS   ;; in LINORE-INTERNAL again
 269
 270
 271 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 272 ;; input handling
 273 ;;
 274
 275 ;; [0..31]
 276 CREATE (CTRL-KEYS-HANDLERS) 32 CELLS ALLOT CREATE;
 277 ;; default is "do nothing"
 278 (CTRL-KEYS-HANDLERS) 32 CELLS ERASE
 279
 280 : SET-CTRL-HANDLER  ( cfa code -- )
 281   DUP 0 32 WITHIN " invalid ctrl code" ?NOT-ERROR
 282   CELLS (CTRL-KEYS-HANDLERS) + !
 283 ;
 284
 285 :NONAME  ( -- )  RESULT-^C LINORE:FINISH-IT! ; 3 SET-CTRL-HANDLER  ;; ^C
 286 :NONAME  ( -- )  RESULT-^D LINORE:FINISH-IT! ; 4 SET-CTRL-HANDLER  ;; ^D
 287
 288 :NONAME  ( -- )  RESULT-ESC LINORE:FINISH-IT! ; 27 SET-CTRL-HANDLER  ;; ESC
 289
 290 :NONAME  ( -- )  RESULT-ENTER LINORE:FINISH-IT! ;
 291 DUP 10 SET-CTRL-HANDLER
 292 DUP 13 SET-CTRL-HANDLER
 293 DROP
 294
 295 ' LINORE-EDIT-API:BACKSPACE 8 SET-CTRL-HANDLER  ;; ^H
 296 ' LINORE:RESET 25 SET-CTRL-HANDLER  ;; ^Y
 297
 298
 299 ;; collect OSC (without first 2 chars)
 300 : (COLLECT-OSC)  ( -- )
 301   0-TO keybuf-len 0
 302   BEGIN
 303     DROP TTY:RAW-READCH DUP BL >
 304   WHILE
 305     keybuf-len keybuf-size = IF BREAK ENDIF
 306     DUP keybuf keybuf-len + C!  +1-TO keybuf-len
 307     DUP [CHAR] A >=
 308   UNTIL DROP
 309 ;
 310
 311 : (EDIT-PROCESS-OSC)  ( -- )
 312   (COLLECT-OSC)
 313   keybuf keybuf-len FALSE LINORE:OSC-KEY-PROCESSOR
 314   IFNOT
 315     VOCID: LINORE:OSC-ACTIONS FIND-WORD-IN-VOC
 316     IF EXECUTE ENDIF
 317   ENDIF
 318 ;
 319
 320 : (EDIT-PROCESS-OTHER)  ( ch -- )
 321   FALSE LINORE:KEY-PROCESSOR IFNOT
 322     DUP 0 32 WITHIN IF
 323       CELLS (CTRL-KEYS-HANDLERS) + @ ?DUP IF EXECUTE ENDIF
 324     ELSE
 325       DUP 127 = IF DROP LINORE-EDIT-API:BACKSPACE
 326       ELSE DUP BL >= IF LINORE-EDIT-API:INS-CHAR ELSE DROP ENDIF
 327       ENDIF
 328     ENDIF
 329   ENDIF
 330 ;
 331
 332 : (EDIT-PROCESS-ESC)  ( ch -- )
 333   DROP ;; it is always 27
 334   TTY:RAW-READCH DUP [CHAR] [ = IF  ;; OSC start
 335     DROP (EDIT-PROCESS-OSC)
 336   ELSE  ;; esc+something; negate keycode
 337     DUP 27 <> IF ( not esc-esc ) NEGATE ENDIF
 338     (EDIT-PROCESS-OTHER)
 339   ENDIF
 340 ;
 341
 342 PREV-DEFS   ;; in LINORE again
 343
 344
 345
 346 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 347 ;; default OSC handlers
 348 ;;
 349
 350 ALSO-DEFS: OSC-ACTIONS
 351
 352 : D  LINORE-EDIT-API:LEFT ;
 353 : C  LINORE-EDIT-API:RIGHT ;
 354 : 7~  LINORE-EDIT-API:HOME ;
 355 : 8~  LINORE-EDIT-API:END ;
 356 : 3~  LINORE-EDIT-API:DELETE ;
 357 : 1;5D  LINORE-EDIT-API:WORD-LEFT ;
 358 : 1;5C  LINORE-EDIT-API:WORD-RIGHT ;
 359
 360 PREV-DEFS   ;; in LINORE again
 361
 362
 363 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 364 ;; public API
 365 ;;
 366
 367 ALSO LINORE-INTERNAL
 368 ALSO LINORE-EDIT-API
 369
 370 ;; set "RESET" API
 371 :NONAME  ( -- )  0-TO BUF-LEN  0-TO DRAW-OFS  0-TO CUR-OFS ;
 372 TO LINORE:RESET
 373
 374 : LINE  ( -- addr count )  BUF BUF-LEN ;
 375
 376 : LINE!  ( addr count -- )
 377   BUF-SIZE MIN DUP TO BUF-LEN BUF SWAP MOVE
 378   BUF-LEN TO CUR-OFS
 379 ;
 380
 381 : EDIT-LINE  ( -- )
 382   TTY-SET/RESET IF TTY:SET-RAW " fuck!" ?NOT-ERROR ENDIF
 383   0 TO ACCEPT-RESULT  TRUE TO FIRST-INPUT
 384   ON-START-EDITING
 385   BEGIN
 386     FALSE ON-BEFORE-DRAW IFNOT DRAW ENDIF ON-AFTER-DRAW
 387     TTY:RAW-READCH DUP 0>=
 388   WHILE
 389     DUP 27 = IF (EDIT-PROCESS-ESC)
 390     ELSE (EDIT-PROCESS-OTHER)
 391     ENDIF
 392   ACCEPT-RESULT UNTIL
 393   ON-END-EDITING
 394   TTY-SET/RESET IF TTY:SET-COOKED DROP ENDIF
 395 ;
 396
 397
 398 ;; we're done
 399 PREVIOUS PREVIOUS PREV-DEFS