Paste: WIP "Quickbinds" Vocab

! Copyright (C) 2025 Serre.
! See https://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators grouping hashtables kernel
math math.parser models parser sequences splitting ui.gadgets
ui.gadgets.buttons ui.gadgets.buttons.private ui.gadgets.labels
ui.gadgets.packs ui.gestures words ;
IN: quickbinds

!   Syntax words and GUI tool for quickly developing and 
! modifying UI gestures, including support for modal keybinds.

! == Core interface

: parse-mods ( strings -- mods )
   [ empty? not ] 1guard 
   [ { { "S" [ S+ ] } { "C" [ C+ ] }
       { "A" [ A+ ] } { "M" [ M+ ] } } case ] map ;

: string>keys ( string -- key-up/down )
   [ first CHAR: ^ = ] keep over [ rest ] when
   "+" split unclip-last 
      [ parse-mods ] dip
   rot [ key-up boa ] [ key-down boa ] if ;

SYNTAX: KEYSTROKE: scan-object string>keys suffix! ;

TUPLE: quickbind quot key-gesture mode desc ;
C: <quickbind> quickbind

: modal-hashtable ( quickbinds mode -- hashtable )
   [ swap mode>> = ] curry filter 
      [ [ key-gesture>> ] [ quot>> ] bi 2array ] map
   >hashtable ;

: update-qb-gestures ( class -- )
    dup [ "quickbinds" word-prop ] 
   [ "quickbinds-mode" word-prop ] bi
   modal-hashtable set-gestures ;

: change-qb-mode ( class mode -- )
   dupd "quickbinds-mode" set-word-prop 
        update-qb-gestures ;
! Would probably benefit from tying mode to model.

: (quickbind) ( class quickbinds -- )
   [        "quickbinds" set-word-prop ] curry
   [ 0 "quickbinds-mode" set-word-prop ]
   [ update-qb-gestures ] tri ;

: <quickbind>* ( quot str mode desc -- quickbind )  
   [ [ string>keys ] 
     [ dup number? [ def>> call( -- x ) ] unless ] 
   bi* ] dip <quickbind> ;

SYNTAX: QUICKBINDS:
   scan-word
      \ ; parse-until
   4 group [ first4 <quickbind>* ] map
   (quickbind) ;

! == Quickbind UI tools (quickbinds.ui?)

! (Can't subclass buttons and init w/button-new?)
TUPLE: quickbind-button < pack 
   index class grab? ;

:: set-quickbind ( gesture qb-index class -- )
   class "quickbinds" 
      [ dup [ qb-index ] dip 
        [ gesture >>key-gesture ] change-nth 
      ]
   change-word-prop 
   class update-qb-gestures ;

: update-qb-button ( quickbind-button -- )
   dup [ gadget-child gadget-child ] [ index>> ]
       [ class>> "quickbinds" word-prop ] tri
   nth key-gesture>> gesture>string >>string drop
   relayout-1 ;

: (grab) ( button -- )
   parents second t >>grab? drop ;

: <quickbind-button> ( index class -- button )
   [ quickbind-button new vertical >>orientation
        "Loading..." [ (grab) ] 
     <roll-button> add-gadget ] 2dip
   [ >>index ] [ >>class ] bi* [ update-qb-button ] keep ;
 
M: quickbind-button
      handle-gesture ( gesture gadget -- ? )
   2dup [ key-down? ] [ grab?>> ] bi* and
   [ [ [ index>> ] [ class>> ] bi set-quickbind ] keep
     f >>grab? update-qb-button f ]
   [ 2drop t ] if ;

TUPLE: quickbind-gadget < pack
   class ;

: <quickbind-row> ( quickbind index class -- pack )
   <quickbind-button> swap 
             [ desc>> " " " " surround <label> ] 
             [ mode>> number>string 
               "(Mode: " ") " surround <label> ] bi
   3array [ <shelf> ] dip add-gadgets ;
   
: <quickbind-gadget> ( class -- pack ) ! A Grid would be nicer.
   [ quickbind-gadget new vertical >>orientation ] dip
      [ "quickbinds" word-prop ] keep 
   [ <quickbind-row> ] curry map-index add-gadgets ;

! Example listener usage:
! TUPLE: test-gadget < label
! ENUMERATION: mode normal insert
! QUICKBINDS: test-gadget
! [ "Hello" >>text relayout-1 ] "S+TAB" mode.normal "Greet User."
!   [ "Bye" >>text relayout-1 ] "C+TAB" mode.normal "Bide \"Adeiu\"."
! [ "Asdfq" >>text relayout-1 ] "S+TAB" mode.insert "Some other nonsense." ;
! "" test-gadget new-label "Quickbound Gadget" open-window
! test-gadget <quickbind-gadget> "Keybind Configuration" open-window
! ...*Almost*, the <quickbind-button> gadget works as intended by itself, but
! not when in a <quickbind-gadget>. Pressing Shift results in an empty gesture.