aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Config.hs7
-rw-r--r--src/Wetterhorn/Dsl/Input.hs55
-rw-r--r--src/Wetterhorn/Keys/Macros.hs115
3 files changed, 109 insertions, 68 deletions
diff --git a/src/Config.hs b/src/Config.hs
index dab514b..ca99aad 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,5 +1,6 @@
module Config (config) where
+import Control.Monad (unless, when)
import Control.Monad.IO.Class
import Control.Monad.Loops
import Text.Printf
@@ -8,7 +9,6 @@ import Wetterhorn.Dsl.Bind
import Wetterhorn.Dsl.Input
import Wetterhorn.Keys.Macros
import Wetterhorn.Layout.Full
-import Control.Monad (unless)
config :: Config WindowLayout
config =
@@ -23,6 +23,11 @@ config =
useInputHandler $ do
ev <- nextInputEvent
+ macroSupport
+ (Mod1 .+ 'q')
+ (weak $ Mod1 .+ '@')
+ ev
+
bind ev (released btnLeft) $ do
wio $ putStrLn "Left Button Released!!"
diff --git a/src/Wetterhorn/Dsl/Input.hs b/src/Wetterhorn/Dsl/Input.hs
index 55f1a5b..625a64b 100644
--- a/src/Wetterhorn/Dsl/Input.hs
+++ b/src/Wetterhorn/Dsl/Input.hs
@@ -10,6 +10,8 @@ module Wetterhorn.Dsl.Input
filterEvent,
isPressEvent,
nextInputEventThat,
+ replayEvents,
+ isKeyEvent,
nextInputPressEvent,
continue,
nextInputEvent,
@@ -17,10 +19,12 @@ module Wetterhorn.Dsl.Input
)
where
-import Control.Monad (forever, void)
+import Control.Concurrent (forkIO, threadDelay)
+import Control.Monad (forever, join, void, (>=>))
import Control.Monad.Cont (MonadCont)
-import Control.Monad.RWS (MonadIO, MonadReader (ask), MonadState (get), MonadTrans (lift), RWST, execRWST, modify)
+import Control.Monad.RWS (MonadIO (liftIO), MonadReader (ask, local), MonadState (get), MonadTrans (lift), RWST, asks, execRWST, gets, modify)
import Control.Monad.Trans.Cont
+import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Maybe (fromMaybe)
import Data.Word (Word32)
import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent
@@ -35,15 +39,22 @@ data InputEvent
| InputKeyEvent KeyEvent.KeyEvent
-- | Context for the input.
-newtype InputContext = InputContext
+data InputContext = InputContext
{ -- | Top of the input routine. Used in "continue" statement.
inputTop :: InputM ()
}
+newtype InputState = InputState
+ { inputSource :: InputM InputEvent
+ }
+
-- | Input monad for handling all kinds of input.
-newtype InputM a = InputM (ContT () (RWST InputContext () () W) a)
+newtype InputM a = InputM (ContT () (RWST InputContext () InputState W) a)
deriving (Monad, Functor, Applicative, MonadCont, MonadIO)
+instance MonadFail InputM where
+ fail _ = continue
+
-- | Lifts a W action to an InputM action.
instance W.Wlike InputM where
liftW = InputM . lift . lift
@@ -74,14 +85,14 @@ forwardKey keyEvent = do
-- | Executes a function if the input event is a key event. If it is not a key
-- event, then nothing happens.
-whenKeyEvent :: InputEvent -> (KeyEvent.KeyEvent -> InputM ()) -> InputM ()
+whenKeyEvent :: (Monad m) => InputEvent -> (KeyEvent.KeyEvent -> m ()) -> m ()
whenKeyEvent (InputKeyEvent ke) = ($ ke)
whenKeyEvent _ = const (return ())
-- | Executes a function in the input event is a button event. If it is not a
-- button event, then nothing happens.
whenButtonEvent ::
- InputEvent -> (ButtonEvent.ButtonEvent -> InputM ()) -> InputM ()
+ (Monad m) => InputEvent -> (ButtonEvent.ButtonEvent -> m ()) -> m ()
whenButtonEvent (InputButtonEvent be) = ($ be)
whenButtonEvent _ = const (return ())
@@ -97,10 +108,29 @@ unwrap :: Maybe a -> InputM a
unwrap (Just val) = return val
unwrap Nothing = continue
+-- | Runs the series of events from the top as if they were input.
+replayEvents :: [InputEvent] -> InputM ()
+replayEvents events = do
+ ioref <- liftIO (newIORef events)
+
+ oldInput <- InputM $ gets inputSource
+
+ let newInput = InputM $ do
+ r <- liftIO (readIORef ioref)
+ case r of
+ [] -> do
+ modify $ \st -> st {inputSource = oldInput}
+ let (InputM action) = oldInput in action
+ (a : as) -> do
+ liftIO (writeIORef ioref as)
+ return a
+
+ InputM $ modify $ \st -> st {inputSource = newInput}
+
-- | Call in the reset handler with the InputM handler you wolud like to use.
useInputHandler :: InputM () -> W ()
useInputHandler (forever -> top@(InputM ctop)) = do
- void $ execRWST (runContT ctop return) (InputContext top) ()
+ void $ execRWST (runContT ctop return) (InputContext top) (InputState useSeatEvents)
-- | Returns the next input event that's either a kep press or a button press.
nextInputPressEvent :: InputM InputEvent
@@ -115,6 +145,10 @@ nextInputEventThat fn =
else forwardEvent ie >> nextInputEventThat fn
)
+isKeyEvent :: InputEvent -> Bool
+isKeyEvent (InputKeyEvent _) = True
+isKeyEvent _ = False
+
isPressEvent :: InputEvent -> Bool
isPressEvent (InputButtonEvent be)
| ButtonEvent.state be == ButtonEvent.ButtonPressed =
@@ -136,9 +170,12 @@ getModifierState = do
keyboard <- W.wio $ wlrSeatGetKeyboard seat
maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard)
--- | Gets the next input event.
nextInputEvent :: InputM InputEvent
-nextInputEvent =
+nextInputEvent = join $ InputM $ gets inputSource
+
+-- | Gets the next input event.
+useSeatEvents :: InputM InputEvent
+useSeatEvents =
InputM $
shiftT
( \thingToDo -> do
diff --git a/src/Wetterhorn/Keys/Macros.hs b/src/Wetterhorn/Keys/Macros.hs
index de546f0..73481b6 100644
--- a/src/Wetterhorn/Keys/Macros.hs
+++ b/src/Wetterhorn/Keys/Macros.hs
@@ -1,25 +1,24 @@
module Wetterhorn.Keys.Macros where
-import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.Default.Class
-import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
import Data.Word
import Foreign (Ptr)
-import Text.Printf
import Wetterhorn.Core.KeyEvent
-import Wetterhorn.Core.Keys
import Wetterhorn.Core.W
+import Wetterhorn.Dsl.Input
+import Wetterhorn.Dsl.Bind
import Wetterhorn.Foreign.WlRoots (WlrInputDevice)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+import Control.Monad (when)
data RecordedKey = RecordedKey Word32 KeyState Word32 Word32 Char
deriving (Read, Show)
data MacrosState = MacrosState
- { macros :: Map Char [RecordedKey],
- currentlyRecording :: Maybe Char
+ { macros :: Map String [RecordedKey],
+ currentlyRecording :: Maybe String
}
deriving (Read, Show)
@@ -28,8 +27,45 @@ instance Default MacrosState where
instance ExtensionClass MacrosState
-startMacroRecording :: (Wlike m) => Char -> m ()
-startMacroRecording ch =
+macroSupport :: (MatchEvent record, MatchEvent replay) => record -> replay -> InputEvent -> InputM ()
+macroSupport rec rep ev = do
+ when (isPressEvent ev) (bind ev rec macroStartStopKeybind)
+ recordMacroKey ev
+ when (isPressEvent ev) (bind ev rep macroReplayKeybind)
+
+-- | Provides a Vim-esque keybinding behavior for macro recording.
+--
+-- Designed to be used like:
+--
+-- bind ev (Mod1 .+ 'q') macroStartStopKeybind
+macroStartStopKeybind :: InputM ()
+macroStartStopKeybind = do
+ currentlyRecordingMacro
+ >>= ( \case
+ Just ch -> do
+ liftIO $ putStrLn $ "Done Recording: " ++ ch
+ stopMacroRecording
+ Nothing -> do
+ (InputKeyEvent (KeyEvent {codepoint = cp})) <- nextInputPressEvent
+ liftIO $ putStrLn $ "Recording: " ++ [cp]
+ startRecording [cp]
+ )
+
+-- | Provides a keybinding for replaying a macro.
+--
+-- Designed to be used like:
+--
+-- bind ev (weak $ Mod1 .+ '@') macroReplayKeybind
+macroReplayKeybind :: InputM ()
+macroReplayKeybind = do
+ ( InputKeyEvent
+ (KeyEvent {codepoint = cp, device = device})
+ ) <-
+ nextInputPressEvent
+ replayMacro device [cp]
+
+startRecording :: (Wlike m) => String -> m ()
+startRecording ch =
xmodify
( \m@MacrosState {macros = macros} ->
m
@@ -41,55 +77,23 @@ startMacroRecording ch =
stopMacroRecording :: (Wlike m) => m ()
stopMacroRecording = xmodify (\m -> m {currentlyRecording = Nothing})
-currentlyRecordingMacro :: (Wlike m) => m (Maybe Char)
+currentlyRecordingMacro :: (Wlike m) => m (Maybe String)
currentlyRecordingMacro = xgets currentlyRecording
-macroKeyBind :: KeysM ()
-macroKeyBind = do
- curRec <- currentlyRecordingMacro
- case curRec of
- Just ch -> do
- liftIO $ printf "End Recording %s\n" (show ch)
- stopMacroRecording
- Nothing -> do
- kp' <- nextKeyPress
- liftIO $ printf "Recording %s\n" (show $ codepoint kp')
- startMacroRecording (codepoint kp')
-
-replayMacroKeybind :: KeysM ()
-replayMacroKeybind =
- replayMacro' =<< nextKeyPress
-
-replayMacro' :: KeyEvent -> KeysM ()
-replayMacro' ke = do
- top <- getTop
- liftW $ replayMacro top (device ke) (codepoint ke)
-
-replayMacro :: KeysM () -> Ptr WlrInputDevice -> Char -> W ()
-replayMacro top inputDevice ch = do
- macro <- xgets $ (fromMaybe [] . Map.lookup ch) . macros
- case macro of
- [] -> return ()
- ks -> do
- ioref <- wio $ newIORef (reverse ks)
- useKeysWithContinuation
- ( \fn -> do
- ks' <- wio $ readIORef ioref
- case ks' of
- (k : ks'') -> do
- wio $ writeIORef ioref ks''
- fn (toKeyEvent k)
- _ -> return ()
- )
- top
+replayMacro :: Ptr WlrInputDevice -> String -> InputM ()
+replayMacro inputDevice s = do
+ m <- liftW (Map.lookup s <$> xgets macros)
+ mapM_ (replayEvents . map toInputEvent . reverse) m
where
- toKeyEvent (RecordedKey kc st mo sym cp) =
- KeyEvent 0 kc st mo sym cp inputDevice
+ toInputEvent :: RecordedKey -> InputEvent
+ toInputEvent (RecordedKey kc st mo sym cp) =
+ InputKeyEvent $ KeyEvent 0 kc st mo sym cp inputDevice
pushMacroKey :: (Wlike m) => KeyEvent -> m ()
pushMacroKey ke = do
cur <- xgets currentlyRecording
- whenJust cur $ \ch ->
+ whenJust cur $ \ch -> do
+ liftW $ wio $ putStrLn $ "-> " ++ show ke
let recordedKey = toRecordedKey ke
in xmodify $ \m@MacrosState {macros = macros} ->
m {macros = Map.insertWith (++) ch [recordedKey] macros}
@@ -99,10 +103,5 @@ pushMacroKey ke = do
toRecordedKey (KeyEvent _ c s m sym cp _) = RecordedKey c s m sym cp
-recordMacroContinuation :: (KeyEvent -> W ()) -> W ()
-recordMacroContinuation cont =
- putKeyHandler
- ( \ke -> do
- pushMacroKey ke
- cont ke
- )
+recordMacroKey :: InputEvent -> InputM ()
+recordMacroKey ev = whenKeyEvent ev pushMacroKey
generated by cgit (git 2.34.1) at 2026-01-02 19:49:38 +0000