slof/fs/accept.fs

\ *****************************************************************************
\ * Copyright (c) 2004, 2008 IBM Corporation
\ * All rights reserved.
\ * This program and the accompanying materials
\ * are made available under the terms of the BSD License
\ * which accompanies this distribution, and is available at
\ * http://www.opensource.org/licenses/bsd-license.php
\ *
\ * Contributors:
\ *     IBM Corporation - initial implementation
\ ****************************************************************************/


\ Implementation of ACCEPT.  Using ECMA-48 for terminal control.

: beep  bell emit ;

: TABLE-EXECUTE
  CREATE DOES> swap cells+ @ ?dup IF execute ELSE beep THEN ;

0 VALUE accept-adr
0 VALUE accept-max
0 VALUE accept-len
0 VALUE accept-cur

: esc  1b emit ;
: csi  esc 5b emit ;

: move-cursor ( -- )
   esc ." 8" accept-cur IF
      csi base @ decimal accept-cur 0 .r base ! ." C"
   THEN
;

: redraw-line ( -- )
   accept-cur accept-len = IF EXIT THEN
   move-cursor
   accept-adr accept-len accept-cur /string type
   csi ." K" move-cursor
;

: full-redraw-line ( -- )
   accept-cur 0 to accept-cur move-cursor
   accept-adr accept-len type
   csi ." K" to accept-cur move-cursor
;

: redraw-prompt ( -- )
   cr depth . [char] > emit
;

: insert-char ( char -- )
   accept-len accept-max = IF drop beep EXIT THEN
   accept-cur accept-len <> IF csi ." @" dup emit
   accept-adr accept-cur + dup 1+ accept-len accept-cur - move
   ELSE dup emit THEN
   accept-adr accept-cur + c!
   accept-cur 1+ to accept-cur
   accept-len 1+ to accept-len redraw-line
;

: delete-char ( -- )
   accept-cur accept-len = IF beep EXIT THEN
   accept-len 1- to accept-len
   accept-adr accept-cur + dup 1+ swap accept-len accept-cur - move
   csi ." P" redraw-line
;

\ *
\ * History handling
\ *

STRUCT
cell FIELD his>next
cell FIELD his>prev
cell FIELD his>len
   0 FIELD his>buf
CONSTANT /his
0 VALUE his-head
0 VALUE his-tail
0 VALUE his-cur

: add-history ( -- )
   accept-len 0= IF EXIT THEN
   /his accept-len + alloc-mem
   his-tail IF dup his-tail his>next ! ELSE dup to his-head THEN
   his-tail over his>prev !  0 over his>next !  dup to his-tail
   accept-len over his>len !  accept-adr swap his>buf accept-len move
;

: history  ( -- )
   his-head BEGIN dup WHILE
   cr dup his>buf over his>len @ type
   his>next @ REPEAT drop
;

: select-history ( his -- )
   dup to his-cur dup IF
   dup his>len @ accept-max min dup to accept-len to accept-cur
   his>buf accept-adr accept-len move ELSE
   drop 0 to accept-len 0 to accept-cur THEN
   full-redraw-line
;


\
\ tab completion
\

\ tab completion state variables
0 value ?tab-pressed
0 value tab-last-adr
0 value tab-last-len

\ compares two strings and returns the longest equal substring.
: $same-string ( addr-1 len-1 addr-2 len-2 -- addr-1 len-1' )
   dup 0= IF    \ The second parameter is not a string.
      2drop EXIT \ bail out
   THEN
   rot min 0 0 -rot ( addr1 addr2 0 len' 0 )
   DO ( addr1 addr2 len-1' )
      2 pick i + c@ lcc
      2 pick i + c@ lcc
      = IF 1 + ELSE leave THEN
   LOOP
   nip
;

: $tab-sift-words    ( text-addr text-len -- sift-count )
   sift-compl-only >r true to sift-compl-only \ save sifting mode

   last BEGIN @ ?dup WHILE \ loop over all words
      $inner-sift IF \ any completions possible?
         \ convert to lower case for user interface sanity
         2dup bounds DO I c@ lcc I c! LOOP
         ?tab-pressed IF 2dup type space THEN  \ <tab><tab> prints possibilities
         tab-last-adr tab-last-len $same-string \ find matching substring ...
         to tab-last-len to tab-last-adr       \ ... and save it
      THEN
   repeat
   2drop

   #sift-count 0 to #sift-count	\ how many words were found?
   r> to sift-compl-only		\ restore sifting completion mode
;

\ 8< node sifting for tab completion on device tree nodes below this line 8<

#include <stack.fs>

10 new-stack device-stack

: (next-dev) ( node -- node' addr len )
   device-stack
   dup (node>path) rot
   dup child IF dup push child -rot EXIT THEN
   dup peer IF peer -rot EXIT THEN
   drop
   BEGIN
      stack-depth
   WHILE
      pop peer ?dup IF -rot EXIT THEN
   REPEAT
   0 -rot
;

: $inner-sift-nodes ( text-addr text-len node -- ... path-addr path-len true | false )
   (next-dev) ( text-addr text-len node' path-addr path-len )
   dup 0= IF drop false EXIT THEN
   2dup 6 pick 6 pick find-isubstr ( text-addr text-len node' path-addr path-len pos )
   0= IF
      #sift-count 1+ to #sift-count \ count completions
      true
   ELSE
      2drop false
   THEN
;

\
\ test function for (next-dev)
: .nodes ( -- )
   s" /" find-node BEGIN dup WHILE
      (next-dev)
      type cr
   REPEAT
   drop
   reset-stack
;

\ node sifting wants its own pockets
create sift-node-buffer 1000 allot
0 value sift-node-num
: sift-node-buffer
   sift-node-buffer sift-node-num 100 * +
   sift-node-num 1+ dup 10 = IF drop 0 THEN
   to sift-node-num
;

: $tab-sift-nodes    ( text-addr text-len -- sift-count )
   s" /" find-node BEGIN dup WHILE
      $inner-sift-nodes IF \ any completions possible?
         sift-node-buffer swap 2>r 2r@ move 2r> \ make an almost permanent copy without strdup
         ?tab-pressed IF 2dup type space THEN  \ <tab><tab> prints possibilities
         tab-last-adr tab-last-len $same-string \ find matching substring ...
         to tab-last-len to tab-last-adr       \ ... and save it
      THEN
   REPEAT
   2drop drop
   #sift-count 0 to #sift-count	\ how many words were found?
   reset-stack
;

: $tab-sift    ( text-addr text-len -- sift-count )
   ?tab-pressed IF beep space THEN \ cosmetical fix for <tab><tab>

   dup IF bl rsplit dup IF 2swap THEN ELSE 0 0 THEN >r >r

   0 dup to tab-last-len to tab-last-adr	\ reset last possible match
   current-node @ IF			\ if we are in a node?
      2dup 2>r				\ save text
      $tab-sift-words to #sift-count	\ search in current node first
      2r>				\ fetch text to complete, again
   THEN
   2dup 2>r
   current-node @ >r 0 set-node		\ now search in global words
   $tab-sift-words to #sift-count
   r> set-node
   2r> $tab-sift-nodes
   \ concatenate previous commands
   r> r> dup IF s"  " $cat THEN tab-last-adr tab-last-len $cat
   to tab-last-len to tab-last-adr  \ ... and save the whole string
;

\ 8< node sifting for tab completion on device tree nodes above this line 8<

: handle-^A
   0 to accept-cur move-cursor ;
: handle-^B
   accept-cur ?dup IF 1- to accept-cur ( csi ." D" ) move-cursor THEN ;
: handle-^D
   delete-char ( redraw-line ) ;
: handle-^E
   accept-len to accept-cur move-cursor ;
: handle-^F
   accept-cur accept-len <> IF accept-cur 1+ to accept-cur csi ." C" THEN ;
: handle-^H
   accept-cur 0= IF beep EXIT THEN
   handle-^B delete-char
;
: handle-^I
   accept-adr accept-len
   $tab-sift 0 > IF
      ?tab-pressed IF
         redraw-prompt full-redraw-line
         false to ?tab-pressed
      ELSE
         tab-last-adr accept-adr tab-last-len move    \ copy matching substring
         tab-last-len dup to accept-len to accept-cur \ len and cursor position
         full-redraw-line		\ redraw new string
         true to ?tab-pressed	\ second tab will print possible matches
      THEN
   THEN
;

: handle-^K
   BEGIN accept-cur accept-len <> WHILE delete-char REPEAT ;
: handle-^L
   history redraw-prompt full-redraw-line ;
: handle-^N
   his-cur IF his-cur his>next @ ELSE his-head THEN
   dup to his-cur select-history
;
: handle-^P
   his-cur IF his-cur his>prev @ ELSE his-tail THEN
   dup to his-cur select-history
;
: handle-^Q  \ Does not handle terminal formatting yet.
   key insert-char ;
: handle-^R
   full-redraw-line ;
: handle-^U
   0 to accept-len 0 to accept-cur full-redraw-line ;

: handle-fn
   key drop beep
;

TABLE-EXECUTE handle-CSI
0 , ' handle-^P , ' handle-^N , ' handle-^F ,
' handle-^B , 0 , 0 , 0 ,
' handle-^A , 0 , 0 , ' handle-^E ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,

: handle-CSI-key
    key 1f and handle-CSI
;

TABLE-EXECUTE handle-meta
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , ' handle-fn ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , 0 ,
0 , 0 , 0 , ' handle-CSI-key ,
0 , 0 , 0 , 0 ,

: handle-ESC-O
   key
   dup 48 = IF
      handle-^A
   ELSE
      dup 46 = IF
         handle-^E
      THEN
   THEN drop
;

: handle-ESC-5b
   key
   dup 31 = IF \ HOME
      key drop ( drops closing 7e ) handle-^A
   ELSE
      dup 33 = IF \ DEL
         key drop handle-^D
      ELSE
         dup 34 = IF \ END
            key drop handle-^E
         ELSE
            dup 1f and handle-CSI
         THEN
      THEN
   THEN drop
;

: handle-ESC
   key
   dup 5b = IF
      handle-ESC-5b
   ELSE
      dup 4f = IF
         handle-ESC-O
      ELSE
         dup 1f and handle-meta
      THEN
   THEN drop
;

TABLE-EXECUTE handle-control
0 , \ ^@:
' handle-^A ,
' handle-^B ,
0 , \ ^C:
' handle-^D ,
' handle-^E ,
' handle-^F ,
0 , \ ^G:
' handle-^H ,
' handle-^I , \ tab
0 , \ ^J:
' handle-^K ,
' handle-^L ,
0 , \ ^M: enter: handled in main loop
' handle-^N ,
0 , \ ^O:
' handle-^P ,
' handle-^Q ,
' handle-^R ,
0 , \ ^S:
0 , \ ^T:
' handle-^U ,
0 , \ ^V:
0 , \ ^W:
0 , \ ^X:
0 , \ ^Y: insert save buffer
0 , \ ^Z:
' handle-ESC ,
0 , \ ^\:
0 , \ ^]:
0 , \ ^^:
0 , \ ^_:

: (accept) ( adr len -- len' )
   cursor-on
   to accept-max to accept-adr
   0 to accept-len 0 to accept-cur
   0 to his-cur
   1b emit 37 emit
   BEGIN
      key dup 0d <>
   WHILE
      dup 9 <> IF 0 to ?tab-pressed THEN \ reset state machine
      dup 7f = IF drop 8 THEN \ Handle DEL as if it was BS. ??? bogus
      dup bl < IF handle-control ELSE
         dup 80 and IF
            dup a0 < IF 7f and handle-meta ELSE drop beep THEN
         ELSE
            insert-char
	 THEN
      THEN
   REPEAT
   drop add-history
   accept-len to accept-cur
   move-cursor space
   accept-len
   cursor-off
;

' (accept) to accept