1 files changed, 74 insertions, 116 deletions

diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs
index 90c24c4..b979048 100644
--- a/src/Wetterhorn/Core/Keys.hs
+++ b/src/Wetterhorn/Core/Keys.hs
@@ -1,34 +1,17 @@
-module Wetterhorn.Core.Keys
-  ( forwardKey,
-    forwardEvent,
-    KeysM,
-    bind,
-    subbind,
-    subbind_,
-    (.+),
-    Modifier (..),
-    keys,
-    ignoreReleaseEvents,
-    weak,
-    continue,
-    WeakKeyMatcher,
-    nextKeyEvent,
-    nextKeyPress,
-    keysWithHandler,
-    putKeyHandler,
-    KeyHandler,
-  )
-where
-
-import Control.Monad (void, when)
+module Wetterhorn.Core.Keys where
+
+import Control.Monad (forever, join, void, when)
+import Control.Monad.Cont.Class
 import Control.Monad.Fix (fix)
 import Control.Monad.IO.Class
+import Control.Monad.Reader (ReaderT (runReaderT))
 import Control.Monad.Reader.Class
-import Control.Monad.State (MonadState (get, put))
+import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT, gets)
+import Control.Monad.Trans.Cont
 import Data.Bits
 import Data.Word
 import Wetterhorn.Core.KeyEvent
-import qualified Wetterhorn.Core.KeyEvent as KeyEvent
+import Wetterhorn.Core.KeyEvent qualified as KeyEvent
 import Wetterhorn.Core.W
 import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
 
@@ -51,8 +34,8 @@ forwardKey keyEvent = do
       )
 
 -- | Forwards the current key event to the focused window.
-forwardEvent :: KeysM ()
-forwardEvent = liftW . forwardKey =<< ask
+forwardEvent :: KeyEvent -> KeysM ()
+forwardEvent = liftW . forwardKey
 
 -- | Enumeration of possible modifiers
 data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5
@@ -72,29 +55,61 @@ modifierToMask m =
       Mod4 -> 6
       Mod5 -> 7
 
+data KeysState = KeysState
+  { -- | Reference to the top. Used for a continue statement.
+    keysTop :: KeysM (),
+    handleContinuation :: KeyContinuation -> W ()
+  }
+
 -- | The Keys monad. This monad abstracts away control flow for handling key
 -- bindings. This makes it easy to make key-sequence bindings.
-newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a))
+-- newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a))
+newtype KeysM a = KeysM (ContT () (StateT KeysState W) a)
+  deriving (Monad, Functor, Applicative, MonadCont, MonadIO)
+
+-- | KeysM can be lifted from a W action.
+instance Wlike KeysM where
+  liftW = KeysM . lift . lift
 
-type KeyHandler = KeyEvent -> W ()
+type KeyContinuation = KeyEvent -> W ()
 
 -- Return type in the keysM monad.
-data KeysMR a = NextKey (KeysM a) | Lift a | Continue
-
-keysWithHandler :: (KeyHandler -> W ()) -> KeysM a -> KeyHandler
-keysWithHandler nextAction keysM = fix $ \top ke -> keys' top keysM ke
-  where
-    keys' top (KeysM fn) ke = do
-      e <- fn top ke
-      case e of
-        NextKey keysM' -> nextAction (keys' top keysM')
-        Lift _ -> return ()
-        _ -> nextAction top
-
-keys :: KeysM a -> KeyEvent -> W ()
-keys = keysWithHandler putKeyHandler
-
-putKeyHandler :: KeyHandler -> W ()
+-- data KeysMR a = NextKey (KeysM a) | Lift a | Continue
+
+-- keysWithHandler :: (KeyContinuation -> W ()) -> KeysM a -> KeyContinuation
+-- keysWithHandler nextAction keysM = fix $ \top ke -> keys' top keysM ke
+--   where
+--     keys' top (KeysM fn) ke = do
+--       e <- fn top ke
+--       case e of
+--         NextKey keysM' -> nextAction (keys' top keysM')
+--         Lift _ -> return ()
+--         _ -> nextAction top
+
+-- keys :: KeysM a -> KeyEvent -> W ()
+-- keys = keysWithHandler putKeyHandler
+
+useKeysWithContinuation :: (KeyContinuation -> W ()) -> KeysM () -> W ()
+useKeysWithContinuation continuation km@(KeysM c) =
+  evalStateT (evalContT (forever c)) (KeysState km continuation)
+
+useKeys :: KeysM () -> W ()
+useKeys = useKeysWithContinuation putKeyHandler
+
+nextKeyEvent :: KeysM KeyEvent
+nextKeyEvent = do
+  st <- KeysM $ lift get
+  KeysM $
+    shiftT
+      ( \keyHandler ->
+          lift . lift $
+            handleContinuation st (\kp -> evalStateT (keyHandler kp) st)
+      )
+
+continue :: KeysM ()
+continue = join (KeysM (gets keysTop))
+
+putKeyHandler :: KeyContinuation -> W ()
 putKeyHandler handler = do
   s@State {currentHooks = hooks} <- get
   put
@@ -105,63 +120,15 @@ putKeyHandler handler = do
             }
       }
 
--- | Returns the next key event. This returns both key pressed and key released
--- events, so it's good to be careful because duplicate casess can happen.
-nextKeyEvent :: KeysM KeyEvent
-nextKeyEvent = KeysM (\_ _ -> return (NextKey (KeysM (\_ -> return . Lift))))
-
 -- | Returns the next KeyPressed event. This is likely what 90% of use cases
 -- want rather than nextKeyEvent.
 nextKeyPress :: KeysM KeyEvent
 nextKeyPress = do
   k <- nextKeyEvent
   if KeyEvent.state k /= KeyPressed
-    then forwardEvent >> nextKeyPress
+    then forwardEvent k >> nextKeyPress
     else return k
 
--- | Resets the handling of KeyBindings to the top. Operates like a 'continue'
--- statement in imperative programming languages.
-continue :: KeysM ()
-continue = KeysM $ \_ _ -> return Continue
-
-instance Functor KeysM where
-  fmap f (KeysM fn) = KeysM $ \top keyEvent -> do
-    e <- fn top keyEvent
-    return $
-      case e of
-        NextKey ma -> NextKey $ fmap f ma
-        Lift a -> Lift $ f a
-        Continue -> Continue
-
-instance Applicative KeysM where
-  pure a = KeysM (\_ _ -> return (Lift a))
-  (<*>) mfn ma = do
-    fn <- mfn
-    fn <$> ma
-
-instance Monad KeysM where
-  a >>= fmb = keysJoin (fmap fmb a)
-    where
-      keysJoin (KeysM f) = KeysM $ \top keyEvent -> do
-        e <- f top keyEvent
-        case e of
-          Lift (KeysM f') -> f' top keyEvent
-          NextKey sub -> return $ NextKey $ keysJoin sub
-          Continue -> return Continue
-
--- | KeysM can be lifted from a W action.
-instance Wlike KeysM where
-  liftW act = KeysM (\_ _ -> Lift <$> act)
-
--- | KeyM can be lifted from an IO action.
-instance MonadIO KeysM where
-  liftIO = liftW . wio
-
--- | Monad
-instance MonadReader KeyEvent KeysM where
-  ask = KeysM (\_ -> return . Lift)
-  local fn (KeysM fn') = KeysM $ \a (fn -> ns) -> fn' a ns
-
 --
 -- binding EDSL used to expressively create key bindings and subbindings inside
 -- a KeysM () context.
@@ -218,32 +185,23 @@ instance MatchKey WeakKeyMatcher where
     where
       ms = KeyEvent.modifiers ev
 
-subbind :: (MatchKey m) => m -> KeysM () -> KeysM ()
-subbind m act = do
-  ev <- ask
-  when (matchKey m ev) $ do
-    _ <- nextKeyPress
-    act
-    continue
+class IsKeysM m where
+  toKeysM :: m a -> KeysM a
 
--- | Like 'subbind', but does not read the next keypress.
-subbind_ :: (MatchKey m) => m -> KeysM () -> KeysM ()
-subbind_ m act = do
-  ev <- ask
-  when (matchKey m ev) $ do
-    act
-    continue
+instance IsKeysM W where
+  toKeysM = liftW
+
+instance IsKeysM KeysM where
+  toKeysM = id
 
-bind :: (MatchKey m) => m -> W () -> KeysM ()
-bind m act = do
-  ev <- ask
+bind :: (MatchKey m, IsKeysM k) => KeyEvent -> m -> k () -> KeysM ()
+bind ev m act = do
   when (matchKey m ev) $ do
-    liftW act
+    toKeysM act
     continue
 
-ignoreReleaseEvents :: KeysM ()
-ignoreReleaseEvents = do
-  ev <- ask
+ignoreReleaseEvents :: KeyEvent -> KeysM ()
+ignoreReleaseEvents ev = do
   when (KeyEvent.state ev /= KeyEvent.KeyPressed) $ do
-    forwardEvent
+    forwardEvent ev
     continue