diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Config.hs | 20 | ||||
| -rw-r--r-- | src/Wetterhorn/Core/Keys.hs | 61 |
2 files changed, 65 insertions, 16 deletions
diff --git a/src/Config.hs b/src/Config.hs index 9d090d6..759e3b8 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -1,5 +1,9 @@ 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.Keys import Wetterhorn.Core.W import Wetterhorn.Layout.Full @@ -20,6 +24,22 @@ config = 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 = wio . print }, diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs index c8f8aeb..4ed7a77 100644 --- a/src/Wetterhorn/Core/Keys.hs +++ b/src/Wetterhorn/Core/Keys.hs @@ -4,6 +4,7 @@ module Wetterhorn.Core.Keys KeysM, bind, subbind, + subbind_, (.+), Modifier (..), keys, @@ -11,6 +12,9 @@ module Wetterhorn.Core.Keys weak, continue, WeakKeyMatcher, + nextKeyEvent, + nextKeyPress, + keyEvents, ) where @@ -72,6 +76,7 @@ newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a)) data KeysMR a = NextKey (KeysM a) | Lift a | Continue +-- | Convert a KeyM operation to a KeyEvent handler. keys :: KeysM a -> KeyEvent -> W () keys keysM = fix $ \top ke -> keys' top keysM ke where @@ -81,28 +86,32 @@ keys keysM = fix $ \top ke -> keys' top keysM ke NextKey keysM' -> putKeyHandler (keys' top keysM') Lift _ -> return () _ -> putKeyHandler top - -putKeyHandler :: (KeyEvent -> W a) -> W () -putKeyHandler handler = do - s@State {currentHooks = hooks} <- get - put - s - { currentHooks = - hooks - { keyHook = void <$> handler - } - } - -nextKey :: KeysM KeyEvent -nextKey = KeysM (\_ _ -> return (NextKey (KeysM (\_ -> return . Lift)))) - + putKeyHandler handler = do + s@State {currentHooks = hooks} <- get + put + s + { currentHooks = + hooks + { keyHook = void <$> handler + } + } + +-- | 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 <- nextKey + k <- nextKeyEvent if KeyEvent.state k /= KeyPressed then forwardEvent >> 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 @@ -141,6 +150,11 @@ 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. +-- + data KeyMatcher = KeyMatcher Word32 Char deriving (Show) @@ -148,6 +162,7 @@ data KeyMatcher = KeyMatcher Word32 Char -- the exact ones given. newtype WeakKeyMatcher = WeakKeyMatcher KeyMatcher +-- | Converts a KeyMatcher to a weak key matcher. weak :: KeyMatcher -> WeakKeyMatcher weak = WeakKeyMatcher @@ -172,6 +187,12 @@ infixr 9 .+ class MatchKey m where matchKey :: m -> KeyEvent -> Bool +instance MatchKey (KeyEvent -> Bool) where + matchKey = ($) + +instance MatchKey Bool where + matchKey = const + instance MatchKey Char where matchKey ch ev = ch == KeyEvent.codepoint ev @@ -193,6 +214,14 @@ subbind m act = do act continue +-- | 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 + bind :: (MatchKey m) => m -> W () -> KeysM () bind m act = do ev <- ask |