diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Config.hs | 27 | ||||
| -rw-r--r-- | src/Wetterhorn/Core/Keys.hs | 251 | ||||
| -rw-r--r-- | src/Wetterhorn/Core/W.hs | 111 | ||||
| -rw-r--r-- | src/Wetterhorn/Foreign/Export.hs | 82 |
4 files changed, 404 insertions, 67 deletions
diff --git a/src/Config.hs b/src/Config.hs index e49a869..87a0277 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -1,14 +1,23 @@ -module Config where +module Config (config) where +import Wetterhorn.Core.Keys import Wetterhorn.Core.W import Wetterhorn.Layout.Full -import Wetterhorn.Layout.Combine -config = defaultConfig { - keyHook = wio . print, - surfaceHook = wio . print, - layout = WindowLayout Full -} +config :: Config WindowLayout +config = + defaultConfig + { hooks = + defaultHooks + { keyHook = ofKeys testKeys, + -- runKeybinds $ do + -- bind (Mod1 .+ 'r') (shellExec "wofi --show run") --- wetterhorn :: IO Wetterhorn --- wetterhorn = initWetterhorn defaultConfig + -- subbind (Mod1 .+ 'g') $ do + -- bind 't' $ shellExec "alacritty" + + -- bind (Mod1 .+ 'Q') requestHotReload, + surfaceHook = wio . print + }, + layout = WindowLayout Full + } diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs new file mode 100644 index 0000000..d08a49f --- /dev/null +++ b/src/Wetterhorn/Core/Keys.hs @@ -0,0 +1,251 @@ +module Wetterhorn.Core.Keys where + +import Control.Monad.Reader (MonadReader (ask), MonadTrans (lift), ReaderT (runReaderT), asks, void, when) +import Control.Monad.State (MonadState (get, put), gets) +import Data.Bits +import Data.Kind +import Data.Word +import Wetterhorn.Core.KeyEvent +import qualified Wetterhorn.Core.KeyEvent as KeyEvent +import Wetterhorn.Core.W +import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard) + +-- | Passes a key event through the current seat. +passThroughKey :: KeyEvent -> W () +passThroughKey keyEvent = do + seatPtr <- getSeat + wio $ do + wlrSeatSetKeyboard + seatPtr + (device keyEvent) + + wlrSeatKeyboardNotifyKey + seatPtr + (timeMs keyEvent) + (keycode keyEvent) + ( case state keyEvent of + KeyReleased -> 0 + _ -> 1 + ) + +data Binding = Skip | Nevermind | JustAction (W ()) + +newtype Keybinds a = Keybinds (ReaderT KeyEvent (Either (Maybe (W ()))) a) + deriving (Functor, Applicative, Monad, MonadReader KeyEvent) + +runKeybinds :: Keybinds a -> KeyEvent -> W () +runKeybinds (Keybinds kb) ke = + case runReaderT kb ke of + Left (Just action) -> action + _ -> do + resetKeys + passThroughKey ke + +resetKeys :: W () +resetKeys = do + Config {hooks = Hooks {keyHook = originalKeyHook}} <- ask + s@State {currentHooks = hooks} <- get + put s {currentHooks = hooks {keyHook = originalKeyHook}} + +-- subbind :: Keybinds a -> W () +-- subbind kb = do +-- s@State {currentHooks = hooks} <- get +-- put s {currentHooks = hooks {keyHook = runKeybinds kb}} + +data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5 + +modifierToMask :: Modifier -> Word32 +modifierToMask m = + 1 + `shiftL` case m of + Shift -> 0 + Lock -> 1 + Control -> 2 + Mod1 -> 3 + Mod2 -> 4 + Mod3 -> 5 + Mod4 -> 6 + Mod5 -> 7 + +-- class MatchesKeyEvent a where +-- matchesKeyEvent :: a -> KeyEvent -> Bool +-- +-- instance MatchesKeyEvent Modifier where +-- matchesKeyEvent m keyEvent = +-- (modifiers keyEvent .&. modifierToMask m) /= 0 +-- +-- instance MatchesKeyEvent Char where +-- matchesKeyEvent c e = c == codepoint e +-- +-- newtype Match = Match (KeyEvent -> Bool) +-- +-- instance MatchesKeyEvent Match where +-- matchesKeyEvent (Match f) = f +-- +-- (.+) :: (MatchesKeyEvent m1, MatchesKeyEvent m2) => m1 -> m2 -> Match +-- (.+) match1 match2 = Match $ \ke -> matchesKeyEvent match1 ke && matchesKeyEvent match2 ke +-- +-- bind :: (MatchesKeyEvent m) => m -> W () -> Keybinds () +-- bind condition action = do +-- ke <- ask +-- when (state ke == KeyPressed && matchesKeyEvent condition ke) $ +-- Keybinds $ +-- lift (Left $ Just (action >> resetKeys)) +-- when (state ke == KeyReleased && matchesKeyEvent condition ke) (return ()) +-- +-- subbind :: (MatchesKeyEvent m) => m -> Keybinds () -> Keybinds () +-- subbind condition subkeys = do +-- ke <- ask +-- when (state ke == KeyPressed && matchesKeyEvent condition ke) $ +-- Keybinds $ +-- lift +-- ( Left $ +-- Just $ +-- nextKey (runKeybinds subkeys) +-- ) +-- when (state ke == KeyReleased && matchesKeyEvent condition ke) (return ()) +-- +-- nevermind :: Keybinds () +-- nevermind = Keybinds $ lift (Left Nothing) + +testKeys :: KeysM () +testKeys = do + k1 <- nextKeyPress + + when (KeyEvent.codepoint k1 == 'R') $ + liftW requestHotReload + + liftW $ wio $ putStrLn $ "1 " ++ show k1 + ck <- currentKey + liftW $ wio $ putStrLn $ "1' " ++ show ck + k2 <- nextKeyPress + liftW $ wio $ putStrLn $ "2 " ++ show k2 + testKeys + +newtype KeysM a = KeysM (KeyEvent -> W (Either (KeysM a) a)) + +ofKeys :: KeysM a -> KeyEvent -> W () +ofKeys (KeysM fn) ke = do + e <- fn ke + case e of + Right _ -> return () + Left next -> runKeysM next + +runKeysM :: KeysM a -> W () +runKeysM k = do + s@State {currentHooks = hooks} <- get + put + s + { currentHooks = + hooks + { keyHook = ofKeys k + } + } + +liftW :: W a -> KeysM a +liftW act = KeysM (\_ -> Right <$> act) + +keysJoin :: KeysM (KeysM a) -> KeysM a +keysJoin (KeysM f) = KeysM $ \keyEvent -> do + e <- f keyEvent + case e of + Right (KeysM f') -> f' keyEvent + Left sub -> return $ Left $ keysJoin sub + +nextKey :: KeysM KeyEvent +nextKey = KeysM (\_ -> return (Left (KeysM (return . Right)))) + +nextKeyPress :: KeysM KeyEvent +nextKeyPress = do + k <- nextKey + if KeyEvent.state k /= KeyPressed + then nextKeyPress + else return k + +currentKey :: KeysM KeyEvent +currentKey = KeysM (return . Right) + +instance Functor KeysM where + fmap f (KeysM fn) = KeysM $ \keyEvent -> do + e <- fn keyEvent + return $ + case e of + Left ma -> Left $ fmap f ma + Right a -> Right $ f a + +instance Applicative KeysM where + pure a = KeysM (\_ -> return (Right a)) + (<*>) mfn ma = do + fn <- mfn + fn <$> ma + +instance Monad KeysM where + return = pure + a >>= fmb = keysJoin (fmap fmb a) + +-- keysJoin (KeysM fn) = KeysM $ \ke -> do +-- nextKeys <- fn ke +-- case nextKeys of +-- NextKey -> NextKey +-- (KeysM fn') -> fn' ke + +-- data KeysResult a = DoDefer (KeyEvent -> W (KeysM a)) | DoIdent a +-- data KeysM a = KeysM (KeyEvent -> W (KeysResult a)) +-- +-- keysJoin :: KeysM (KeysM a) -> KeysM a +-- keysJoin (KeysM fn) = KeysM $ \ke -> do +-- kr <- fn ke +-- case kr of +-- DoDefer nextKeyFn -> + +-- data KeysM a where +-- Ident :: W a -> KeysM a +-- NextKey :: (KeyEvent -> W (KeysM a)) -> KeysM a +-- +-- runKeysM :: KeysM a -> KeyEvent -> W () +-- runKeysM (Ident ma) _ = void ma +-- runKeysM (NextKey fn) keyEvent = do +-- val <- fn keyEvent +-- s@State {currentHooks = hooks} <- get +-- put s {currentHooks = hooks {keyHook = runKeysM val}} +-- +-- instance Functor KeysM where +-- fmap f (Ident wa) = Ident $ fmap f wa +-- fmap f (NextKey fn) = NextKey $ fmap (fmap f) . fn +-- +-- instance Applicative KeysM where +-- pure = Ident . pure +-- +-- +-- joinKeysM :: KeysM (KeysM a) -> KeysM a +-- joinKeysM (Ident mKeysMA) = +-- Ident $ do +-- keysMa <- mKeysMA +-- case keysMa of +-- Ident ma -> ma +-- NextKey -> +-- +-- instance Monad KeysM where +-- return = pure + +-- (Ident ma) >>= fn = + +-- nextKey :: (KeyEvent -> W ()) -> W () +-- nextKey evf = do +-- s@State {currentHooks = hooks} <- get +-- put s {currentHooks = hooks {keyHook = evf}} + +-- +-- data KeyM a where +-- Ident :: W a -> KeyM a +-- Deferred :: KeyM KeyEvent +-- Cont :: (KeyEvent -> KeyM b) -> KeyM b +-- +-- instance Functor KeyM where +-- fmap fn k = case k of +-- Ident wa -> Ident (fn <$> wa) +-- Deferred -> Cont (pure . fn) +-- Cont f -> Cont (fmap fn . f) + +-- bind :: KeyM KeyEvent -> (KeyEvent -> KeyM b) -> KeyM b +-- bind = undefined diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs index 11bac05..b2b044e 100644 --- a/src/Wetterhorn/Core/W.hs +++ b/src/Wetterhorn/Core/W.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DuplicateRecordFields #-} + module Wetterhorn.Core.W where import Control.Arrow (Arrow (first)) -import Control.Monad.RWS (MonadIO (liftIO), MonadReader, MonadState) +import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState) import Control.Monad.Reader (ReaderT (runReaderT)) import Control.Monad.State (StateT (runStateT)) import Control.Monad.Trans.Maybe @@ -12,8 +14,9 @@ import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr) import Text.Read import Wetterhorn.Core.KeyEvent import Wetterhorn.Core.SurfaceEvent -import Wetterhorn.Foreign -import Wetterhorn.Foreign.ForeignInterface (ForeignInterface) +import Wetterhorn.Foreign.ForeignInterface (ForeignInterface (ForeignInterface)) +import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface +import Wetterhorn.Foreign.WlRoots (WlrSeat) import Wetterhorn.StackSet hiding (layout) data RationalRect = RationalRect Rational Rational Rational Rational @@ -87,7 +90,7 @@ handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l readWindowLayout :: WindowLayout -> String -> WindowLayout readWindowLayout (WindowLayout l) s | (Just x) <- readLayout s = - WindowLayout (asTypeOf x l) + WindowLayout (asTypeOf x l) readWindowLayout l _ = l serializeWindowLayout :: WindowLayout -> String @@ -118,45 +121,105 @@ data Context = Context ctxConfig :: Config WindowLayout } +defaultHooks :: Hooks +defaultHooks = + Hooks + { keyHook = \_ -> return (), + surfaceHook = \_ -> return () + } + defaultConfig :: Config () defaultConfig = Config - { keyHook = \_ -> return (), - surfaceHook = \_ -> return (), + { hooks = defaultHooks, layout = () } -data Config l = Config +data Hooks = Hooks { keyHook :: KeyEvent -> W (), - surfaceHook :: SurfaceEvent -> W (), - layout :: l + surfaceHook :: SurfaceEvent -> W () } -data State = State - { mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window, - allWindows :: Set Window +data Config l = Config + { layout :: l, + hooks :: Hooks } -initColdState :: WindowLayout -> IO State -initColdState l = return $ State (StackSet (Screen () () (Workspace "0" l (Stack [] []))) [] []) mempty +data State = State + { -- The datastructure containing the state of the windows. + mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window, + -- | All the windows wetterhorn knows about, even if they are not mapped. + allWindows :: Set Window, + -- | Current set of hooks. The initial hooks are provided by the + -- configuration, but the hooks can change during operation. This is how key + -- sequences can be mapped. + currentHooks :: Hooks + } +-- | Initializes a "cold" state from a configuration. A cold state is the +-- initial state on startup. It is constrasted with a "hot" state, which is a +-- persisted state after a hot-reload. +initColdState :: Config WindowLayout -> IO State +initColdState Config {layout = layout, hooks = hooks} = + return $ + State + ( StackSet (Screen () () (Workspace "0" layout (Stack [] []))) [] [] + ) + mempty + hooks + +-- | Marshals the serializable parts of the state to a string. This happens +-- during a hot-reload where some state must be saved to persist across hot +-- reloads. marshalState :: State -> String -marshalState (State mapped allWindows) = - show - ( mapLayout serializeWindowLayout mapped, - allWindows - ) - -demarshalState :: WindowLayout -> String -> State -demarshalState witness str = State mapped allWindows +marshalState + ( State + { mapped = mapped, + allWindows = allWindows + } + ) = + show + ( mapLayout serializeWindowLayout mapped, + allWindows + ) + +-- | Demarshals the string from "marshalState" into a state. Uses the provided +-- config to fill out non-persistent parts of the state. +demarshalState :: Config WindowLayout -> String -> State +demarshalState Config {hooks = hooks, layout = layout} str = + State mapped allWindows hooks where - (mapLayout (readWindowLayout witness) -> mapped, allWindows) = read str + (mapLayout (readWindowLayout layout) -> mapped, allWindows) = read str +-- | This is _the_ main monad used for Wetterhorn operations. Contains +-- everything required to operate. Contains the state, configuration and +-- interface to foreign code. newtype W a = W (ReaderT Context (StateT State IO) a) - deriving (Functor, Applicative, Monad, MonadState State, MonadReader Context, MonadIO) + deriving (Functor, Applicative, Monad, MonadState State, MonadIO) + +-- | Let Config be the thing W is a reader for. There is already a way to get +-- the foreign interface in the context. +instance MonadReader (Config WindowLayout) W where + local fn (W r) = W $ local (\(Context fi conf) -> Context fi (fn conf)) r + ask = W $ ctxConfig <$> ask runW :: W a -> (Context, State) -> IO (a, State) runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st +foreignInterface :: W ForeignInterface +foreignInterface = W $ ctxForeignInterface <$> ask + +getSeat :: W (Ptr WlrSeat) +getSeat = (wio . ForeignInterface.getSeat) =<< foreignInterface + +requestHotReload :: W () +requestHotReload = (wio . ForeignInterface.requestHotReload) =<< foreignInterface + +requestExit :: Int -> W () +requestExit ec = (wio . flip ForeignInterface.requestExit ec) =<< foreignInterface + +shellExec :: String -> W () +shellExec = wio . ForeignInterface.doShellExec + wio :: IO a -> W a wio = liftIO diff --git a/src/Wetterhorn/Foreign/Export.hs b/src/Wetterhorn/Foreign/Export.hs index 0d71a4e..e35ed71 100644 --- a/src/Wetterhorn/Foreign/Export.hs +++ b/src/Wetterhorn/Foreign/Export.hs @@ -3,6 +3,7 @@ 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 @@ -24,26 +25,31 @@ import qualified Wetterhorn.Core.W as W import Wetterhorn.Foreign.ForeignInterface import Wetterhorn.Foreign.WlRoots -runForeign :: (forall l. W.Config l -> W ()) -> Wetterhorn -> IO Wetterhorn +type Wetter = (W.Config W.WindowLayout, W.State) + +toWetter :: (W.Context, W.State) -> (W.Config W.WindowLayout, W.State) +toWetter = first W.ctxConfig + +runForeign :: (Wetter -> W ()) -> Wetterhorn -> IO Wetterhorn runForeign fn stblptr = do - (ctx, st) <- deRefStablePtr stblptr + w@(ctx, st) <- deRefStablePtr stblptr freeStablePtr stblptr - (_, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st) + (_, state') <- W.runW (fn $ toWetter w) (ctx, st) newStablePtr (ctx, state') -runForeignWithReturn :: (Storable a) => (forall l. W.Config l -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn +runForeignWithReturn :: (Storable a) => (Wetter -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn runForeignWithReturn fn ptr stableptr = do - (ctx, st) <- deRefStablePtr stableptr + w@(ctx, st) <- deRefStablePtr stableptr freeStablePtr stableptr - (val, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st) + (val, state') <- W.runW (fn $ toWetter w) (ctx, st) poke ptr val newStablePtr (ctx, state') -runForeignWithReturn2 :: (Storable a, Storable b) => (forall l. W.Config l -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn +runForeignWithReturn2 :: (Storable a, Storable b) => (Wetter -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn runForeignWithReturn2 fn ptrA ptrB stableptr = do - (ctx, st) <- deRefStablePtr stableptr + w@(ctx, st) <- deRefStablePtr stableptr freeStablePtr stableptr - ((vA, vB), state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st) + ((vA, vB), state') <- W.runW (fn $ toWetter w) (ctx, st) poke ptrA vA poke ptrB vB newStablePtr (ctx, state') @@ -61,7 +67,7 @@ pluginHotStart chars len = do foreignInterface <- getForeignInterface newStablePtr ( W.Context foreignInterface config, - W.demarshalState (W.layout config) (CH.unpack bs) + W.demarshalState config (CH.unpack bs) ) -- | This function is called when a "coldstart" request is receieved. It just @@ -73,7 +79,7 @@ foreign export ccall "plugin_cold_start" pluginColdStart :: IO Wetterhorn pluginColdStart = do foreignInterface <- getForeignInterface - state <- W.initColdState (W.layout config) + state <- W.initColdState config newStablePtr (W.Context foreignInterface config, state) -- | Marshals the opaque state to a C-style byte array and size pointer. @@ -111,24 +117,27 @@ pluginHandleKeybinding :: Wetterhorn -> IO Wetterhorn pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp = - runForeignWithReturn $ \config -> do - event <- W.wio $ - runForeignDemarshal eventPtr $ do - tMs <- demarshal - kc <- demarshal - _ <- (demarshal :: ForeignDemarshal Word32) - keyState <- demarshal - return $ - KeyEvent - tMs - kc - (if keyState == (0 :: Word8) then KeyReleased else KeyPressed) - mods - sym - (toEnum $ fromIntegral cp) - inputDevicePtr - W.keyHook config event - return 1 + runForeignWithReturn $ + \( _, + W.State {W.currentHooks = W.Hooks {keyHook = keyHook}} + ) -> do + event <- W.wio $ + runForeignDemarshal eventPtr $ do + tMs <- demarshal + kc <- demarshal + _ <- (demarshal :: ForeignDemarshal Word32) + keyState <- demarshal + return $ + KeyEvent + tMs + kc + (if keyState == (0 :: Word8) then KeyReleased else KeyPressed) + mods + sym + (toEnum $ fromIntegral cp) + inputDevicePtr + keyHook event + return 1 -- | Function exported to the harness to handle the mapping/unmapping/deletion -- of an XDG surface. @@ -139,10 +148,9 @@ foreign export ccall "plugin_handle_surface" pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn pluginHandleSurface p t = runForeign - ( \c -> - W.surfaceHook - c - $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p) + ( \(_, W.State {currentHooks = W.Hooks {surfaceHook = surfaceHook}}) -> + surfaceHook $ + SurfaceEvent (toEnum $ fromIntegral t) (toSurface p) ) -- | Function exported to the harness to handle the mapping/unmapping/deletion @@ -153,4 +161,10 @@ foreign export ccall "plugin_handle_xwayland_surface" pluginHandleXWaylandSurface :: Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn pluginHandleXWaylandSurface p t = - runForeign (\c -> W.surfaceHook c $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)) + runForeign + ( \( _, + W.State + { currentHooks = W.Hooks {surfaceHook = surfaceHook} + } + ) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p) + ) |