diff options
| -rw-r--r-- | src/Config.hs | 65 | ||||
| -rw-r--r-- | src/Wetterhorn/Core/Keys.hs | 190 | ||||
| -rw-r--r-- | src/Wetterhorn/Core/W.hs | 12 | ||||
| -rw-r--r-- | src/Wetterhorn/Foreign/Export.hs | 19 |
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" |