urflibs/linore.f

   1 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; and now for something completely different...
   3 ;; UrAsm Forth Engine!
   4 ;; GPLv3 ONLY
   5 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6 ;; simple line editor
   7 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (*
  10   usage:
  11     LINORE:RESET
  12       reset input line (make it empty)
  13
  14     " pp>" LINORE:PROMPT-EDIT
  15       edit line.
  16       return TRUE on enter, or FALSE on esc/^C/^D
  17
  18     LINORE:EDIT-LOOP
  19       edit line without redrawing the prompt.
  20       return TRUE on enter, or FALSE on esc/^C/^D
  21
  22     LINORE:LINE  ( -- addr count )
  23       get edited line.
  24
  25     " abc" LINORE:LINE!
  26       set line to edit.
  27 *)
  28
  29 VOCABULARY LINORE
  30
  31 VOCABULARY LINORE-INTERNAL
  32 ALSO-DEFS: LINORE-INTERNAL
  33
  34 ;; input buffer
  35 (USER-TIB) VALUE BUF
  36 (USER-TIB-SIZE) VALUE BUF-SIZE
  37 0 VALUE BUF-LEN
  38 0 VALUE DRAW-OFS
  39 0 VALUE CUR-OFS
  40 ;; start position for line drawing
  41 0 VALUE START-X
  42 30 VALUE DRAW-WIDTH
  43 10 VALUE DRAW-MARGIN
  44
  45
  46 ;; OSC buffer (without first 2 chars)
  47 32 CONSTANT keybuf-size
  48 0 VALUE keybuf-len
  49 CREATE keybuf keybuf-size ALLOT CREATE;
  50
  51 ;; collect OSC (without first 2 chars)
  52 : (COLLECT-OSC)  ( -- )
  53   0-TO keybuf-len 0
  54   BEGIN
  55     DROP TTY:RAW-READCH DUP BL >
  56   WHILE
  57     keybuf-len keybuf-size = IF BREAK ENDIF
  58     DUP keybuf keybuf-len + C!  +1-TO keybuf-len
  59     DUP [CHAR] A >=
  60   UNTIL DROP
  61 ;
  62
  63
  64 : NORM-CURSOR-POS  ( -- )  CUR-OFS BUF-LEN MIN 0 MAX TO CUR-OFS ;
  65
  66
  67 : CURVIS-AT-LEFT  ( -- )
  68   CUR-OFS DRAW-MARGIN - 0 MAX TO DRAW-OFS
  69 ;
  70
  71 : CURVIS-AT-RIGHT  ( -- )
  72   \ " goo!" ERROR
  73   CUR-OFS DRAW-WIDTH - DRAW-MARGIN + 0 MAX
  74   BUF-LEN DRAW-MARGIN - 0 MAX
  75   MIN TO DRAW-OFS
  76 ;
  77
  78 : MAKE-CURSOR-VISIBLE  ( -- )
  79   NORM-CURSOR-POS
  80   CUR-OFS DRAW-OFS < IF CURVIS-AT-LEFT
  81   ELSE CUR-OFS DRAW-OFS - DRAW-WIDTH >= IF CURVIS-AT-RIGHT
  82   ENDIF ENDIF
  83 ;
  84
  85
  86 : .OSC-1  ( n cmd-char -- )
  87   " \e[" TTY:RAW-TYPE
  88   SWAP <# #S #> TTY:RAW-TYPE
  89   TTY:RAW-EMIT
  90 ;
  91
  92 : GOTO-X  ( x -- )
  93   1+ [CHAR] G .OSC-1
  94 ;
  95
  96 : TO-START-X  ( -- )
  97   START-X GOTO-X
  98 ;
  99
 100 : DRAW-LINE  ( -- )
 101   BUF DRAW-OFS +  BUF-LEN DRAW-OFS - DRAW-WIDTH MIN  TTY:RAW-TYPE
 102   " \e[K" TTY:RAW-TYPE
 103 ;
 104
 105 : POS-CURSOR  ( -- )
 106   START-X CUR-OFS DRAW-OFS - + GOTO-X
 107 ;
 108
 109 : DRAW  ( -- )
 110   MAKE-CURSOR-VISIBLE
 111   TO-START-X DRAW-LINE POS-CURSOR
 112   TTY:RAW-FLUSH
 113 ;
 114
 115
 116 ;; -1 when out of bounds
 117 : CUR-C@  ( -- ch )
 118   CUR-OFS 0 BUF-LEN WITHIN IF BUF CUR-OFS + C@
 119   ELSE -1
 120   ENDIF
 121 ;
 122
 123 ;; various commands to bind
 124 : DO-LEFT  ( -- )  -1-TO CUR-OFS ;
 125 : DO-RIGHT  ( -- )  +1-TO CUR-OFS ;
 126 : DO-HOME  ( -- )  0-TO CUR-OFS ;
 127 : DO-END  ( -- )  BUF-LEN TO CUR-OFS ;
 128
 129 : (GO-LEFT-RIGHT)  ( mdir cmp-cfa -- mdir )
 130   >R BEGIN
 131     CUR-C@ 0>=
 132   WHILE
 133     CUR-C@ BL R@ EXECUTE
 134   WHILE
 135     DUP +TO CUR-OFS
 136   REPEAT RDROP
 137 ;
 138
 139 : (GO-WORD-LEFT-RIGHT)  ( mdir -- )
 140   NORM-CURSOR-POS
 141   DUP 0< IF -1-TO CUR-OFS ENDIF
 142   CUR-C@ 0>= IF
 143     CUR-C@ BL <= IF ['] <= ELSE ['] > ENDIF
 144     (GO-LEFT-RIGHT)
 145     0< IF +1-TO CUR-OFS ENDIF
 146   ELSE 0< IF +1-TO CUR-OFS ENDIF
 147   ENDIF
 148 ;
 149
 150 : DO-WORD-LEFT  ( -- )  -1 (GO-WORD-LEFT-RIGHT) ;
 151 : DO-WORD-RIGHT  ( -- )  +1 (GO-WORD-LEFT-RIGHT) ;
 152
 153 : DO-DELETE  ( -- )
 154   NORM-CURSOR-POS
 155   CUR-OFS BUF-LEN < IF
 156     BUF CUR-OFS + DUP 1+ SWAP
 157     BUF-LEN CUR-OFS - MOVE
 158     -1-TO BUF-LEN
 159   ENDIF
 160 ;
 161
 162 : DO-BACKSPACE  ( -- )
 163   NORM-CURSOR-POS
 164   CUR-OFS IF DO-LEFT DO-DELETE ENDIF
 165 ;
 166
 167 : DO-INS-CHAR  ( ch -- )
 168   NORM-CURSOR-POS
 169   BUF CUR-OFS +  DUP 1+
 170   BUF-LEN CUR-OFS - MOVE
 171   BUF CUR-OFS + C!
 172   +1-TO BUF-LEN
 173   DO-RIGHT
 174 ;
 175
 176
 177 : MAX-PROMPT-LEN  ( -- len )
 178   DRAW-WIDTH DRAW-MARGIN 3 * - 0 MAX
 179 ;
 180
 181 : PROMPT  ( addr count -- )
 182   0 MAX  ;; just in case
 183   TTY:SIZE DROP TO DRAW-WIDTH
 184   \  30 TO DRAW-WIDTH -- debug
 185   DUP MAX-PROMPT-LEN > IF
 186     ;; prompt is too long
 187     MAX-PROMPT-LEN >R SWAP R@ + SWAP R> - 0 MAX
 188   ENDIF
 189   DUP TO START-X DUP -TO DRAW-WIDTH
 190   13 TTY:RAW-EMIT TTY:RAW-TYPE
 191 ;
 192
 193 PREV-DEFS
 194
 195
 196 ALSO LINORE-INTERNAL
 197 ALSO-DEFS: LINORE
 198
 199 : KEY-PROCESSOR  ( ch FALSE -- ch FALSE / TRUE )  ... ;
 200 : ESC-PROCESSOR  ( ch FALSE -- ch FALSE / TRUE )  ... ;
 201 : OSC-KEY-PROCESSOR  ( addr count FALSE -- addr count FALSE / TRUE )  ... ;
 202
 203 : ON-ESCAPED  ( -- )  ... ;
 204 : ON-ACCEPTED  ( -- )  ... ;
 205 : ON-START-EDIT  ( -- )  ... ;
 206 : ON-BEFORE-DRAW  ( FALSE -- FALSE / TRUE )  ... ;
 207 : ON-AFTER-DRAW  ( -- )  ... ;
 208
 209
 210 SIMPLE-VOCABULARY OSC-ACTIONS
 211 ALSO-DEFS: OSC-ACTIONS
 212
 213 : D  DO-LEFT ;
 214 : C  DO-RIGHT ;
 215 : 7~  DO-HOME ;
 216 : 8~  DO-END ;
 217 : 3~  DO-DELETE ;
 218 : 1;5D  DO-WORD-LEFT ;
 219 : 1;5C  DO-WORD-RIGHT ;
 220 \ : A  HISTORY-UP ;
 221 \ : B  HISTORY-DOWN ;
 222
 223 PREV-DEFS
 224
 225
 226 ;; reset input buffer (i.e. make it empty)
 227 : RESET  ( -- )  0-TO BUF-LEN  0-TO DRAW-OFS  0-TO CUR-OFS ;
 228
 229 : LINE  ( -- addr count )  BUF BUF-LEN ;
 230
 231 : LINE!  ( addr count -- )
 232   BUF-SIZE MIN DUP TO BUF-LEN BUF SWAP MOVE
 233   BUF-LEN TO CUR-OFS
 234 ;
 235
 236 : (EDIT-PROCESS-OSC)  ( -- exitflag )
 237   (COLLECT-OSC)
 238   keybuf keybuf-len FALSE OSC-KEY-PROCESSOR
 239   IFNOT
 240     VOCID: OSC-ACTIONS FIND-WORD-IN-VOC
 241     IF EXECUTE ENDIF
 242   ENDIF
 243   FALSE
 244 ;
 245
 246 : (EDIT-PROCESS-ESC)  ( -- exitflag )
 247   TTY:RAW-READCH DUP [CHAR] [ = IF DROP (EDIT-PROCESS-OSC)
 248   ELSE FALSE ESC-PROCESSOR IFNOT 27 = IF -1 ELSE FALSE ENDIF
 249   ELSE FALSE
 250   ENDIF ENDIF
 251 ;
 252
 253 : (EDIT-PROCESS-OTHER)  ( ch -- exitflag )
 254   FALSE KEY-PROCESSOR IFNOT
 255     CASE
 256       3 OF -1 ENDOF
 257       4 OF -1 ENDOF
 258       8 OF DO-BACKSPACE FALSE ENDOF
 259       10 OF 1 ENDOF
 260       13 OF 1 ENDOF
 261       25 OF RESET FALSE ENDOF  ;; ^Y
 262       127 OF DO-BACKSPACE FALSE ENDOF
 263       OTHERWISE DO-INS-CHAR FALSE
 264     ENDCASE
 265   ELSE FALSE
 266   ENDIF
 267 ;
 268
 269 : EDIT-LOOP  ( -- accepted )
 270   TTY:SET-RAW " fuck!" ?NOT-ERROR
 271   ON-START-EDIT FALSE
 272   BEGIN
 273     DROP  ;; drop old exit flag
 274     FALSE ON-BEFORE-DRAW IFNOT DRAW ENDIF ON-AFTER-DRAW
 275     TTY:RAW-READCH DUP 0>=
 276   WHILE
 277     DUP 27 = IF DROP (EDIT-PROCESS-ESC)
 278     ELSE (EDIT-PROCESS-OTHER)
 279     ENDIF
 280   DUP UNTIL 0>
 281   TTY:SET-COOKED DROP
 282   DUP IF ON-ACCEPTED ELSE ON-ESCAPED ENDIF
 283 ;
 284
 285 : PROMPT-EDIT  ( addr count -- accepted )
 286   TTY:SET-RAW " fuck!" ?NOT-ERROR
 287   PROMPT
 288   EDIT-LOOP
 289 ;
 290
 291 PREVIOUS PREV-DEFS