Change KeysM to use a ContT monad instead of rolling my own.

Turns out the haskell geniuses already figured out how to encapsulate
such asynchronous control flow.

4 files changed, 124 insertions, 162 deletions

diff --git a/src/Config.hs b/src/Config.hs
index 4521cc1..04d13c6 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -2,13 +2,12 @@ module Config (config) where
 
 import Control.Monad.IO.Class
 import Control.Monad.Loops
-import Control.Monad.RWS (MonadReader (ask))
-import qualified Wetterhorn.Core.KeyEvent as KeyEvent
+import Wetterhorn.Core.KeyEvent qualified as KeyEvent
 import Wetterhorn.Core.Keys
 import Wetterhorn.Core.W
 import Wetterhorn.Layout.Full
 
-alsoLog :: KeyHandler -> W ()
+alsoLog :: KeyContinuation -> W ()
 alsoLog kh =
   putKeyHandler
     ( \ke -> do
@@ -21,36 +20,36 @@ config =
   defaultConfig
     { hooks =
         defaultHooks
-          { keyHook = keysWithHandler alsoLog $ do
-              ignoreReleaseEvents
-
-              bind (Mod1 .+ 'r') (shellExec "wofi --show run")
-              bind (Shift .+ Mod1 .+ 'R') requestHotReload
-              bind (Mod1 .+ 't') (shellExec "alacritty")
-
-              subbind (Mod1 .+ 'l') $ do
-                bind 'l' $ wio $ putStrLn "lololololo"
-                bind 'j' $ wio $ putStrLn "JOGGING!"
-
-              subbind (Mod1 .+ 'p') $ do
-                str <-
-                  unfoldM
-                    ( do
-                        ke <- ask
-                        if KeyEvent.codepoint ke == '\r'
-                          then return Nothing
-                          else do
-                            Just (KeyEvent.codepoint ke) <$ nextKeyPress
-                    )
-
-                liftIO $ putStrLn $ "You input: " ++ str
-                bind (str == "hello") $ do
-                  liftIO $ putStrLn "You Win! *\\o/*"
-                liftIO $ putStrLn "You Lose :("
-
-              forwardEvent,
-            surfaceHook = do
+          { surfaceHook = do
               handleSurface
           },
-      layout = WindowLayout Full
+      layout = WindowLayout Full,
+      resetHook = do
+        useKeysWithContinuation alsoLog $ do
+          kp <- nextKeyPress
+
+          bind kp (Mod1 .+ 'r') (shellExec "wofi --show run")
+
+          bind kp (Shift .+ Mod1 .+ 'R') requestHotReload
+
+          bind kp (Mod1 .+ 't') (shellExec "alacritty")
+
+          bind kp (weak $ Mod1 .+ '∫') (shellExec "gxmessage hi")
+
+          bind kp (Mod1 .+ 'p') $ do
+            str <-
+              unfoldM
+                ( do
+                    ke <- nextKeyPress
+                    return $
+                      if KeyEvent.codepoint ke == '\r'
+                        then Nothing
+                        else Just (KeyEvent.codepoint ke)
+                )
+            liftIO $ putStrLn $ "You input: " ++ str
+            bind kp (str == "hello") $ do
+              wio $ putStrLn "You Win! *\\o/*"
+            liftIO $ putStrLn "You lose :("
+
+          forwardEvent kp
     }
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
diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs
index c708961..dfa0753 100644
--- a/src/Wetterhorn/Core/W.hs
+++ b/src/Wetterhorn/Core/W.hs
@@ -10,16 +10,16 @@ import Control.Monad.Trans.Maybe
 import Data.Data (Typeable, cast)
 import Data.Kind (Constraint, Type)
 import Data.Set (Set)
-import qualified Data.Set as Set
+import Data.Set qualified as Set
 import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr)
 import Text.Read
 import Wetterhorn.Core.KeyEvent
 import Wetterhorn.Core.SurfaceEvent
 import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
-import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface
+import Wetterhorn.Foreign.ForeignInterface qualified as ForeignInterface
 import Wetterhorn.Foreign.WlRoots (Surface, WlrSeat)
 import Wetterhorn.StackSet hiding (layout)
-import qualified Wetterhorn.StackSet as StackSet
+import Wetterhorn.StackSet qualified as StackSet
 
 data RationalRect = RationalRect Rational Rational Rational Rational
 
@@ -136,7 +136,8 @@ defaultConfig :: Config ()
 defaultConfig =
   Config
     { hooks = defaultHooks,
-      layout = ()
+      layout = (),
+      resetHook = return ()
     }
 
 data Hooks = Hooks
@@ -146,7 +147,8 @@ data Hooks = Hooks
 
 data Config l = Config
   { layout :: l,
-    hooks :: Hooks
+    hooks :: Hooks,
+    resetHook :: W ()
   }
 
 data State = State
diff --git a/src/Wetterhorn/Foreign/Export.hs b/src/Wetterhorn/Foreign/Export.hs
index e35ed71..d1f83f5 100644
--- a/src/Wetterhorn/Foreign/Export.hs
+++ b/src/Wetterhorn/Foreign/Export.hs
@@ -5,8 +5,8 @@ module Wetterhorn.Foreign.Export () where
 import Config
 import Control.Arrow (Arrow (first))
 import Control.Monad (forM_)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as CH
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as CH
 import Foreign
   ( Ptr,
     Storable (poke, pokeByteOff),
@@ -21,7 +21,7 @@ import Foreign.C (CChar, CInt (..))
 import Wetterhorn.Core.KeyEvent (KeyEvent (..), KeyState (..))
 import Wetterhorn.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent))
 import Wetterhorn.Core.W (W, Wetterhorn)
-import qualified Wetterhorn.Core.W as W
+import Wetterhorn.Core.W qualified as W
 import Wetterhorn.Foreign.ForeignInterface
 import Wetterhorn.Foreign.WlRoots
 
@@ -65,10 +65,12 @@ pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn
 pluginHotStart chars len = do
   bs <- BS.packCStringLen (chars, fromIntegral len)
   foreignInterface <- getForeignInterface
-  newStablePtr
-    ( W.Context foreignInterface config,
-      W.demarshalState config (CH.unpack bs)
-    )
+  wtr <-
+    newStablePtr
+      ( W.Context foreignInterface config,
+        W.demarshalState config (CH.unpack bs)
+      )
+  runForeign (\(conf, _) -> W.resetHook conf) wtr
 
 -- | This function is called when a "coldstart" request is receieved. It just
 -- calles the function "wetterhorn". This function should be defined in the main
@@ -80,7 +82,8 @@ pluginColdStart :: IO Wetterhorn
 pluginColdStart = do
   foreignInterface <- getForeignInterface
   state <- W.initColdState config
-  newStablePtr (W.Context foreignInterface config, state)
+  wtr <- newStablePtr (W.Context foreignInterface config, state)
+  runForeign (\(conf, _) -> W.resetHook conf) wtr
 
 -- | Marshals the opaque state to a C-style byte array and size pointer.
 foreign export ccall "plugin_marshal_state"