From cb657fa9fc8124bdab42eb148e9b4a8ac69fc05e Mon Sep 17 00:00:00 2001 From: Josh Rahm Date: Thu, 1 Jan 2026 20:29:02 -0700 Subject: [refactor] Wetterhorn -> Montis --- plug/src/Config.hs | 16 +- plug/src/Montis/Constraints.hs | 13 + plug/src/Montis/Core.hs | 152 ++++++++++ plug/src/Montis/Core/ButtonEvent.hs | 15 + plug/src/Montis/Core/KeyEvent.hs | 22 ++ plug/src/Montis/Core/Keys.hs | 239 +++++++++++++++ plug/src/Montis/Core/SurfaceEvent.hs | 16 + plug/src/Montis/Core/W.hs | 379 ++++++++++++++++++++++++ plug/src/Montis/Dsl/Bind.hs | 128 ++++++++ plug/src/Montis/Dsl/Buttons.hsc | 229 ++++++++++++++ plug/src/Montis/Dsl/Input.hs | 286 ++++++++++++++++++ plug/src/Montis/Foreign.hs | 18 ++ plug/src/Montis/Foreign/Export.hs | 208 +++++++++++++ plug/src/Montis/Foreign/ForeignInterface.hs | 81 +++++ plug/src/Montis/Foreign/WlRoots.hs | 67 +++++ plug/src/Montis/Keys/Macros.hs | 145 +++++++++ plug/src/Montis/Keys/MagicModifierKey.hs | 50 ++++ plug/src/Montis/Layout/Combine.hs | 48 +++ plug/src/Montis/Layout/Full.hs | 23 ++ plug/src/Montis/StackSet.hs | 210 +++++++++++++ plug/src/Wetterhorn/Constraints.hs | 13 - plug/src/Wetterhorn/Core.hs | 152 ---------- plug/src/Wetterhorn/Core/ButtonEvent.hs | 15 - plug/src/Wetterhorn/Core/KeyEvent.hs | 22 -- plug/src/Wetterhorn/Core/Keys.hs | 239 --------------- plug/src/Wetterhorn/Core/SurfaceEvent.hs | 16 - plug/src/Wetterhorn/Core/W.hs | 379 ------------------------ plug/src/Wetterhorn/Dsl/Bind.hs | 128 -------- plug/src/Wetterhorn/Dsl/Buttons.hsc | 229 -------------- plug/src/Wetterhorn/Dsl/Input.hs | 286 ------------------ plug/src/Wetterhorn/Foreign.hs | 18 -- plug/src/Wetterhorn/Foreign/Export.hs | 208 ------------- plug/src/Wetterhorn/Foreign/ForeignInterface.hs | 81 ----- plug/src/Wetterhorn/Foreign/WlRoots.hs | 67 ----- plug/src/Wetterhorn/Keys/Macros.hs | 145 --------- plug/src/Wetterhorn/Keys/MagicModifierKey.hs | 50 ---- plug/src/Wetterhorn/Layout/Combine.hs | 48 --- plug/src/Wetterhorn/Layout/Full.hs | 23 -- plug/src/Wetterhorn/StackSet.hs | 210 ------------- plug/src/harness_adapter.c | 6 +- 40 files changed, 2340 insertions(+), 2340 deletions(-) create mode 100644 plug/src/Montis/Constraints.hs create mode 100644 plug/src/Montis/Core.hs create mode 100644 plug/src/Montis/Core/ButtonEvent.hs create mode 100644 plug/src/Montis/Core/KeyEvent.hs create mode 100644 plug/src/Montis/Core/Keys.hs create mode 100644 plug/src/Montis/Core/SurfaceEvent.hs create mode 100644 plug/src/Montis/Core/W.hs create mode 100644 plug/src/Montis/Dsl/Bind.hs create mode 100644 plug/src/Montis/Dsl/Buttons.hsc create mode 100644 plug/src/Montis/Dsl/Input.hs create mode 100644 plug/src/Montis/Foreign.hs create mode 100644 plug/src/Montis/Foreign/Export.hs create mode 100644 plug/src/Montis/Foreign/ForeignInterface.hs create mode 100644 plug/src/Montis/Foreign/WlRoots.hs create mode 100644 plug/src/Montis/Keys/Macros.hs create mode 100644 plug/src/Montis/Keys/MagicModifierKey.hs create mode 100644 plug/src/Montis/Layout/Combine.hs create mode 100644 plug/src/Montis/Layout/Full.hs create mode 100644 plug/src/Montis/StackSet.hs delete mode 100644 plug/src/Wetterhorn/Constraints.hs delete mode 100644 plug/src/Wetterhorn/Core.hs delete mode 100644 plug/src/Wetterhorn/Core/ButtonEvent.hs delete mode 100644 plug/src/Wetterhorn/Core/KeyEvent.hs delete mode 100644 plug/src/Wetterhorn/Core/Keys.hs delete mode 100644 plug/src/Wetterhorn/Core/SurfaceEvent.hs delete mode 100644 plug/src/Wetterhorn/Core/W.hs delete mode 100644 plug/src/Wetterhorn/Dsl/Bind.hs delete mode 100644 plug/src/Wetterhorn/Dsl/Buttons.hsc delete mode 100644 plug/src/Wetterhorn/Dsl/Input.hs delete mode 100644 plug/src/Wetterhorn/Foreign.hs delete mode 100644 plug/src/Wetterhorn/Foreign/Export.hs delete mode 100644 plug/src/Wetterhorn/Foreign/ForeignInterface.hs delete mode 100644 plug/src/Wetterhorn/Foreign/WlRoots.hs delete mode 100644 plug/src/Wetterhorn/Keys/Macros.hs delete mode 100644 plug/src/Wetterhorn/Keys/MagicModifierKey.hs delete mode 100644 plug/src/Wetterhorn/Layout/Combine.hs delete mode 100644 plug/src/Wetterhorn/Layout/Full.hs delete mode 100644 plug/src/Wetterhorn/StackSet.hs diff --git a/plug/src/Config.hs b/plug/src/Config.hs index e76e6ea..0c067c4 100644 --- a/plug/src/Config.hs +++ b/plug/src/Config.hs @@ -3,14 +3,14 @@ module Config (config) where import Control.Monad (unless) import Data.Bits import Data.Data (Proxy (Proxy)) -import Wetterhorn.Core.ButtonEvent as ButtonEvent -import Wetterhorn.Core.KeyEvent as KeyEvent -import Wetterhorn.Core.W -import Wetterhorn.Dsl.Bind -import Wetterhorn.Dsl.Input -import Wetterhorn.Keys.Macros -import Wetterhorn.Keys.MagicModifierKey -import Wetterhorn.Layout.Full +import Montis.Core.ButtonEvent as ButtonEvent +import Montis.Core.KeyEvent as KeyEvent +import Montis.Core.W +import Montis.Dsl.Bind +import Montis.Dsl.Input +import Montis.Keys.Macros +import Montis.Keys.MagicModifierKey +import Montis.Layout.Full config :: Config WindowLayout config = diff --git a/plug/src/Montis/Constraints.hs b/plug/src/Montis/Constraints.hs new file mode 100644 index 0000000..f1f15ff --- /dev/null +++ b/plug/src/Montis/Constraints.hs @@ -0,0 +1,13 @@ +-- | Contains useful constraints and constraint combinators for type-level +-- metaprogramming. +module Montis.Constraints where + +-- | A null constraint. All types implement this. +class Unconstrained a + +instance Unconstrained a + +-- | Combines multiple constraints by 'And'ing them together. +class (c1 a, c2 a) => (&&&&) c1 c2 a + +instance (c1 a, c2 a) => (&&&&) c1 c2 a diff --git a/plug/src/Montis/Core.hs b/plug/src/Montis/Core.hs new file mode 100644 index 0000000..df024e2 --- /dev/null +++ b/plug/src/Montis/Core.hs @@ -0,0 +1,152 @@ +{-# HLINT ignore "Use camelCase" #-} + +module Montis.Core +-- ( WState (..), +-- WConfig (..), +-- SurfaceState (..), +-- W, +-- getWConfig, +-- getWState, +-- runW, +-- Montis, +-- initMontis, +-- wio, +-- incrementState, +-- readWState, +-- defaultConfig, +-- requestHotReload, +-- ctxConfig, +-- KeyEvent (..), +-- KeyState (..), +-- ) +where + +-- import Control.Arrow (first) +-- import Control.Exception +-- import Data.ByteString (ByteString) +-- import Data.Char (ord) +-- import Data.Map (Map) +-- import Foreign (Ptr, StablePtr, Word32, newStablePtr) +-- import Text.Printf +-- import Montis.Foreign.ForeignInterface (ForeignInterface) +-- import Montis.Foreign.WlRoots +-- import qualified Data.ByteString.Char8 as CH +-- import qualified Data.Map as Map +-- import qualified Montis.Foreign.ForeignInterface as ForeignInterface +-- +-- data WContext = WContext +-- { ctxForeignInterface :: ForeignInterface, +-- ctxConfig :: WConfig +-- } +-- +-- -- This is the OpaqueState passed to the harness. +-- type Montis = StablePtr (WContext, WState) +-- +-- requestHotReload :: W () +-- requestHotReload = do +-- fi <- ctxForeignInterface <$> getWContext +-- wio $ ForeignInterface.requestHotReload fi +-- +-- requestLog :: String -> W () +-- requestLog str = do +-- fi <- ctxForeignInterface <$> getWContext +-- wio $ ForeignInterface.requestLog fi str +-- +-- requestExit :: Int -> W () +-- requestExit ec = do +-- fi <- ctxForeignInterface <$> getWContext +-- wio $ ForeignInterface.requestExit fi ec +-- +-- initMontis :: WConfig -> IO Montis +-- initMontis conf = do +-- foreignInterface <- ForeignInterface.getForeignInterface +-- newStablePtr (WContext foreignInterface conf, WState "this is a string" 0) +-- +-- defaultBindings :: Map (KeyState, Word32, Word32) (W ()) +-- defaultBindings = +-- Map.fromList +-- [ ((KeyPressed, 0x9, sym 'Q'), requestHotReload), +-- ((KeyPressed, 0x8, sym 'r'), wio $ ForeignInterface.doShellExec "wofi --show run"), +-- ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"), +-- ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"), +-- ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"), +-- ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"), +-- ( (KeyPressed, 0x8, sym 'p'), +-- wio $ do +-- putStrLn "Maps:" +-- putStrLn =<< readFile "/proc/self/maps" +-- ), +-- ((KeyPressed, 0x8, sym 'q'), requestExit 0) +-- ] +-- where +-- sym = fromIntegral . ord +-- +-- defaultConfig :: WConfig +-- defaultConfig = +-- WConfig +-- { keybindingHandler = \keyEvent -> do +-- seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext +-- +-- maybe +-- ( wio $ do +-- wlrSeatSetKeyboard seatPtr (device keyEvent) +-- wlrSeatKeyboardNotifyKey +-- seatPtr +-- (timeMs keyEvent) +-- (keycode keyEvent) +-- ( case state keyEvent of +-- KeyReleased -> 0 +-- _ -> 1 +-- ) +-- +-- return True +-- ) +-- (fmap (const True)) +-- $ Map.lookup +-- (state keyEvent, modifiers keyEvent, keysym keyEvent) +-- defaultBindings, +-- surfaceHandler = \state surface -> wio (printf "Surface %s is %s\n" (show surface) (show state)) +-- } +-- +-- readWState :: ByteString -> IO WState +-- readWState bs = +-- catch +-- (return $ read (CH.unpack bs)) +-- ( \e -> +-- let _ = (e :: SomeException) in return (WState "" 0) +-- ) +-- +-- newtype W a = W ((WContext, WState) -> IO (a, WState)) +-- +-- instance Functor W where +-- fmap mfn (W fn) = W $ fmap (first mfn) <$> fn +-- +-- instance Applicative W where +-- pure a = W $ \(_, s) -> return (a, s) +-- mfn <*> ma = do +-- fn <- mfn +-- fn <$> ma +-- +-- instance Monad W where +-- (W fntoa) >>= fnmb = W $ \(config, state) -> do +-- (a, state') <- fntoa (config, state) +-- let W fntob = fnmb a +-- fntob (config, state') +-- +-- getWContext :: W WContext +-- getWContext = W pure +-- +-- getWConfig :: W WConfig +-- getWConfig = ctxConfig <$> getWContext +-- +-- getWState :: W WState +-- getWState = W $ \(_, s) -> pure (s, s) +-- +-- runW :: W a -> (WContext, WState) -> IO (a, WState) +-- runW (W fn) = fn +-- +-- incrementState :: W Int +-- incrementState = W $ \(_, WState s i) -> return (i, WState s (i + 1)) +-- +-- wio :: IO a -> W a +-- wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b) diff --git a/plug/src/Montis/Core/ButtonEvent.hs b/plug/src/Montis/Core/ButtonEvent.hs new file mode 100644 index 0000000..f9c5c48 --- /dev/null +++ b/plug/src/Montis/Core/ButtonEvent.hs @@ -0,0 +1,15 @@ +module Montis.Core.ButtonEvent where + +import Montis.Foreign.WlRoots +import Data.Word (Word32) +import Foreign (Ptr) + +data ButtonState = ButtonReleased | ButtonPressed deriving (Show, Read, Eq, Enum, Ord) + +data ButtonEvent = ButtonEvent { + pointer :: Ptr WlrPointer, + timeMs :: Word32, + button :: Word32, + modifiers :: Word32, + state :: ButtonState +} deriving (Eq, Show, Ord) diff --git a/plug/src/Montis/Core/KeyEvent.hs b/plug/src/Montis/Core/KeyEvent.hs new file mode 100644 index 0000000..cbdda4f --- /dev/null +++ b/plug/src/Montis/Core/KeyEvent.hs @@ -0,0 +1,22 @@ +module Montis.Core.KeyEvent + ( KeyEvent (..), + KeyState (..), + ) +where + +import Data.Word (Word32) +import Foreign (Ptr) +import Montis.Foreign.WlRoots + +data KeyState = KeyPressed | KeyReleased deriving (Show, Read, Eq, Enum, Ord) + +data KeyEvent = KeyEvent + { timeMs :: Word32, + keycode :: Word32, + state :: KeyState, + modifiers :: Word32, + keysym :: Word32, + codepoint :: Char, + device :: Ptr WlrInputDevice + } + deriving (Show, Ord, Eq) diff --git a/plug/src/Montis/Core/Keys.hs b/plug/src/Montis/Core/Keys.hs new file mode 100644 index 0000000..4ee9e6e --- /dev/null +++ b/plug/src/Montis/Core/Keys.hs @@ -0,0 +1,239 @@ +module Montis.Core.Keys where + +import Control.Monad (forever, void, when) +import Control.Monad.Cont.Class +import Control.Monad.IO.Class +import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT, gets, modify) +import Control.Monad.Trans.Cont +import Data.Bits +import Data.Word +import Montis.Core.ButtonEvent (ButtonEvent) +import Montis.Core.KeyEvent +import qualified Montis.Core.KeyEvent as KeyEvent +import qualified Montis.Core.ButtonEvent as ButtonEvent +import Montis.Core.W +import Montis.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard) + +-- | Forwards the given key event to the focused window. +forwardKey :: KeyEvent -> W () +forwardKey keyEvent = do + seatPtr <- getSeat + wio $ do + wlrSeatSetKeyboard + seatPtr + (device keyEvent) + + wlrSeatKeyboardNotifyKey + seatPtr + (timeMs keyEvent) + (keycode keyEvent) + ( case state keyEvent of + KeyReleased -> 0 + _ -> 1 + ) + +-- | Forwards the current key event to the focused window. +forwardEvent :: KeyEvent -> KeysM () +forwardEvent = liftW . forwardKey + +-- | Enumeration of possible modifiers +data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5 + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +-- | Converts a modifier to its associated mask. +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 + +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 (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 KeyContinuation = KeyEvent -> W () + +useKeysWithContinuation :: (KeyContinuation -> W ()) -> KeysM () -> W () +useKeysWithContinuation continuation (forever -> km@(KeysM c)) = + evalStateT (evalContT c) (KeysState km continuation) + +useKeys :: KeysM () -> W () +useKeys = useKeysWithContinuation putKeyHandler + +-- | Returns the next key event. +nextKeyEvent :: KeysM KeyEvent +nextKeyEvent = do + st <- KeysM $ lift get + KeysM $ + shiftT + ( \keyHandler -> + lift . lift $ + handleContinuation st (\kp -> evalStateT (keyHandler kp) st) + ) + +-- | Discards the rest of the continuation and starts again from the top. Useful +-- for keybinds where once the key is handled, there's nothing left to do. +continue :: KeysM () +continue = do + st <- KeysM $ lift get + let (KeysM topCont) = keysTop st + + -- This shift discards the rest of the computation and instead returns to the + -- top of the handler. + KeysM $ shiftT (\_ -> resetT topCont) + +-- | Returns the "top" continuation. +getTop :: KeysM (KeysM ()) +getTop = KeysM (gets keysTop) + +putKeyHandler :: KeyContinuation -> W () +putKeyHandler handler = do + s@State {currentHooks = hooks} <- get + put + s + { currentHooks = + hooks + { keyHook = void <$> handler + } + } + +nextButtonEvent :: KeysM ButtonEvent +nextButtonEvent = do + st <- KeysM get + KeysM $ + shiftT $ \h -> + lift $ lift $ putButtonHandler (\ev -> evalStateT (h ev) st) + where + putButtonHandler h = do + modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}} + +nextButtonOrKeyEvent :: KeysM (Either ButtonEvent KeyEvent) +nextButtonOrKeyEvent = do + st <- KeysM get + KeysM $ + shiftT $ \rest -> + lift $ lift $ do + putButtonHandler (\ev -> evalStateT (rest (Left ev)) st) + handleContinuation st (\ev -> evalStateT (rest (Right ev)) st) + + where + putButtonHandler h = do + modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}} + +nextButtonOrKeyPress :: KeysM (Either ButtonEvent KeyEvent) +nextButtonOrKeyPress = do + ev <- nextButtonOrKeyEvent + case ev of + Left bev | ButtonEvent.state bev == ButtonEvent.ButtonPressed -> return ev + Left bev -> forwardButtonEvent bev >> nextButtonOrKeyPress + Right kev | KeyEvent.state kev == KeyEvent.KeyPressed -> return ev + Right kev -> forwardEvent kev >> nextButtonOrKeyPress + + where + forwardButtonEvent _ = return () + + +-- | 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 k >> nextKeyPress + else return k + +-- +-- binding EDSL used to expressively create key bindings and subbindings inside +-- a KeysM () context. +-- + +data KeyMatcher = KeyMatcher Word32 Char + deriving (Show) + +-- | Like a KeyMatcher, but allows additional modifiers to be pressed, not just +-- the exact ones given. +newtype WeakKeyMatcher = WeakKeyMatcher KeyMatcher + +-- | Converts a KeyMatcher to a weak key matcher. +weak :: KeyMatcher -> WeakKeyMatcher +weak = WeakKeyMatcher + +class KeyMatcherId r where + toKeyMatcher :: r -> KeyMatcher + +instance KeyMatcherId KeyMatcher where + toKeyMatcher = id + +instance KeyMatcherId Char where + toKeyMatcher = KeyMatcher 0 + +class KeyMatcherBuilder b where + (.+) :: (KeyMatcherId i) => b -> i -> KeyMatcher + +instance KeyMatcherBuilder Modifier where + (.+) m (toKeyMatcher -> (KeyMatcher mods ch)) = + KeyMatcher (mods .|. modifierToMask m) ch + +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 + +instance MatchKey KeyMatcher where + matchKey (KeyMatcher m ch) ev = + ch == KeyEvent.codepoint ev && m == KeyEvent.modifiers ev + +instance MatchKey WeakKeyMatcher where + matchKey (WeakKeyMatcher (KeyMatcher m ch)) ev = + ch == KeyEvent.codepoint ev && (m .|. ms) == ms + where + ms = KeyEvent.modifiers ev + +class IsKeysM m where + toKeysM :: m a -> KeysM a + +instance IsKeysM W where + toKeysM = liftW + +instance IsKeysM KeysM where + toKeysM = id + +bind :: (MatchKey m, IsKeysM k) => KeyEvent -> m -> k () -> KeysM () +bind ev m act = do + when (matchKey m ev) $ do + toKeysM act + continue + +ignoreReleaseEvents :: KeyEvent -> KeysM () +ignoreReleaseEvents ev = do + when (KeyEvent.state ev /= KeyEvent.KeyPressed) $ do + forwardEvent ev + continue diff --git a/plug/src/Montis/Core/SurfaceEvent.hs b/plug/src/Montis/Core/SurfaceEvent.hs new file mode 100644 index 0000000..93bcdae --- /dev/null +++ b/plug/src/Montis/Core/SurfaceEvent.hs @@ -0,0 +1,16 @@ +module Montis.Core.SurfaceEvent + ( SurfaceEvent (..), + SurfaceState (..), + ) +where + +import Montis.Foreign.WlRoots + +data SurfaceState = Map | Unmap | Destroy + deriving (Eq, Ord, Show, Read, Enum) + +data SurfaceEvent = SurfaceEvent + { state :: SurfaceState, + surface :: Surface + } + deriving (Eq, Ord, Show) diff --git a/plug/src/Montis/Core/W.hs b/plug/src/Montis/Core/W.hs new file mode 100644 index 0000000..cf21a04 --- /dev/null +++ b/plug/src/Montis/Core/W.hs @@ -0,0 +1,379 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Montis.Core.W where + +import Control.Arrow (Arrow (first)) +import Control.Monad ((<=<)) +import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState, modify) +import Control.Monad.Reader (ReaderT (runReaderT)) +import Control.Monad.State (StateT (runStateT), gets, modify') +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Data.Data (TypeRep, Typeable, cast, tyConModule, tyConName, tyConPackage) +import Data.Default.Class (Default, def) +import Data.Kind (Constraint, Type) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Proxy +import Data.Set (Set) +import qualified Data.Set as Set +import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr) +import Text.Printf (printf) +import Text.Read hiding (lift) +import Type.Reflection (someTypeRep, someTypeRepTyCon) +import Montis.Core.ButtonEvent (ButtonEvent) +import Montis.Core.KeyEvent +import Montis.Core.SurfaceEvent +import Montis.Foreign.ForeignInterface (ForeignInterface) +import qualified Montis.Foreign.ForeignInterface as ForeignInterface +import Montis.Foreign.WlRoots (Surface, WlrSeat) +import Montis.StackSet hiding (layout) +import qualified Montis.StackSet as StackSet + +data RationalRect = RationalRect Rational Rational Rational Rational + +-- | Wrapper for a message. Messages are sent to layout and layouts are supposed +-- to handle them. This hides a typeable parameter. +data Message where + Message :: (Typeable a) => a -> Message + +-- | casts a message to a type. +fromMessage :: (Typeable a) => Message -> Maybe a +fromMessage (Message t) = cast t + +-- | Wraps a type in a message. +toMessage :: (Typeable a) => a -> Message +toMessage = Message + +class (Typeable l) => HandleMessage l where + handleMessage :: Message -> l -> MaybeT W l + handleMessage _ = return + +newtype Window = Window + { surface :: Surface + } + deriving (Show, Ord, Eq, Read) + +-- | Types of this class "lay out" windows by assigning rectangles and handle +-- messages. +class (Typeable l, HandleMessage l) => LayoutClass l where + -- | Constraints on the type to lay out. Sometimes a layout requires the 'a' + -- type to be "Ord", other times "Eq", this is the mechanism by which this + -- constraint is expressed. + type LayoutConstraint l :: Type -> Constraint + + -- | Runs the layout in an impure way returning a modified layout and the list + -- of windows to their rectangles under a monad. + runLayout :: (LayoutConstraint l a) => Stack a -> l -> W (l, [(a, RationalRect)]) + + readLayout :: String -> Maybe l + default readLayout :: (Read l) => String -> Maybe l + readLayout = readMaybe + + serializeLayout :: l -> String + default serializeLayout :: (Show l) => l -> String + serializeLayout = show + + description :: l -> String + default description :: (Show l) => l -> String + description = show + {-# MINIMAL runLayout #-} + +-- | Lifts a pure-layout implementation to a signature that complies with +-- 'runLayout' +pureLayout :: + (Stack a -> l -> [(a, RationalRect)]) -> + Stack a -> + l -> + W (l, [(a, RationalRect)]) +pureLayout fn as l = return (l, fn as l) + +-- A Layout which hides the layout parameter under an existential type and +-- asserts the layout hidden can work with Window types. +data WindowLayout + = forall l a. + (LayoutClass l, LayoutConstraint l a, a ~ Window) => + WindowLayout l + +runWindowLayout :: Stack Window -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)]) +runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l + +handleWindowMessage :: Message -> WindowLayout -> MaybeT W WindowLayout +handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l + +-- | Using the 'Layout' as a witness, parse existentially wrapped windows +-- from a 'String'. +readWindowLayout :: WindowLayout -> String -> WindowLayout +readWindowLayout (WindowLayout l) s + | (Just x) <- readLayout s = + WindowLayout (asTypeOf x l) +readWindowLayout l _ = l + +-- | Serializes a window layout to a string. +serializeWindowLayout :: WindowLayout -> String +serializeWindowLayout (WindowLayout l) = serializeLayout l + +type ScreenId = () + +type ScreenDetail = () + +type Tag = String + +newtype ReadPtr a = ReadPtr (Ptr ()) + +instance Read (ReadPtr a) where + readPrec = fmap (ReadPtr . intPtrToPtr) readPrec + +instance Show (ReadPtr a) where + show (ReadPtr ptr) = show (ptrToIntPtr ptr) + +type Montis = StablePtr (Context, State) + +data Context = Context + { ctxForeignInterface :: ForeignInterface, + ctxConfig :: Config WindowLayout + } + +defaultHooks :: Hooks +defaultHooks = + Hooks + { keyHook = \_ -> return (), + surfaceHook = handleSurface, + buttonHook = \_ -> return () + } + +defaultConfig :: Config () +defaultConfig = + Config + { hooks = defaultHooks, + layout = (), + resetHook = return () + } + +data Hooks = Hooks + { keyHook :: KeyEvent -> W (), + surfaceHook :: SurfaceEvent -> W (), + buttonHook :: ButtonEvent -> W () + } + +data Config l = Config + { layout :: l, + hooks :: Hooks, + resetHook :: W () + } + +-- | Typeclass defining the set of types which can be used as state extensions +-- to the W monad. These state extensions may be persistent or not. +-- +-- There are default implementations for all methods if the type implements +-- Read, Show and Default, +class (Typeable a) => ExtensionClass a where + -- | The initial value used for the first time an extension is 'gotten' or + -- demarshalling fails. + initialValue :: a + + -- | Transforms a type into a string. If the type cannot be marshalled, this + -- function should return Nothing. + -- + -- If a type cannot be marshalled, it cannot persist across hot reloads. + marshalExtension :: a -> Maybe String + + -- | Reads an extension from a string. If this type is not marshallable or + -- reading fails, this function should return Nothing. + demarshalExtension :: String -> Maybe a + + -- | If the type implements Default, use the default implementation. + default initialValue :: (Default a) => a + initialValue = def + + -- | If the type implements Show, use show for the marshalling. + default marshalExtension :: (Show a) => a -> Maybe String + marshalExtension = Just . show + + -- | If the type implements Read, use read for the demarshalling. + default demarshalExtension :: (Read a) => String -> Maybe a + demarshalExtension = readMaybe + +data StateExtension where + StateExtension :: (ExtensionClass a) => a -> StateExtension + +-- | Puts a state extension. +xput :: forall a m. (ExtensionClass a, Wlike m) => a -> m () +xput val = liftW $ do + modify' $ \state@State {extensibleState = extensibleState} -> + state + { extensibleState = + M.insert + ( xRepr (Proxy :: Proxy a) + ) + (Right $ StateExtension val) + extensibleState + } + +-- | Modifies a state extension. +xmodify :: forall a m. (ExtensionClass a, Wlike m) => (a -> a) -> m () +xmodify fn = xput . fn =<< xget + +-- | Modifies a state extension in the monadic context. +xmodifyM :: forall a m. (ExtensionClass a, Wlike m) => (a -> m a) -> m () +xmodifyM fn = (xput <=< fn) =<< xget + +-- | Produces a string representation of a type used to key into the extensible +-- state map. +xRepr :: forall proxy a. (ExtensionClass a) => proxy a -> String +xRepr _ = tyconToStr $ someTypeRepTyCon (someTypeRep (Proxy :: Proxy a)) + where + tyconToStr tc = + printf "%s.%s.%s" (tyConPackage tc) (tyConModule tc) (tyConName tc) + +-- | Gets a state extension. +xget :: forall a m. (ExtensionClass a, Wlike m) => m a +xget = do + xs <- liftW $ gets extensibleState + case M.lookup (xRepr (Proxy :: Proxy a)) xs of + Just (Right (StateExtension a)) -> return (fromMaybe initialValue (cast a)) + Just (Left str) -> + let v = fromMaybe initialValue (demarshalExtension str) + in xput v >> return v + Nothing -> + xput (initialValue :: a) >> return initialValue + +xgets :: forall a b m. (ExtensionClass a, Wlike m) => (a -> b) -> m b +xgets fn = fn <$> xget + +-- State as it is marshalled. Used for derived instances of Show and Read. +data MarshalledState + = MarshalledState + (StackSet ScreenId ScreenDetail Tag String Window) + (Set Window) + [(String, String)] + deriving (Show, Read) + +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, + -- | Map from the typerep string to the state extension. + extensibleState :: Map String (Either String StateExtension) + } + +-- | 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 + mempty + +-- | 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 = mapped, + allWindows = allWindows, + extensibleState = xs + } + ) = + show $ + MarshalledState + (mapLayout serializeWindowLayout mapped) + allWindows + (mapMaybe (\(k, v) -> (k,) <$> doMarshalEx v) (M.toList xs)) + where + doMarshalEx (Left s) = Just s + doMarshalEx (Right (StateExtension a)) = marshalExtension a + +-- | 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 xs + where + ( MarshalledState + (mapLayout (readWindowLayout layout) -> mapped) + allWindows + (fmap Left . M.fromList -> xs) + ) = read str + +-- | This is _the_ main monad used for Montis 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, 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 + +-- | Type class to lift an arbitrary 'W' computation into another monad. +class (Monad m) => Wlike m where + liftW :: W a -> m a + +-- | Trivial instance of W for Wlike. +instance Wlike W where + liftW = id + +-- Default implementations for common handlers. + +-- | handles a new surface event. This updates the state to reflect how it +-- should look in the harness. +handleSurface :: SurfaceEvent -> W () +handleSurface (SurfaceEvent state (Window -> win)) = + case state of + Destroy -> + modify $ + \st@State + { allWindows = allWindows, + mapped = mapped + } -> + st + { allWindows = Set.delete win allWindows, + mapped = StackSet.delete win mapped + } + Unmap -> modify $ + \st@State {mapped = mapped} -> + st + { mapped = StackSet.delete win mapped + } + Map -> modify $ + \st@State {mapped = mapped, allWindows = allWindows} -> + st + { mapped = StackSet.insertTiled win mapped, + allWindows = Set.insert win allWindows + } diff --git a/plug/src/Montis/Dsl/Bind.hs b/plug/src/Montis/Dsl/Bind.hs new file mode 100644 index 0000000..c7dbc43 --- /dev/null +++ b/plug/src/Montis/Dsl/Bind.hs @@ -0,0 +1,128 @@ +-- | eDSL for the 'bind' function. The 'bind' function provides an easy way to +-- bind certain actions to other actions. +module Montis.Dsl.Bind + ( bind, + (.+), + MatchEvent (..), + Modifier (..), + released, + weak, + run, + modifierToMask, + module X, + ) +where + +import Control.Monad +import Control.Monad.Trans +import Data.Bits +import Data.Word +import Montis.Core.ButtonEvent (ButtonEvent(..)) +import qualified Montis.Core.ButtonEvent as ButtonEvent +import Montis.Core.KeyEvent (KeyEvent(..)) +import qualified Montis.Core.KeyEvent as KeyEvent +import Montis.Core.W +import Montis.Dsl.Buttons as X +import Montis.Dsl.Input + +class MatchEvent m where + matches :: m -> InputEvent -> W Bool + +instance MatchEvent (InputEvent -> W Bool) where + matches = ($) + +instance MatchEvent Char where + matches ch (InputKeyEvent ke) = return $ KeyEvent.codepoint ke == ch + matches _ _ = return False + +instance MatchEvent Button where + matches (Button b) (InputButtonEvent be) = + return $ ButtonEvent.button be == b + matches _ _ = return False + +-- | Enumeration of possible modifiers. +-- +-- ModX can be used for extra user-defined modifiers which are not standard xkb +-- modifiers. +data Modifier + = Shift + | Lock + | Control + | Mod1 + | Mod2 + | Mod3 + | Mod4 + | Mod5 + | ModX Int + deriving (Eq, Ord, Show, Read) + +-- | Converts a modifier to its associated mask. +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 + ModX b -> b + 8 + +released :: (MatchEvent m) => m -> InputEvent -> W Bool +released me ev | not (isPressEvent ev) = matches me ev +released _ _ = return False + +data MatchModifiers = MatchModifiers + { weakModifierMatch :: Bool, + modifierMask :: Word32, + baseMatch :: InputEvent -> W Bool + } + +instance MatchEvent MatchModifiers where + matches (MatchModifiers weak bits base) ev = do + mods <- getMods ev + b <- liftW $ base ev + + return $ + b + && ( (not weak && mods == bits) + || (weak && (bits .&. mods == bits)) + ) + where + getMods (InputButtonEvent (ButtonEvent {ButtonEvent.modifiers = mods})) = return mods + getMods (InputKeyEvent (KeyEvent {KeyEvent.modifiers = mods})) = return mods + getMods _ = getModifierState + +class LiftMatchModifiers a where + toModifiers :: a -> MatchModifiers + default toModifiers :: (MatchEvent a) => a -> MatchModifiers + toModifiers = MatchModifiers False 0 . matches + +instance LiftMatchModifiers MatchModifiers where + toModifiers = id + +instance LiftMatchModifiers Char + +instance LiftMatchModifiers Button + +-- toModifiers ch = MatchModifiers False 0 (matches ch) + +(.+) :: (LiftMatchModifiers mods) => Modifier -> mods -> MatchModifiers +(.+) modifier (toModifiers -> (MatchModifiers b mask base)) = + MatchModifiers b (mask .|. modifierToMask modifier) base + +infixr 9 .+ + +bind :: (MatchEvent match) => InputEvent -> match -> InputM spy () -> InputM spy () +bind ev match action = do + matches' <- liftW $ matches match ev + when matches' (action >> continue) + +weak :: MatchModifiers -> MatchModifiers +weak m = m {weakModifierMatch = True} + +run :: W () -> InputM spy () +run = liftW diff --git a/plug/src/Montis/Dsl/Buttons.hsc b/plug/src/Montis/Dsl/Buttons.hsc new file mode 100644 index 0000000..963d5ce --- /dev/null +++ b/plug/src/Montis/Dsl/Buttons.hsc @@ -0,0 +1,229 @@ +module Montis.Dsl.Buttons where + +import Data.Word + +#include + +data Button = Button Word32 + +btnMisc :: Button +btnMisc = Button #const BTN_MISC + +btn0 :: Button +btn0 = Button #const BTN_0 + +btn1 :: Button +btn1 = Button #const BTN_1 + +btn2 :: Button +btn2 = Button #const BTN_2 + +btn3 :: Button +btn3 = Button #const BTN_3 + +btn4 :: Button +btn4 = Button #const BTN_4 + +btn5 :: Button +btn5 = Button #const BTN_5 + +btn6 :: Button +btn6 = Button #const BTN_6 + +btn7 :: Button +btn7 = Button #const BTN_7 + +btn8 :: Button +btn8 = Button #const BTN_8 + +btn9 :: Button +btn9 = Button #const BTN_9 + +btnMouse :: Button +btnMouse = Button #const BTN_MOUSE + +btnLeft :: Button +btnLeft = Button #const BTN_LEFT + +btnRight :: Button +btnRight = Button #const BTN_RIGHT + +btnMiddle :: Button +btnMiddle = Button #const BTN_MIDDLE + +btnSide :: Button +btnSide = Button #const BTN_SIDE + +btnExtra :: Button +btnExtra = Button #const BTN_EXTRA + +btnForward :: Button +btnForward = Button #const BTN_FORWARD + +btnBack :: Button +btnBack = Button #const BTN_BACK + +btnTask :: Button +btnTask = Button #const BTN_TASK + +btnJoystick :: Button +btnJoystick = Button #const BTN_JOYSTICK + +btnTrigger :: Button +btnTrigger = Button #const BTN_TRIGGER + +btnThumb :: Button +btnThumb = Button #const BTN_THUMB + +btnThumb2 :: Button +btnThumb2 = Button #const BTN_THUMB2 + +btnTop :: Button +btnTop = Button #const BTN_TOP + +btnTop2 :: Button +btnTop2 = Button #const BTN_TOP2 + +btnPinkie :: Button +btnPinkie = Button #const BTN_PINKIE + +btnBase :: Button +btnBase = Button #const BTN_BASE + +btnBase2 :: Button +btnBase2 = Button #const BTN_BASE2 + +btnBase3 :: Button +btnBase3 = Button #const BTN_BASE3 + +btnBase4 :: Button +btnBase4 = Button #const BTN_BASE4 + +btnBase5 :: Button +btnBase5 = Button #const BTN_BASE5 + +btnBase6 :: Button +btnBase6 = Button #const BTN_BASE6 + +btnDead :: Button +btnDead = Button #const BTN_DEAD + +btnGamepad :: Button +btnGamepad = Button #const BTN_GAMEPAD + +btnSouth :: Button +btnSouth = Button #const BTN_SOUTH + +btnA :: Button +btnA = Button #const BTN_A + +btnEast :: Button +btnEast = Button #const BTN_EAST + +btnB :: Button +btnB = Button #const BTN_B + +btnC :: Button +btnC = Button #const BTN_C + +btnNorth :: Button +btnNorth = Button #const BTN_NORTH + +btnX :: Button +btnX = Button #const BTN_X + +btnWest :: Button +btnWest = Button #const BTN_WEST + +btnY :: Button +btnY = Button #const BTN_Y + +btnZ :: Button +btnZ = Button #const BTN_Z + +btnTl :: Button +btnTl = Button #const BTN_TL + +btnTr :: Button +btnTr = Button #const BTN_TR + +btnTl2 :: Button +btnTl2 = Button #const BTN_TL2 + +btnTr2 :: Button +btnTr2 = Button #const BTN_TR2 + +btnSelect :: Button +btnSelect = Button #const BTN_SELECT + +btnStart :: Button +btnStart = Button #const BTN_START + +btnMode :: Button +btnMode = Button #const BTN_MODE + +btnThumbl :: Button +btnThumbl = Button #const BTN_THUMBL + +btnThumbr :: Button +btnThumbr = Button #const BTN_THUMBR + +btnDigi :: Button +btnDigi = Button #const BTN_DIGI + +btnToolPen :: Button +btnToolPen = Button #const BTN_TOOL_PEN + +btnToolRubber :: Button +btnToolRubber = Button #const BTN_TOOL_RUBBER + +btnToolBrush :: Button +btnToolBrush = Button #const BTN_TOOL_BRUSH + +btnToolPencil :: Button +btnToolPencil = Button #const BTN_TOOL_PENCIL + +btnToolAirbrush :: Button +btnToolAirbrush = Button #const BTN_TOOL_AIRBRUSH + +btnToolFinger :: Button +btnToolFinger = Button #const BTN_TOOL_FINGER + +btnToolMouse :: Button +btnToolMouse = Button #const BTN_TOOL_MOUSE + +btnToolLens :: Button +btnToolLens = Button #const BTN_TOOL_LENS + +btnToolQuinttap :: Button +btnToolQuinttap = Button #const BTN_TOOL_QUINTTAP + +btnStylus3 :: Button +btnStylus3 = Button #const BTN_STYLUS3 + +btnTouch :: Button +btnTouch = Button #const BTN_TOUCH + +btnStylus :: Button +btnStylus = Button #const BTN_STYLUS + +btnStylus2 :: Button +btnStylus2 = Button #const BTN_STYLUS2 + +btnToolDoubletap :: Button +btnToolDoubletap = Button #const BTN_TOOL_DOUBLETAP + +btnToolTripletap :: Button +btnToolTripletap = Button #const BTN_TOOL_TRIPLETAP + +btnToolQuadtap :: Button +btnToolQuadtap = Button #const BTN_TOOL_QUADTAP + +btnWheel :: Button +btnWheel = Button #const BTN_WHEEL + +btnGearDown :: Button +btnGearDown = Button #const BTN_GEAR_DOWN + +btnGearUp :: Button +btnGearUp = Button #const BTN_GEAR_UP diff --git a/plug/src/Montis/Dsl/Input.hs b/plug/src/Montis/Dsl/Input.hs new file mode 100644 index 0000000..4855951 --- /dev/null +++ b/plug/src/Montis/Dsl/Input.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE DataKinds #-} + +module Montis.Dsl.Input + ( InputM, + InputEvent (..), + InputProxy (..), + NoProxy, + withProxies, + forwardEvent, + forwardKey, + whenKeyEvent, + whenButtonEvent, + useInputHandler, + unwrap, + filterEvent, + isPressEvent, + nextInputEventThat, + replayEvents, + isKeyEvent, + nextInputPressEvent, + continue, + nextInputEvent, + getModifierState, + ) +where + +import Control.Concurrent (threadDelay) +import Control.Monad +import Control.Monad.Cont (MonadCont) +import Control.Monad.Loops (andM) +import Control.Monad.RWS + ( MonadIO (liftIO), + MonadReader (ask), + MonadState (get), + MonadTrans (lift), + RWST, + execRWST, + gets, + modify, + ) +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Proxy +import Data.Word (Word32) +import qualified Montis.Core.ButtonEvent as ButtonEvent +import qualified Montis.Core.KeyEvent as KeyEvent +import Montis.Core.W (W (..)) +import qualified Montis.Core.W as W +import Montis.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard) + +class InputProxy (spy :: k) where + onKeyEvent :: Proxy spy -> InputEvent -> MaybeT W InputEvent + +instance (InputProxy h, InputProxy t) => InputProxy (h ': t) where + onKeyEvent _ = onKeyEvent (Proxy :: Proxy h) <=< onKeyEvent (Proxy :: Proxy t) + +instance InputProxy '[] where + onKeyEvent _ = return + +data NoProxy + +instance InputProxy NoProxy where + onKeyEvent _ = return + +instance (InputProxy s1, InputProxy s2) => InputProxy (s1, s2) where + onKeyEvent proxy = onKeyEvent (fmap fst proxy) <=< onKeyEvent (fmap snd proxy) + +-- | Union of event types. +data InputEvent + = InputButtonEvent ButtonEvent.ButtonEvent + | InputKeyEvent KeyEvent.KeyEvent + +-- | Context for the input. +newtype InputContext spy = InputContext + { -- | Top of the input routine. Used in "continue" statement. + inputTop :: InputM spy () + } + +newtype InputState spy = InputState + { inputSource :: InputM spy InputEvent + } + +-- | Input monad for handling all kinds of input. +newtype InputM spy a = InputM (ContT () (RWST (InputContext spy) () (InputState spy) W) a) + deriving (Monad, Functor, Applicative, MonadCont, MonadIO) + +instance MonadFail (InputM spy) where + fail _ = continue + +-- | Lifts a W action to an InputM action. +instance W.Wlike (InputM spy) where + liftW = InputM . lift . lift + +-- | Resets the input handler to the top. +continue :: InputM spy a +continue = do + (InputContext {inputTop = (InputM top)}) <- InputM ask + InputM $ shiftT (\_ -> resetT top) + +-- | Forwards the given key event to the focused window. +forwardKey :: KeyEvent.KeyEvent -> W () +forwardKey keyEvent = do + seatPtr <- W.getSeat + W.wio $ do + wlrSeatSetKeyboard + seatPtr + (KeyEvent.device keyEvent) + + wlrSeatKeyboardNotifyKey + seatPtr + (KeyEvent.timeMs keyEvent) + (KeyEvent.keycode keyEvent) + ( case KeyEvent.state keyEvent of + KeyEvent.KeyReleased -> 0 + _ -> 1 + ) + +-- | Executes a function if the input event is a key event. If it is not a key +-- event, then nothing happens. +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 :: + (Monad m) => InputEvent -> (ButtonEvent.ButtonEvent -> m ()) -> m () +whenButtonEvent (InputButtonEvent be) = ($ be) +whenButtonEvent _ = const (return ()) + +-- | Forwards the given input event to focused window. +forwardEvent :: (W.Wlike m) => InputEvent -> m () +forwardEvent = \case + InputKeyEvent kv -> W.liftW $ forwardKey kv + InputButtonEvent _ -> return () + +-- | "Unwraps" a maybe. If the maybe is present, the handler proceeds. If the +-- maybe is not present, the handler restarts execution from the top. +unwrap :: Maybe a -> InputM spy 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 spy () +replayEvents events = do + ioref <- liftIO (newIORef events) + + (InputM oldInput) <- InputM $ gets inputSource + + let newInput = + InputM $ + shiftT + ( \thingToDo -> do + r <- liftIO (readIORef ioref) + case r of + [] -> do + modify $ \st -> st {inputSource = InputM oldInput} + a <- oldInput + lift (thingToDo a) + (a : as) -> do + liftIO (writeIORef ioref as) + lift (thingToDo a) + ) + + InputM $ modify $ \st -> st {inputSource = newInput} + where + delay to act = liftIO (threadDelay to) >> act + +-- | Call in the reset handler with the InputM handler you wolud like to use. +useInputHandler :: (InputProxy spy) => InputM spy () -> W () +useInputHandler (forever -> top@(InputM ctop)) = do + 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 spy InputEvent +nextInputPressEvent = nextInputEventThat (andM [isPressEvent, not . modifierKey]) + +modifierKey :: InputEvent -> Bool +modifierKey (InputKeyEvent (KeyEvent.KeyEvent {codepoint = '\NUL'})) = True +modifierKey _ = False + +nextInputEventThat :: (InputEvent -> Bool) -> InputM spy InputEvent +nextInputEventThat fn = + nextInputEvent + >>= ( \ie -> + if fn ie + then return ie + else forwardEvent ie >> nextInputEventThat fn + ) + +isKeyEvent :: InputEvent -> Bool +isKeyEvent (InputKeyEvent _) = True +isKeyEvent _ = False + +isPressEvent :: InputEvent -> Bool +isPressEvent (InputButtonEvent be) + | ButtonEvent.state be == ButtonEvent.ButtonPressed = + True +isPressEvent (InputKeyEvent ke) + | KeyEvent.state ke == KeyEvent.KeyPressed = + True +isPressEvent _ = False + +-- | Returns the event only if it matches the filter. If it does not match the +-- filter, execution resets to the top. +filterEvent :: (InputEvent -> Bool) -> InputEvent -> InputM spy InputEvent +filterEvent fn ev | fn ev = return ev +filterEvent _ _ = continue + +getModifierState :: W Word32 +getModifierState = do + seat <- W.getSeat + keyboard <- W.wio $ wlrSeatGetKeyboard seat + maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard) + +nextInputEvent :: InputM spy InputEvent +nextInputEvent = join $ InputM $ gets inputSource + +withProxies :: Proxy spy -> InputM spy a -> InputM spy a +withProxies _ = id + +-- | Gets the next input event. +useSeatEvents :: forall spy. (InputProxy spy) => InputM spy InputEvent +useSeatEvents = + InputM $ + shiftT + ( \thingToDo -> do + putButtonHandler $ \be -> do + runSpies thingToDo (InputButtonEvent be) + + putKeyHandler $ \ke -> do + runSpies thingToDo (InputKeyEvent ke) + ) + where + runSpies fn ev = do + evM <- lift $ runMaybeT (onKeyEvent (Proxy :: Proxy spy) ev) + mapM_ + ( \ev' -> do + clearButtonHandler + clearKeyHandler + fn ev' + ) + evM + + clearButtonHandler = + lift $ + modify $ \st -> + st + { W.currentHooks = + (W.currentHooks st) + { W.buttonHook = const (return ()) + } + } + + clearKeyHandler = + lift $ + modify $ \st -> + st + { W.currentHooks = + (W.currentHooks st) + { W.keyHook = const (return ()) + } + } + + putButtonHandler h = lift $ do + (r, s) <- (,) <$> ask <*> get + lift $ + modify $ \st -> + st + { W.currentHooks = + (W.currentHooks st) + { W.buttonHook = \be -> void (execRWST (h be) r s) + } + } + + putKeyHandler h = lift $ do + (r, s) <- (,) <$> ask <*> get + lift $ + modify $ \st -> + st + { W.currentHooks = + (W.currentHooks st) + { W.keyHook = \ke -> void (execRWST (h ke) r s) + } + } diff --git a/plug/src/Montis/Foreign.hs b/plug/src/Montis/Foreign.hs new file mode 100644 index 0000000..fbbfb08 --- /dev/null +++ b/plug/src/Montis/Foreign.hs @@ -0,0 +1,18 @@ +module Montis.Foreign + ( TypedIntPtr (..), + toPtr, + fromPtr, + ) +where + +import Foreign (IntPtr, Ptr) +import qualified Foreign + +toPtr :: TypedIntPtr a -> Ptr a +toPtr (TypedIntPtr ip) = Foreign.intPtrToPtr ip + +fromPtr :: Ptr a -> TypedIntPtr a +fromPtr = TypedIntPtr . Foreign.ptrToIntPtr + +newtype TypedIntPtr a = TypedIntPtr IntPtr + deriving (Show, Read, Eq, Ord, Num) diff --git a/plug/src/Montis/Foreign/Export.hs b/plug/src/Montis/Foreign/Export.hs new file mode 100644 index 0000000..f14fb40 --- /dev/null +++ b/plug/src/Montis/Foreign/Export.hs @@ -0,0 +1,208 @@ +-- | This module does not export anything. It exists simply to provide C-symbols +-- for the plugin. +module Montis.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 Foreign + ( Ptr, + Storable (poke, pokeByteOff), + Word32, + Word8, + deRefStablePtr, + freeStablePtr, + mallocBytes, + newStablePtr, + ) +import Foreign.C (CChar, CInt (..)) +import Montis.Core.ButtonEvent (ButtonEvent (ButtonEvent), ButtonState (ButtonPressed, ButtonReleased)) +import Montis.Core.KeyEvent (KeyEvent (..), KeyState (..)) +import Montis.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent)) +import Montis.Core.W (W, Montis) +import qualified Montis.Core.W as W +import Montis.Foreign.ForeignInterface +import Montis.Foreign.WlRoots + +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 ()) -> Montis -> IO Montis +runForeign fn stblptr = do + w@(ctx, st) <- deRefStablePtr stblptr + freeStablePtr stblptr + (_, state') <- W.runW (fn $ toWetter w) (ctx, st) + newStablePtr (ctx, state') + +runForeignWithReturn :: + (Storable a) => (Wetter -> W a) -> Ptr a -> Montis -> IO Montis +runForeignWithReturn fn ptr stableptr = do + w@(ctx, st) <- deRefStablePtr stableptr + freeStablePtr stableptr + (val, state') <- W.runW (fn $ toWetter w) (ctx, st) + poke ptr val + newStablePtr (ctx, state') + +runForeignWithReturn2 :: + (Storable a, Storable b) => + (Wetter -> W (a, b)) -> + Ptr a -> + Ptr b -> + Montis -> + IO Montis +runForeignWithReturn2 fn ptrA ptrB stableptr = do + w@(ctx, st) <- deRefStablePtr stableptr + freeStablePtr stableptr + ((vA, vB), state') <- W.runW (fn $ toWetter w) (ctx, st) + poke ptrA vA + poke ptrB vB + newStablePtr (ctx, state') + +-- | This function is the implementation of the "hotstart" mechanism. It gives a +-- pointer to the previously marshalled state and the length of that array and +-- this function returns a Montis instance. +foreign export ccall "plugin_hot_start" + pluginHotStart :: + Ptr CChar -> Word32 -> IO Montis + +pluginHotStart :: Ptr CChar -> Word32 -> IO Montis +pluginHotStart chars len = do + bs <- BS.packCStringLen (chars, fromIntegral len) + foreignInterface <- getForeignInterface + 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 +-- code as it's sort-of the equivalent of XMonad's "main" function. +foreign export ccall "plugin_cold_start" + pluginColdStart :: IO Montis + +pluginColdStart :: IO Montis +pluginColdStart = do + foreignInterface <- getForeignInterface + state <- W.initColdState config + 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" + pluginMarshalState :: Montis -> Ptr Word32 -> IO (Ptr Word8) + +pluginMarshalState :: Montis -> Ptr Word32 -> IO (Ptr Word8) +pluginMarshalState stblptr outlen = do + (_, st) <- deRefStablePtr stblptr + let bs = CH.pack (W.marshalState st) + ret <- mallocBytes (BS.length bs) + poke outlen (fromIntegral $ BS.length bs) + forM_ (zip [0 ..] (BS.unpack bs)) $ \(off, w8) -> do + pokeByteOff ret off w8 + return ret + +foreign export ccall "plugin_handle_button" + pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Montis -> IO Montis + +pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Montis -> IO Montis +pluginHandleButton eventPtr modifiers = do + runForeign $ + \( _, + W.State {W.currentHooks = W.Hooks {buttonHook = buttonHook}} + ) -> do + event <- W.wio $ + runForeignDemarshal eventPtr $ do + ButtonEvent + <$> demarshal + <*> demarshal + <*> demarshal + <*> pure modifiers + <*> ( ( \u8 -> + if (u8 :: Word8) == 0 + then ButtonReleased + else ButtonPressed + ) + <$> demarshal + ) + + buttonHook event + +foreign export ccall "plugin_handle_keybinding" + pluginHandleKeybinding :: + Ptr WlrInputDevice -> + Ptr WlrEventKeyboardKey -> + Word32 -> + Word32 -> + Word32 -> + Ptr CInt -> + Montis -> + IO Montis + +pluginHandleKeybinding :: + Ptr WlrInputDevice -> + Ptr WlrEventKeyboardKey -> + Word32 -> + Word32 -> + Word32 -> + Ptr CInt -> + Montis -> + IO Montis +pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp = + 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. +foreign export ccall "plugin_handle_surface" + pluginHandleSurface :: + Ptr WlrXdgSurface -> CInt -> Montis -> IO Montis + +pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Montis -> IO Montis +pluginHandleSurface p t = + runForeign + ( \(_, 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 +-- of an XWayland surface. +foreign export ccall "plugin_handle_xwayland_surface" + pluginHandleXWaylandSurface :: + Ptr WlrXWaylandSurface -> CInt -> Montis -> IO Montis + +pluginHandleXWaylandSurface :: + Ptr WlrXWaylandSurface -> CInt -> Montis -> IO Montis +pluginHandleXWaylandSurface p t = + runForeign + ( \( _, + W.State + { currentHooks = W.Hooks {surfaceHook = surfaceHook} + } + ) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p) + ) diff --git a/plug/src/Montis/Foreign/ForeignInterface.hs b/plug/src/Montis/Foreign/ForeignInterface.hs new file mode 100644 index 0000000..c01e6b8 --- /dev/null +++ b/plug/src/Montis/Foreign/ForeignInterface.hs @@ -0,0 +1,81 @@ +module Montis.Foreign.ForeignInterface + ( getForeignInterface, + ForeignInterface (..), + ForeignDemarshal (..), + runForeignDemarshal, + demarshal, + doShellExec, + ) +where + +import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT) +import Data.Void (Void) +import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr) +import Foreign.C (CChar, CInt (..)) +import Foreign.C.String +import GHC.Exts (FunPtr) +import Montis.Foreign.WlRoots + +newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a) + deriving (Functor, Monad, Applicative, MonadState (Ptr ())) + +runForeignDemarshal :: Ptr b -> ForeignDemarshal a -> IO a +runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm (castPtr p) + +demarshal :: (Storable a) => ForeignDemarshal a +demarshal = do + ptr <- get + val <- ForeignDemarshal $ lift $ peek $ castPtr ptr + put (plusPtr ptr (sizeOf val)) + return val + +type CtxT = Ptr Void + +type ForeignCallGetPtr = CtxT -> IO (Ptr ()) + +type ForeignCall = CtxT -> IO () + +type ForeignCallStr = CtxT -> CString -> IO () + +type ForeignCallInt = CtxT -> CInt -> IO () + +foreign import ccall "get_foreign_interface" foreignInterfacePtr :: IO (Ptr ()) + +foreign import ccall "dynamic" toForeignCall :: FunPtr ForeignCall -> ForeignCall + +foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> ForeignCallStr + +foreign import ccall "dynamic" toForeignCallInt :: FunPtr ForeignCallInt -> ForeignCallInt + +foreign import ccall "dynamic" toForeignCallGetPtr :: FunPtr ForeignCallGetPtr -> ForeignCallGetPtr + +foreign import ccall "shell_exec" shellExec :: Ptr CChar -> IO () + +data ForeignInterface = ForeignInterface + { requestHotReload :: IO (), + requestLog :: String -> IO (), + requestExit :: Int -> IO (), + getSeat :: IO (Ptr WlrSeat) + } + +doShellExec :: String -> IO () +doShellExec str = withCString str shellExec + +getForeignInterface :: IO ForeignInterface +getForeignInterface = do + ptr <- foreignInterfacePtr + runForeignDemarshal ptr $ do + ctx <- demarshal + requestHotReloadFn <- demarshal + doLogFn <- demarshal + doRequestExit <- demarshal + getSeatFn <- demarshal + + return $ + ForeignInterface + { requestHotReload = toForeignCall requestHotReloadFn ctx, + requestLog = \str -> + withCString str $ \cs -> toForeignCallStr doLogFn ctx cs, + requestExit = toForeignCallInt doRequestExit ctx . fromIntegral, + getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx + } diff --git a/plug/src/Montis/Foreign/WlRoots.hs b/plug/src/Montis/Foreign/WlRoots.hs new file mode 100644 index 0000000..4b0685f --- /dev/null +++ b/plug/src/Montis/Foreign/WlRoots.hs @@ -0,0 +1,67 @@ +module Montis.Foreign.WlRoots where + +import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr, nullPtr) +import Text.Read + +data WlrKeyboard + +data WlrPointer + +data WlrPointerButtonEvent + +data WlrSeat + +data WlrInputDevice + +data WlrEventKeyboardKey + +data WlrXdgSurface + +data WlrXWaylandSurface + +data Surface + = XdgSurface (Ptr WlrXdgSurface) + | XWaylandSurface (Ptr WlrXWaylandSurface) + deriving (Ord, Eq) + +instance Show Surface where + show (XdgSurface p) = show (XdgSerializeSurface (ptrToIntPtr p)) + show (XWaylandSurface p) = show (XWaylandSerializeSurface (ptrToIntPtr p)) + +instance Read Surface where + readPrec = fmap toSurf readPrec + where + toSurf (XdgSerializeSurface ip) = XdgSurface (intPtrToPtr ip) + toSurf (XWaylandSerializeSurface ip) = XWaylandSurface (intPtrToPtr ip) + +-- | Type which exists specifically to derive instances of read and show. +data SerializableSurface + = XdgSerializeSurface IntPtr + | XWaylandSerializeSurface IntPtr + deriving (Read, Show) + +class ForeignSurface a where + toSurface :: Ptr a -> Surface + +instance ForeignSurface WlrXdgSurface where + toSurface = XdgSurface + +instance ForeignSurface WlrXWaylandSurface where + toSurface = XWaylandSurface + +guardNull :: Ptr a -> Maybe (Ptr a) +guardNull p | p == nullPtr = Nothing +guardNull p = Just p + +foreign import ccall "wlr_seat_set_keyboard" wlrSeatSetKeyboard :: + Ptr WlrSeat -> Ptr WlrInputDevice -> IO () + +foreign import ccall "wlr_seat_get_keyboard" wlrSeatGetKeyboard :: + Ptr WlrSeat -> IO (Ptr WlrKeyboard) + +foreign import ccall "wlr_keyboard_get_modifiers" wlrKeyboardGetModifiers :: + Ptr WlrKeyboard -> IO Word32 + +foreign import ccall "wlr_seat_keyboard_notify_key" + wlrSeatKeyboardNotifyKey :: + Ptr WlrSeat -> Word32 -> Word32 -> Word32 -> IO () diff --git a/plug/src/Montis/Keys/Macros.hs b/plug/src/Montis/Keys/Macros.hs new file mode 100644 index 0000000..37f4db4 --- /dev/null +++ b/plug/src/Montis/Keys/Macros.hs @@ -0,0 +1,145 @@ +-- There are constraints used for better type-level enforced safety rules. +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} + +module Montis.Keys.Macros + ( MacroSupport, + macroStartStopKeybind, + macroReplayKeybind, + stopMacroRecording, + startRecording, + ) +where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans (MonadTrans (lift)) +import Data.Default.Class +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Type.Bool +import Data.Type.Equality +import Data.Word +import Foreign (Ptr) +import GHC.TypeError +import Montis.Core.KeyEvent +import Montis.Core.W +import Montis.Dsl.Input +import Montis.Foreign.WlRoots (WlrInputDevice) + +data RecordedKey = RecordedKey Word32 Word32 KeyState Word32 Word32 Char + deriving (Read, Show) + +data MacrosState = MacrosState + { macros :: Map String [RecordedKey], + currentlyRecording :: Maybe String + } + deriving (Read, Show) + +instance Default MacrosState where + def = MacrosState mempty def + +instance ExtensionClass MacrosState + +type family Find a ls where + Find b (a : t) = (b == a) || Find b t + Find _ '[] = False + +-- | Provides a Vim-esque keybinding behavior for macro recording. +-- +-- Designed to be used like: +-- +-- bind ev (Mod1 .+ 'q') macroStartStopKeybind +macroStartStopKeybind :: (HasMacroSupport spy) => InputM spy () +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 :: (HasMacroSupport spy) => InputM spy () +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 + { macros = Map.delete ch macros, + currentlyRecording = Just ch + } + ) + +stopMacroRecording :: (Wlike m) => m () +stopMacroRecording = xmodify (\m -> m {currentlyRecording = Nothing}) + +currentlyRecordingMacro :: (Wlike m) => m (Maybe String) +currentlyRecordingMacro = xgets currentlyRecording + +replayMacro :: Ptr WlrInputDevice -> String -> InputM spy () +replayMacro inputDevice s = do + m <- liftW (Map.lookup s <$> xgets macros) + -- 'tail' is to cut off the last keystroke which stops the recording. + mapM_ (replayEvents . map toInputEvent . reverse . tail) m + where + toInputEvent :: RecordedKey -> InputEvent + toInputEvent (RecordedKey ts kc st mo keysym cp) = + InputKeyEvent $ KeyEvent ts kc st mo keysym cp inputDevice + +pushMacroKey :: (Wlike m) => KeyEvent -> m () +pushMacroKey ke = do + cur <- xgets currentlyRecording + whenJust cur $ \ch -> do + let recordedKey = toRecordedKey ke + in xmodify $ \m@MacrosState {macros = macros} -> + m {macros = Map.insertWith (++) ch [recordedKey] macros} + where + whenJust (Just a) fn = fn a + whenJust _ _ = return () + + toRecordedKey (KeyEvent ts c s m keysym cp _) = RecordedKey ts c s m keysym cp + +-- | Phantom type defining a proxy required to support macros. +data MacroSupport + +-- | Instance for macro support. +instance InputProxy MacroSupport where + onKeyEvent _ ie = do + lift $ whenKeyEvent ie pushMacroKey + return ie + +class HasMacroSupport t + +instance + ( If + (Find MacroSupport t) + True + ( TypeError + ( Text "This Requires the Macro Proxy to be Enabled." + :<>: Text "Please enable this by adding MacroSupport to your" + :<>: Text "inputProxies list.\n" + :<>: Text "i.e. Change " + :<>: ShowType t + :<>: Text " to " + :<>: ShowType (MacroSupport ': t) + ) + ) + ~ True + ) => + HasMacroSupport t + +instance HasMacroSupport MacroSupport diff --git a/plug/src/Montis/Keys/MagicModifierKey.hs b/plug/src/Montis/Keys/MagicModifierKey.hs new file mode 100644 index 0000000..0cf1eb3 --- /dev/null +++ b/plug/src/Montis/Keys/MagicModifierKey.hs @@ -0,0 +1,50 @@ +module Montis.Keys.MagicModifierKey where + +import Data.Data +import Data.Default.Class +import GHC.TypeNats +import Montis.Core.KeyEvent +import Montis.Core.W +import Montis.Dsl.Bind +import Montis.Dsl.Input +import Control.Monad.RWS (MonadTrans(lift)) +import Control.Monad.Trans.Maybe (MaybeT(..)) + +data MagicModifierProxy (keycode :: Natural) inputproxy + deriving (Typeable) + +newtype MagicModifierState (keycode :: Natural) = MagicModifierState {isPressed :: Bool} + deriving (Typeable, Eq, Show, Ord, Read) + +instance Default (MagicModifierState k) where + def = MagicModifierState False + +instance (KnownNat k) => ExtensionClass (MagicModifierState k) + +instance + (KnownNat keycode, InputProxy inputproxy) => + InputProxy (MagicModifierProxy keycode inputproxy) + where + onKeyEvent proxy ie = do + case ie of + (InputKeyEvent (KeyEvent {keycode = kc, state = state})) + | fromIntegral kc == natVal (keycodeProxy proxy) -> do + lift $ setMagicModifierPressed proxy (state == KeyPressed) + MaybeT (return Nothing) + _ -> do + pressed <- lift $ isMagicModifierPressed proxy + if pressed + then onKeyEvent (Proxy :: Proxy inputproxy) ie + else return ie + where + keycodeProxy :: Proxy (MagicModifierProxy kc a) -> Proxy kc + keycodeProxy _ = Proxy + + isMagicModifierPressed p = isPressed <$> getModState p + setMagicModifierPressed p = modifyModState p . const + + getModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> W (MagicModifierState kc) + getModState _ = xget + + modifyModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> (MagicModifierState kc -> Bool) -> W () + modifyModState _ fn = xmodify (MagicModifierState . fn) diff --git a/plug/src/Montis/Layout/Combine.hs b/plug/src/Montis/Layout/Combine.hs new file mode 100644 index 0000000..7563876 --- /dev/null +++ b/plug/src/Montis/Layout/Combine.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ViewPatterns #-} + +module Montis.Layout.Combine where + +import Data.Typeable +import Montis.Constraints +import Montis.Core.W + +data (|||) a b = Comb LR a b + deriving (Typeable, Read, Show) + +data Next = Next + deriving (Typeable) + +data Reset = Reset + deriving (Typeable) + +(|||) :: a -> b -> (a ||| b) +a ||| b = Comb L a b + +data LR = L | R deriving (Read, Show, Ord, Eq, Enum) + +instance (HandleMessage a, HandleMessage b) => HandleMessage (a ||| b) where + handleMessage (fromMessage -> Just Next) (Comb L l r) = return (Comb R l r) + handleMessage (fromMessage -> Just Reset) (Comb _ l r) = return (Comb L l r) + handleMessage mesg (Comb L l r) = + Comb L <$> handleMessage mesg l <*> pure r + handleMessage mesg (Comb R l r) = + Comb L l <$> handleMessage mesg r + +instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where + -- In order to use this layout class, the lay-out type 'a' must satisfy BOTH + -- the left and right constraints. + type LayoutConstraint (a ||| b) = LayoutConstraint a &&&& LayoutConstraint b + + runLayout as (Comb R r l) = do + (r', ret) <- runLayout as r + return (Comb R r' l, ret) + runLayout as (Comb L r l) = do + (l', ret) <- runLayout as l + return (Comb R r l', ret) + + serializeLayout (Comb lr l r) = show (Comb lr (serializeLayout l) (serializeLayout r)) + readLayout str = Comb lr <$> l <*> r + where + (Comb lr (readLayout -> l) (readLayout -> r)) = read str + + description (Comb _ l r) = description l ++ " ||| " ++ description r diff --git a/plug/src/Montis/Layout/Full.hs b/plug/src/Montis/Layout/Full.hs new file mode 100644 index 0000000..b2efb91 --- /dev/null +++ b/plug/src/Montis/Layout/Full.hs @@ -0,0 +1,23 @@ +module Montis.Layout.Full where + +import Data.Data (Typeable) +import Data.Default.Class +import Montis.Constraints +import Montis.Core.W +import Montis.StackSet + +data Full = Full + deriving (Read, Show, Typeable) + +instance Default Full where + def = Full + +instance HandleMessage Full + +instance LayoutClass Full where + type LayoutConstraint Full = Unconstrained + + runLayout = pureLayout $ \l _ -> + case l of + (focused -> Just a) -> [(a, RationalRect 1 1 1 1)] + _ -> [] diff --git a/plug/src/Montis/StackSet.hs b/plug/src/Montis/StackSet.hs new file mode 100644 index 0000000..9f24514 --- /dev/null +++ b/plug/src/Montis/StackSet.hs @@ -0,0 +1,210 @@ +module Montis.StackSet where + +import Control.Monad (void) +import Data.Monoid (First(..)) +import Control.Monad.Identity +import Control.Monad.Writer (MonadWriter (tell), execWriter) +import Data.Maybe (isJust, mapMaybe) +import Data.Maybe (isJust) + +-- | The root datastructure for holding the state of the windows. +data StackSet s sd t l a = StackSet + { -- | The currently selected screen. + current :: Screen s sd t l a, + -- | Remaining visible screens. + visible :: [Screen s sd t l a], + -- | Workspaces that exist, but are not on a screen. + hidden :: [Workspace t l a] + } + deriving (Read, Show, Eq, Ord, Functor) + +class TraverseWorkspace f where + traverseWorkspaces :: + (Applicative m) => (Workspace t l a -> m (Workspace t' l' a')) -> f t l a -> m (f t' l' a') + +traverseWorkspaces_ :: (TraverseWorkspace f, Monad m) => (Workspace t l a -> m ()) -> f t l a -> m () +traverseWorkspaces_ f = void . traverseWorkspaces (\w -> f w >> pure w) + +foldMapWorkspaces :: + (Monoid m, TraverseWorkspace f) => (Workspace t l a -> m) -> f t l a -> m +foldMapWorkspaces fn = execWriter . traverseWorkspaces_ (tell . fn) + +mapWorkspaces :: + (TraverseWorkspace f) => + (Workspace t l a -> Workspace t' l' a') -> + f t l a -> + f t' l' a' +mapWorkspaces fn = runIdentity . traverseWorkspaces (pure . fn) + +instance TraverseWorkspace Workspace where + traverseWorkspaces f = f + +instance TraverseWorkspace (Screen s sd) where + traverseWorkspaces f scr = (\w' -> scr {workspace = w'}) <$> f (workspace scr) + +instance TraverseWorkspace (StackSet s sd) where + traverseWorkspaces f (StackSet cur vis hid) = + StackSet + <$> traverseWorkspaces f cur + <*> traverse (traverseWorkspaces f) vis + <*> traverse (traverseWorkspaces f) hid + +instance Traversable Stack where + traverse f (Stack u d) = + Stack <$> traverse f u <*> traverse f d + +instance (TraverseWorkspace f) => Foldable (f t l) where + foldMap fn = + execWriter + . traverseWorkspaces_ (\(Workspace _ _ s) -> tell (foldMap (fn . windowInSeat) s)) + +instance (Functor (f t l), TraverseWorkspace f) => Traversable (f t l) where + sequenceA = + traverseWorkspaces $ + \(Workspace t l sf) -> Workspace t l <$> traverse sequenceA sf + +class HasFocus f where + focused :: f a -> Maybe a + +data Rectangle = Rectangle Int Int Int Int + deriving (Read, Show, Eq, Ord) + +instance HasFocus (StackSet s sd t l) where + focused (StackSet c _ _) = focused c + +data Screen s sd t l a = Screen + { screenDetail :: sd, + screenId :: s, + workspace :: Workspace t l a + } + deriving (Read, Show, Eq, Ord, Functor) + +instance HasFocus (Screen s sd t l) where + focused (Screen _ _ w) = focused w + +-- | Defines where a window should appear. +data WindowSeat a = Floating Rectangle a | Tiled a + deriving (Read, Show, Eq, Ord, Functor, Foldable) + +windowInSeat :: WindowSeat a -> a +windowInSeat (Floating _ a) = a +windowInSeat (Tiled a) = a + +instance Traversable WindowSeat where + sequenceA (Floating r fa) = Floating r <$> fa + sequenceA (Tiled fa) = Tiled <$> fa + +instance HasFocus WindowSeat where + focused (Floating _ a) = Just a + focused (Tiled a) = Just a + +data Workspace t l a = Workspace + { tag :: t, + layout :: l, + stack :: Stack (WindowSeat a) + } + deriving (Read, Show, Eq, Ord, Functor) + +instance HasFocus (Workspace t l) where + focused (Workspace _ _ s) = windowInSeat <$> focused s + +data Stack a = Stack + { -- | The elements above the focused one. + up :: ![a], + -- | The elements below the focused one including the focused one itself. + down :: ![a] + } + deriving (Read, Show, Eq, Ord, Functor, Foldable) + +instance HasFocus Stack where + focused (Stack _ (a : _)) = Just a + focused _ = Nothing + +-- | Change the tag in a structure. +mapTag :: (TraverseWorkspace f) => (t -> t') -> f t l a -> f t' l a +mapTag fn = mapWorkspaces (\w -> w {tag = fn (tag w)}) + +-- | Change the layout in a structure. +mapLayout :: (TraverseWorkspace f) => (l -> l') -> f t l a -> f t l' a +mapLayout fn = mapWorkspaces (\w -> w {layout = fn (layout w)}) + +-- | Return all the tags in a structure. +tags :: (TraverseWorkspace f) => f t l a -> [t] +tags = foldMapWorkspaces ((: []) . tag) + +-- | Insert a new window into the StackSet. The optional rectangle indicates if +-- the window should be floating or tiled. +-- +-- The window is inserted just above the the currently focused window and is +-- given focus. +insert :: a -> Maybe Rectangle -> StackSet s sd t l a -> StackSet s sd t l a +insert win rect = + runIdentity + . onCurrentStack + ( \(Stack u d) -> + return $ + (\w -> Stack u (w : d)) $ + maybe (Tiled win) (`Floating` win) rect + ) + +-- | Find the tag associated with a window. +findTag :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Maybe t +findTag a = + getFirst + . foldMapWorkspaces + ( \ws -> + foldMap + ( \a' -> + First $ if a' == a then Just (tag ws) else Nothing + ) + ws + ) + +-- | Return true if the window exist in a structure +elem :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Bool +elem a = isJust . findTag a + +-- | Convenience function for inserting a window in stack set tiled. +insertTiled :: a -> StackSet s sd t l a -> StackSet s sd t l a +insertTiled win = insert win Nothing + +integrate :: Stack a -> [a] +integrate (Stack u d) = u ++ d + +differentiate :: [a] -> Stack a +differentiate = Stack [] + +applyStack :: + (Monad m) => + (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) -> + Workspace t l a -> + m (Workspace t l a) +applyStack fn (Workspace t l s) = Workspace t l <$> fn s + +-- | Apply a function to the currently focused stack. +onCurrentStack :: + (Monad m) => + (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) -> + StackSet s sd t l a -> + m (StackSet s sd t l a) +onCurrentStack fn (StackSet cur vis hid) = + StackSet <$> cur' cur <*> pure vis <*> pure hid + where + cur' (Screen s sd ws) = Screen s sd <$> ws' ws + ws' (Workspace t l s) = Workspace t l <$> fn s + +catMaybes :: StackSet s sd t l (Maybe a) -> StackSet s sd t l a +catMaybes (StackSet cur hidden visible) = + StackSet (catMaybesS cur) (map catMaybesS hidden) (map catMaybesW visible) + where + catMaybesS (Screen a b ws) = Screen a b $ catMaybesW ws + catMaybesW (Workspace a b st) = Workspace a b $ catMaybesSt st + catMaybesSt (Stack up down) = + Stack (mapMaybe sequenceA up) (mapMaybe sequenceA down) + +filter :: (a -> Bool) -> StackSet s sd t l a -> StackSet s sd t l a +filter ffn = + Montis.StackSet.catMaybes . fmap (\a -> if ffn a then Just a else Nothing) + +delete :: (Eq a) => a -> StackSet s sd t l a -> StackSet s sd t l a +delete win = Montis.StackSet.filter (/=win) diff --git a/plug/src/Wetterhorn/Constraints.hs b/plug/src/Wetterhorn/Constraints.hs deleted file mode 100644 index 129fd6c..0000000 --- a/plug/src/Wetterhorn/Constraints.hs +++ /dev/null @@ -1,13 +0,0 @@ --- | Contains useful constraints and constraint combinators for type-level --- metaprogramming. -module Wetterhorn.Constraints where - --- | A null constraint. All types implement this. -class Unconstrained a - -instance Unconstrained a - --- | Combines multiple constraints by 'And'ing them together. -class (c1 a, c2 a) => (&&&&) c1 c2 a - -instance (c1 a, c2 a) => (&&&&) c1 c2 a diff --git a/plug/src/Wetterhorn/Core.hs b/plug/src/Wetterhorn/Core.hs deleted file mode 100644 index d853191..0000000 --- a/plug/src/Wetterhorn/Core.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# HLINT ignore "Use camelCase" #-} - -module Wetterhorn.Core --- ( WState (..), --- WConfig (..), --- SurfaceState (..), --- W, --- getWConfig, --- getWState, --- runW, --- Wetterhorn, --- initWetterhorn, --- wio, --- incrementState, --- readWState, --- defaultConfig, --- requestHotReload, --- ctxConfig, --- KeyEvent (..), --- KeyState (..), --- ) -where - --- import Control.Arrow (first) --- import Control.Exception --- import Data.ByteString (ByteString) --- import Data.Char (ord) --- import Data.Map (Map) --- import Foreign (Ptr, StablePtr, Word32, newStablePtr) --- import Text.Printf --- import Wetterhorn.Foreign.ForeignInterface (ForeignInterface) --- import Wetterhorn.Foreign.WlRoots --- import qualified Data.ByteString.Char8 as CH --- import qualified Data.Map as Map --- import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface --- --- data WContext = WContext --- { ctxForeignInterface :: ForeignInterface, --- ctxConfig :: WConfig --- } --- --- -- This is the OpaqueState passed to the harness. --- type Wetterhorn = StablePtr (WContext, WState) --- --- requestHotReload :: W () --- requestHotReload = do --- fi <- ctxForeignInterface <$> getWContext --- wio $ ForeignInterface.requestHotReload fi --- --- requestLog :: String -> W () --- requestLog str = do --- fi <- ctxForeignInterface <$> getWContext --- wio $ ForeignInterface.requestLog fi str --- --- requestExit :: Int -> W () --- requestExit ec = do --- fi <- ctxForeignInterface <$> getWContext --- wio $ ForeignInterface.requestExit fi ec --- --- initWetterhorn :: WConfig -> IO Wetterhorn --- initWetterhorn conf = do --- foreignInterface <- ForeignInterface.getForeignInterface --- newStablePtr (WContext foreignInterface conf, WState "this is a string" 0) --- --- defaultBindings :: Map (KeyState, Word32, Word32) (W ()) --- defaultBindings = --- Map.fromList --- [ ((KeyPressed, 0x9, sym 'Q'), requestHotReload), --- ((KeyPressed, 0x8, sym 'r'), wio $ ForeignInterface.doShellExec "wofi --show run"), --- ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"), --- ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"), --- ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"), --- ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"), --- ( (KeyPressed, 0x8, sym 'p'), --- wio $ do --- putStrLn "Maps:" --- putStrLn =<< readFile "/proc/self/maps" --- ), --- ((KeyPressed, 0x8, sym 'q'), requestExit 0) --- ] --- where --- sym = fromIntegral . ord --- --- defaultConfig :: WConfig --- defaultConfig = --- WConfig --- { keybindingHandler = \keyEvent -> do --- seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext --- --- maybe --- ( wio $ do --- wlrSeatSetKeyboard seatPtr (device keyEvent) --- wlrSeatKeyboardNotifyKey --- seatPtr --- (timeMs keyEvent) --- (keycode keyEvent) --- ( case state keyEvent of --- KeyReleased -> 0 --- _ -> 1 --- ) --- --- return True --- ) --- (fmap (const True)) --- $ Map.lookup --- (state keyEvent, modifiers keyEvent, keysym keyEvent) --- defaultBindings, --- surfaceHandler = \state surface -> wio (printf "Surface %s is %s\n" (show surface) (show state)) --- } --- --- readWState :: ByteString -> IO WState --- readWState bs = --- catch --- (return $ read (CH.unpack bs)) --- ( \e -> --- let _ = (e :: SomeException) in return (WState "" 0) --- ) --- --- newtype W a = W ((WContext, WState) -> IO (a, WState)) --- --- instance Functor W where --- fmap mfn (W fn) = W $ fmap (first mfn) <$> fn --- --- instance Applicative W where --- pure a = W $ \(_, s) -> return (a, s) --- mfn <*> ma = do --- fn <- mfn --- fn <$> ma --- --- instance Monad W where --- (W fntoa) >>= fnmb = W $ \(config, state) -> do --- (a, state') <- fntoa (config, state) --- let W fntob = fnmb a --- fntob (config, state') --- --- getWContext :: W WContext --- getWContext = W pure --- --- getWConfig :: W WConfig --- getWConfig = ctxConfig <$> getWContext --- --- getWState :: W WState --- getWState = W $ \(_, s) -> pure (s, s) --- --- runW :: W a -> (WContext, WState) -> IO (a, WState) --- runW (W fn) = fn --- --- incrementState :: W Int --- incrementState = W $ \(_, WState s i) -> return (i, WState s (i + 1)) --- --- wio :: IO a -> W a --- wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b) diff --git a/plug/src/Wetterhorn/Core/ButtonEvent.hs b/plug/src/Wetterhorn/Core/ButtonEvent.hs deleted file mode 100644 index cc3d905..0000000 --- a/plug/src/Wetterhorn/Core/ButtonEvent.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Wetterhorn.Core.ButtonEvent where - -import Wetterhorn.Foreign.WlRoots -import Data.Word (Word32) -import Foreign (Ptr) - -data ButtonState = ButtonReleased | ButtonPressed deriving (Show, Read, Eq, Enum, Ord) - -data ButtonEvent = ButtonEvent { - pointer :: Ptr WlrPointer, - timeMs :: Word32, - button :: Word32, - modifiers :: Word32, - state :: ButtonState -} deriving (Eq, Show, Ord) diff --git a/plug/src/Wetterhorn/Core/KeyEvent.hs b/plug/src/Wetterhorn/Core/KeyEvent.hs deleted file mode 100644 index 77d273f..0000000 --- a/plug/src/Wetterhorn/Core/KeyEvent.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Wetterhorn.Core.KeyEvent - ( KeyEvent (..), - KeyState (..), - ) -where - -import Data.Word (Word32) -import Foreign (Ptr) -import Wetterhorn.Foreign.WlRoots - -data KeyState = KeyPressed | KeyReleased deriving (Show, Read, Eq, Enum, Ord) - -data KeyEvent = KeyEvent - { timeMs :: Word32, - keycode :: Word32, - state :: KeyState, - modifiers :: Word32, - keysym :: Word32, - codepoint :: Char, - device :: Ptr WlrInputDevice - } - deriving (Show, Ord, Eq) diff --git a/plug/src/Wetterhorn/Core/Keys.hs b/plug/src/Wetterhorn/Core/Keys.hs deleted file mode 100644 index 54d7125..0000000 --- a/plug/src/Wetterhorn/Core/Keys.hs +++ /dev/null @@ -1,239 +0,0 @@ -module Wetterhorn.Core.Keys where - -import Control.Monad (forever, void, when) -import Control.Monad.Cont.Class -import Control.Monad.IO.Class -import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT, gets, modify) -import Control.Monad.Trans.Cont -import Data.Bits -import Data.Word -import Wetterhorn.Core.ButtonEvent (ButtonEvent) -import Wetterhorn.Core.KeyEvent -import qualified Wetterhorn.Core.KeyEvent as KeyEvent -import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent -import Wetterhorn.Core.W -import Wetterhorn.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard) - --- | Forwards the given key event to the focused window. -forwardKey :: KeyEvent -> W () -forwardKey keyEvent = do - seatPtr <- getSeat - wio $ do - wlrSeatSetKeyboard - seatPtr - (device keyEvent) - - wlrSeatKeyboardNotifyKey - seatPtr - (timeMs keyEvent) - (keycode keyEvent) - ( case state keyEvent of - KeyReleased -> 0 - _ -> 1 - ) - --- | Forwards the current key event to the focused window. -forwardEvent :: KeyEvent -> KeysM () -forwardEvent = liftW . forwardKey - --- | Enumeration of possible modifiers -data Modifier = Shift | Lock | Control | Mod1 | Mod2 | Mod3 | Mod4 | Mod5 - deriving (Eq, Ord, Show, Read, Enum, Bounded) - --- | Converts a modifier to its associated mask. -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 - -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 (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 KeyContinuation = KeyEvent -> W () - -useKeysWithContinuation :: (KeyContinuation -> W ()) -> KeysM () -> W () -useKeysWithContinuation continuation (forever -> km@(KeysM c)) = - evalStateT (evalContT c) (KeysState km continuation) - -useKeys :: KeysM () -> W () -useKeys = useKeysWithContinuation putKeyHandler - --- | Returns the next key event. -nextKeyEvent :: KeysM KeyEvent -nextKeyEvent = do - st <- KeysM $ lift get - KeysM $ - shiftT - ( \keyHandler -> - lift . lift $ - handleContinuation st (\kp -> evalStateT (keyHandler kp) st) - ) - --- | Discards the rest of the continuation and starts again from the top. Useful --- for keybinds where once the key is handled, there's nothing left to do. -continue :: KeysM () -continue = do - st <- KeysM $ lift get - let (KeysM topCont) = keysTop st - - -- This shift discards the rest of the computation and instead returns to the - -- top of the handler. - KeysM $ shiftT (\_ -> resetT topCont) - --- | Returns the "top" continuation. -getTop :: KeysM (KeysM ()) -getTop = KeysM (gets keysTop) - -putKeyHandler :: KeyContinuation -> W () -putKeyHandler handler = do - s@State {currentHooks = hooks} <- get - put - s - { currentHooks = - hooks - { keyHook = void <$> handler - } - } - -nextButtonEvent :: KeysM ButtonEvent -nextButtonEvent = do - st <- KeysM get - KeysM $ - shiftT $ \h -> - lift $ lift $ putButtonHandler (\ev -> evalStateT (h ev) st) - where - putButtonHandler h = do - modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}} - -nextButtonOrKeyEvent :: KeysM (Either ButtonEvent KeyEvent) -nextButtonOrKeyEvent = do - st <- KeysM get - KeysM $ - shiftT $ \rest -> - lift $ lift $ do - putButtonHandler (\ev -> evalStateT (rest (Left ev)) st) - handleContinuation st (\ev -> evalStateT (rest (Right ev)) st) - - where - putButtonHandler h = do - modify $ \st -> st {currentHooks = (currentHooks st) {buttonHook = h}} - -nextButtonOrKeyPress :: KeysM (Either ButtonEvent KeyEvent) -nextButtonOrKeyPress = do - ev <- nextButtonOrKeyEvent - case ev of - Left bev | ButtonEvent.state bev == ButtonEvent.ButtonPressed -> return ev - Left bev -> forwardButtonEvent bev >> nextButtonOrKeyPress - Right kev | KeyEvent.state kev == KeyEvent.KeyPressed -> return ev - Right kev -> forwardEvent kev >> nextButtonOrKeyPress - - where - forwardButtonEvent _ = return () - - --- | 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 k >> nextKeyPress - else return k - --- --- binding EDSL used to expressively create key bindings and subbindings inside --- a KeysM () context. --- - -data KeyMatcher = KeyMatcher Word32 Char - deriving (Show) - --- | Like a KeyMatcher, but allows additional modifiers to be pressed, not just --- the exact ones given. -newtype WeakKeyMatcher = WeakKeyMatcher KeyMatcher - --- | Converts a KeyMatcher to a weak key matcher. -weak :: KeyMatcher -> WeakKeyMatcher -weak = WeakKeyMatcher - -class KeyMatcherId r where - toKeyMatcher :: r -> KeyMatcher - -instance KeyMatcherId KeyMatcher where - toKeyMatcher = id - -instance KeyMatcherId Char where - toKeyMatcher = KeyMatcher 0 - -class KeyMatcherBuilder b where - (.+) :: (KeyMatcherId i) => b -> i -> KeyMatcher - -instance KeyMatcherBuilder Modifier where - (.+) m (toKeyMatcher -> (KeyMatcher mods ch)) = - KeyMatcher (mods .|. modifierToMask m) ch - -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 - -instance MatchKey KeyMatcher where - matchKey (KeyMatcher m ch) ev = - ch == KeyEvent.codepoint ev && m == KeyEvent.modifiers ev - -instance MatchKey WeakKeyMatcher where - matchKey (WeakKeyMatcher (KeyMatcher m ch)) ev = - ch == KeyEvent.codepoint ev && (m .|. ms) == ms - where - ms = KeyEvent.modifiers ev - -class IsKeysM m where - toKeysM :: m a -> KeysM a - -instance IsKeysM W where - toKeysM = liftW - -instance IsKeysM KeysM where - toKeysM = id - -bind :: (MatchKey m, IsKeysM k) => KeyEvent -> m -> k () -> KeysM () -bind ev m act = do - when (matchKey m ev) $ do - toKeysM act - continue - -ignoreReleaseEvents :: KeyEvent -> KeysM () -ignoreReleaseEvents ev = do - when (KeyEvent.state ev /= KeyEvent.KeyPressed) $ do - forwardEvent ev - continue diff --git a/plug/src/Wetterhorn/Core/SurfaceEvent.hs b/plug/src/Wetterhorn/Core/SurfaceEvent.hs deleted file mode 100644 index 3e7eaf3..0000000 --- a/plug/src/Wetterhorn/Core/SurfaceEvent.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Wetterhorn.Core.SurfaceEvent - ( SurfaceEvent (..), - SurfaceState (..), - ) -where - -import Wetterhorn.Foreign.WlRoots - -data SurfaceState = Map | Unmap | Destroy - deriving (Eq, Ord, Show, Read, Enum) - -data SurfaceEvent = SurfaceEvent - { state :: SurfaceState, - surface :: Surface - } - deriving (Eq, Ord, Show) diff --git a/plug/src/Wetterhorn/Core/W.hs b/plug/src/Wetterhorn/Core/W.hs deleted file mode 100644 index 862f9fa..0000000 --- a/plug/src/Wetterhorn/Core/W.hs +++ /dev/null @@ -1,379 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} - -module Wetterhorn.Core.W where - -import Control.Arrow (Arrow (first)) -import Control.Monad ((<=<)) -import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState, modify) -import Control.Monad.Reader (ReaderT (runReaderT)) -import Control.Monad.State (StateT (runStateT), gets, modify') -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Data.Data (TypeRep, Typeable, cast, tyConModule, tyConName, tyConPackage) -import Data.Default.Class (Default, def) -import Data.Kind (Constraint, Type) -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Proxy -import Data.Set (Set) -import qualified Data.Set as Set -import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr) -import Text.Printf (printf) -import Text.Read hiding (lift) -import Type.Reflection (someTypeRep, someTypeRepTyCon) -import Wetterhorn.Core.ButtonEvent (ButtonEvent) -import Wetterhorn.Core.KeyEvent -import Wetterhorn.Core.SurfaceEvent -import Wetterhorn.Foreign.ForeignInterface (ForeignInterface) -import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface -import Wetterhorn.Foreign.WlRoots (Surface, WlrSeat) -import Wetterhorn.StackSet hiding (layout) -import qualified Wetterhorn.StackSet as StackSet - -data RationalRect = RationalRect Rational Rational Rational Rational - --- | Wrapper for a message. Messages are sent to layout and layouts are supposed --- to handle them. This hides a typeable parameter. -data Message where - Message :: (Typeable a) => a -> Message - --- | casts a message to a type. -fromMessage :: (Typeable a) => Message -> Maybe a -fromMessage (Message t) = cast t - --- | Wraps a type in a message. -toMessage :: (Typeable a) => a -> Message -toMessage = Message - -class (Typeable l) => HandleMessage l where - handleMessage :: Message -> l -> MaybeT W l - handleMessage _ = return - -newtype Window = Window - { surface :: Surface - } - deriving (Show, Ord, Eq, Read) - --- | Types of this class "lay out" windows by assigning rectangles and handle --- messages. -class (Typeable l, HandleMessage l) => LayoutClass l where - -- | Constraints on the type to lay out. Sometimes a layout requires the 'a' - -- type to be "Ord", other times "Eq", this is the mechanism by which this - -- constraint is expressed. - type LayoutConstraint l :: Type -> Constraint - - -- | Runs the layout in an impure way returning a modified layout and the list - -- of windows to their rectangles under a monad. - runLayout :: (LayoutConstraint l a) => Stack a -> l -> W (l, [(a, RationalRect)]) - - readLayout :: String -> Maybe l - default readLayout :: (Read l) => String -> Maybe l - readLayout = readMaybe - - serializeLayout :: l -> String - default serializeLayout :: (Show l) => l -> String - serializeLayout = show - - description :: l -> String - default description :: (Show l) => l -> String - description = show - {-# MINIMAL runLayout #-} - --- | Lifts a pure-layout implementation to a signature that complies with --- 'runLayout' -pureLayout :: - (Stack a -> l -> [(a, RationalRect)]) -> - Stack a -> - l -> - W (l, [(a, RationalRect)]) -pureLayout fn as l = return (l, fn as l) - --- A Layout which hides the layout parameter under an existential type and --- asserts the layout hidden can work with Window types. -data WindowLayout - = forall l a. - (LayoutClass l, LayoutConstraint l a, a ~ Window) => - WindowLayout l - -runWindowLayout :: Stack Window -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)]) -runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l - -handleWindowMessage :: Message -> WindowLayout -> MaybeT W WindowLayout -handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l - --- | Using the 'Layout' as a witness, parse existentially wrapped windows --- from a 'String'. -readWindowLayout :: WindowLayout -> String -> WindowLayout -readWindowLayout (WindowLayout l) s - | (Just x) <- readLayout s = - WindowLayout (asTypeOf x l) -readWindowLayout l _ = l - --- | Serializes a window layout to a string. -serializeWindowLayout :: WindowLayout -> String -serializeWindowLayout (WindowLayout l) = serializeLayout l - -type ScreenId = () - -type ScreenDetail = () - -type Tag = String - -newtype ReadPtr a = ReadPtr (Ptr ()) - -instance Read (ReadPtr a) where - readPrec = fmap (ReadPtr . intPtrToPtr) readPrec - -instance Show (ReadPtr a) where - show (ReadPtr ptr) = show (ptrToIntPtr ptr) - -type Wetterhorn = StablePtr (Context, State) - -data Context = Context - { ctxForeignInterface :: ForeignInterface, - ctxConfig :: Config WindowLayout - } - -defaultHooks :: Hooks -defaultHooks = - Hooks - { keyHook = \_ -> return (), - surfaceHook = handleSurface, - buttonHook = \_ -> return () - } - -defaultConfig :: Config () -defaultConfig = - Config - { hooks = defaultHooks, - layout = (), - resetHook = return () - } - -data Hooks = Hooks - { keyHook :: KeyEvent -> W (), - surfaceHook :: SurfaceEvent -> W (), - buttonHook :: ButtonEvent -> W () - } - -data Config l = Config - { layout :: l, - hooks :: Hooks, - resetHook :: W () - } - --- | Typeclass defining the set of types which can be used as state extensions --- to the W monad. These state extensions may be persistent or not. --- --- There are default implementations for all methods if the type implements --- Read, Show and Default, -class (Typeable a) => ExtensionClass a where - -- | The initial value used for the first time an extension is 'gotten' or - -- demarshalling fails. - initialValue :: a - - -- | Transforms a type into a string. If the type cannot be marshalled, this - -- function should return Nothing. - -- - -- If a type cannot be marshalled, it cannot persist across hot reloads. - marshalExtension :: a -> Maybe String - - -- | Reads an extension from a string. If this type is not marshallable or - -- reading fails, this function should return Nothing. - demarshalExtension :: String -> Maybe a - - -- | If the type implements Default, use the default implementation. - default initialValue :: (Default a) => a - initialValue = def - - -- | If the type implements Show, use show for the marshalling. - default marshalExtension :: (Show a) => a -> Maybe String - marshalExtension = Just . show - - -- | If the type implements Read, use read for the demarshalling. - default demarshalExtension :: (Read a) => String -> Maybe a - demarshalExtension = readMaybe - -data StateExtension where - StateExtension :: (ExtensionClass a) => a -> StateExtension - --- | Puts a state extension. -xput :: forall a m. (ExtensionClass a, Wlike m) => a -> m () -xput val = liftW $ do - modify' $ \state@State {extensibleState = extensibleState} -> - state - { extensibleState = - M.insert - ( xRepr (Proxy :: Proxy a) - ) - (Right $ StateExtension val) - extensibleState - } - --- | Modifies a state extension. -xmodify :: forall a m. (ExtensionClass a, Wlike m) => (a -> a) -> m () -xmodify fn = xput . fn =<< xget - --- | Modifies a state extension in the monadic context. -xmodifyM :: forall a m. (ExtensionClass a, Wlike m) => (a -> m a) -> m () -xmodifyM fn = (xput <=< fn) =<< xget - --- | Produces a string representation of a type used to key into the extensible --- state map. -xRepr :: forall proxy a. (ExtensionClass a) => proxy a -> String -xRepr _ = tyconToStr $ someTypeRepTyCon (someTypeRep (Proxy :: Proxy a)) - where - tyconToStr tc = - printf "%s.%s.%s" (tyConPackage tc) (tyConModule tc) (tyConName tc) - --- | Gets a state extension. -xget :: forall a m. (ExtensionClass a, Wlike m) => m a -xget = do - xs <- liftW $ gets extensibleState - case M.lookup (xRepr (Proxy :: Proxy a)) xs of - Just (Right (StateExtension a)) -> return (fromMaybe initialValue (cast a)) - Just (Left str) -> - let v = fromMaybe initialValue (demarshalExtension str) - in xput v >> return v - Nothing -> - xput (initialValue :: a) >> return initialValue - -xgets :: forall a b m. (ExtensionClass a, Wlike m) => (a -> b) -> m b -xgets fn = fn <$> xget - --- State as it is marshalled. Used for derived instances of Show and Read. -data MarshalledState - = MarshalledState - (StackSet ScreenId ScreenDetail Tag String Window) - (Set Window) - [(String, String)] - deriving (Show, Read) - -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, - -- | Map from the typerep string to the state extension. - extensibleState :: Map String (Either String StateExtension) - } - --- | 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 - mempty - --- | 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 = mapped, - allWindows = allWindows, - extensibleState = xs - } - ) = - show $ - MarshalledState - (mapLayout serializeWindowLayout mapped) - allWindows - (mapMaybe (\(k, v) -> (k,) <$> doMarshalEx v) (M.toList xs)) - where - doMarshalEx (Left s) = Just s - doMarshalEx (Right (StateExtension a)) = marshalExtension a - --- | 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 xs - where - ( MarshalledState - (mapLayout (readWindowLayout layout) -> mapped) - allWindows - (fmap Left . M.fromList -> xs) - ) = 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, 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 - --- | Type class to lift an arbitrary 'W' computation into another monad. -class (Monad m) => Wlike m where - liftW :: W a -> m a - --- | Trivial instance of W for Wlike. -instance Wlike W where - liftW = id - --- Default implementations for common handlers. - --- | handles a new surface event. This updates the state to reflect how it --- should look in the harness. -handleSurface :: SurfaceEvent -> W () -handleSurface (SurfaceEvent state (Window -> win)) = - case state of - Destroy -> - modify $ - \st@State - { allWindows = allWindows, - mapped = mapped - } -> - st - { allWindows = Set.delete win allWindows, - mapped = StackSet.delete win mapped - } - Unmap -> modify $ - \st@State {mapped = mapped} -> - st - { mapped = StackSet.delete win mapped - } - Map -> modify $ - \st@State {mapped = mapped, allWindows = allWindows} -> - st - { mapped = StackSet.insertTiled win mapped, - allWindows = Set.insert win allWindows - } diff --git a/plug/src/Wetterhorn/Dsl/Bind.hs b/plug/src/Wetterhorn/Dsl/Bind.hs deleted file mode 100644 index 0b6adaf..0000000 --- a/plug/src/Wetterhorn/Dsl/Bind.hs +++ /dev/null @@ -1,128 +0,0 @@ --- | eDSL for the 'bind' function. The 'bind' function provides an easy way to --- bind certain actions to other actions. -module Wetterhorn.Dsl.Bind - ( bind, - (.+), - MatchEvent (..), - Modifier (..), - released, - weak, - run, - modifierToMask, - module X, - ) -where - -import Control.Monad -import Control.Monad.Trans -import Data.Bits -import Data.Word -import Wetterhorn.Core.ButtonEvent (ButtonEvent(..)) -import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent -import Wetterhorn.Core.KeyEvent (KeyEvent(..)) -import qualified Wetterhorn.Core.KeyEvent as KeyEvent -import Wetterhorn.Core.W -import Wetterhorn.Dsl.Buttons as X -import Wetterhorn.Dsl.Input - -class MatchEvent m where - matches :: m -> InputEvent -> W Bool - -instance MatchEvent (InputEvent -> W Bool) where - matches = ($) - -instance MatchEvent Char where - matches ch (InputKeyEvent ke) = return $ KeyEvent.codepoint ke == ch - matches _ _ = return False - -instance MatchEvent Button where - matches (Button b) (InputButtonEvent be) = - return $ ButtonEvent.button be == b - matches _ _ = return False - --- | Enumeration of possible modifiers. --- --- ModX can be used for extra user-defined modifiers which are not standard xkb --- modifiers. -data Modifier - = Shift - | Lock - | Control - | Mod1 - | Mod2 - | Mod3 - | Mod4 - | Mod5 - | ModX Int - deriving (Eq, Ord, Show, Read) - --- | Converts a modifier to its associated mask. -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 - ModX b -> b + 8 - -released :: (MatchEvent m) => m -> InputEvent -> W Bool -released me ev | not (isPressEvent ev) = matches me ev -released _ _ = return False - -data MatchModifiers = MatchModifiers - { weakModifierMatch :: Bool, - modifierMask :: Word32, - baseMatch :: InputEvent -> W Bool - } - -instance MatchEvent MatchModifiers where - matches (MatchModifiers weak bits base) ev = do - mods <- getMods ev - b <- liftW $ base ev - - return $ - b - && ( (not weak && mods == bits) - || (weak && (bits .&. mods == bits)) - ) - where - getMods (InputButtonEvent (ButtonEvent {ButtonEvent.modifiers = mods})) = return mods - getMods (InputKeyEvent (KeyEvent {KeyEvent.modifiers = mods})) = return mods - getMods _ = getModifierState - -class LiftMatchModifiers a where - toModifiers :: a -> MatchModifiers - default toModifiers :: (MatchEvent a) => a -> MatchModifiers - toModifiers = MatchModifiers False 0 . matches - -instance LiftMatchModifiers MatchModifiers where - toModifiers = id - -instance LiftMatchModifiers Char - -instance LiftMatchModifiers Button - --- toModifiers ch = MatchModifiers False 0 (matches ch) - -(.+) :: (LiftMatchModifiers mods) => Modifier -> mods -> MatchModifiers -(.+) modifier (toModifiers -> (MatchModifiers b mask base)) = - MatchModifiers b (mask .|. modifierToMask modifier) base - -infixr 9 .+ - -bind :: (MatchEvent match) => InputEvent -> match -> InputM spy () -> InputM spy () -bind ev match action = do - matches' <- liftW $ matches match ev - when matches' (action >> continue) - -weak :: MatchModifiers -> MatchModifiers -weak m = m {weakModifierMatch = True} - -run :: W () -> InputM spy () -run = liftW diff --git a/plug/src/Wetterhorn/Dsl/Buttons.hsc b/plug/src/Wetterhorn/Dsl/Buttons.hsc deleted file mode 100644 index c3e049c..0000000 --- a/plug/src/Wetterhorn/Dsl/Buttons.hsc +++ /dev/null @@ -1,229 +0,0 @@ -module Wetterhorn.Dsl.Buttons where - -import Data.Word - -#include - -data Button = Button Word32 - -btnMisc :: Button -btnMisc = Button #const BTN_MISC - -btn0 :: Button -btn0 = Button #const BTN_0 - -btn1 :: Button -btn1 = Button #const BTN_1 - -btn2 :: Button -btn2 = Button #const BTN_2 - -btn3 :: Button -btn3 = Button #const BTN_3 - -btn4 :: Button -btn4 = Button #const BTN_4 - -btn5 :: Button -btn5 = Button #const BTN_5 - -btn6 :: Button -btn6 = Button #const BTN_6 - -btn7 :: Button -btn7 = Button #const BTN_7 - -btn8 :: Button -btn8 = Button #const BTN_8 - -btn9 :: Button -btn9 = Button #const BTN_9 - -btnMouse :: Button -btnMouse = Button #const BTN_MOUSE - -btnLeft :: Button -btnLeft = Button #const BTN_LEFT - -btnRight :: Button -btnRight = Button #const BTN_RIGHT - -btnMiddle :: Button -btnMiddle = Button #const BTN_MIDDLE - -btnSide :: Button -btnSide = Button #const BTN_SIDE - -btnExtra :: Button -btnExtra = Button #const BTN_EXTRA - -btnForward :: Button -btnForward = Button #const BTN_FORWARD - -btnBack :: Button -btnBack = Button #const BTN_BACK - -btnTask :: Button -btnTask = Button #const BTN_TASK - -btnJoystick :: Button -btnJoystick = Button #const BTN_JOYSTICK - -btnTrigger :: Button -btnTrigger = Button #const BTN_TRIGGER - -btnThumb :: Button -btnThumb = Button #const BTN_THUMB - -btnThumb2 :: Button -btnThumb2 = Button #const BTN_THUMB2 - -btnTop :: Button -btnTop = Button #const BTN_TOP - -btnTop2 :: Button -btnTop2 = Button #const BTN_TOP2 - -btnPinkie :: Button -btnPinkie = Button #const BTN_PINKIE - -btnBase :: Button -btnBase = Button #const BTN_BASE - -btnBase2 :: Button -btnBase2 = Button #const BTN_BASE2 - -btnBase3 :: Button -btnBase3 = Button #const BTN_BASE3 - -btnBase4 :: Button -btnBase4 = Button #const BTN_BASE4 - -btnBase5 :: Button -btnBase5 = Button #const BTN_BASE5 - -btnBase6 :: Button -btnBase6 = Button #const BTN_BASE6 - -btnDead :: Button -btnDead = Button #const BTN_DEAD - -btnGamepad :: Button -btnGamepad = Button #const BTN_GAMEPAD - -btnSouth :: Button -btnSouth = Button #const BTN_SOUTH - -btnA :: Button -btnA = Button #const BTN_A - -btnEast :: Button -btnEast = Button #const BTN_EAST - -btnB :: Button -btnB = Button #const BTN_B - -btnC :: Button -btnC = Button #const BTN_C - -btnNorth :: Button -btnNorth = Button #const BTN_NORTH - -btnX :: Button -btnX = Button #const BTN_X - -btnWest :: Button -btnWest = Button #const BTN_WEST - -btnY :: Button -btnY = Button #const BTN_Y - -btnZ :: Button -btnZ = Button #const BTN_Z - -btnTl :: Button -btnTl = Button #const BTN_TL - -btnTr :: Button -btnTr = Button #const BTN_TR - -btnTl2 :: Button -btnTl2 = Button #const BTN_TL2 - -btnTr2 :: Button -btnTr2 = Button #const BTN_TR2 - -btnSelect :: Button -btnSelect = Button #const BTN_SELECT - -btnStart :: Button -btnStart = Button #const BTN_START - -btnMode :: Button -btnMode = Button #const BTN_MODE - -btnThumbl :: Button -btnThumbl = Button #const BTN_THUMBL - -btnThumbr :: Button -btnThumbr = Button #const BTN_THUMBR - -btnDigi :: Button -btnDigi = Button #const BTN_DIGI - -btnToolPen :: Button -btnToolPen = Button #const BTN_TOOL_PEN - -btnToolRubber :: Button -btnToolRubber = Button #const BTN_TOOL_RUBBER - -btnToolBrush :: Button -btnToolBrush = Button #const BTN_TOOL_BRUSH - -btnToolPencil :: Button -btnToolPencil = Button #const BTN_TOOL_PENCIL - -btnToolAirbrush :: Button -btnToolAirbrush = Button #const BTN_TOOL_AIRBRUSH - -btnToolFinger :: Button -btnToolFinger = Button #const BTN_TOOL_FINGER - -btnToolMouse :: Button -btnToolMouse = Button #const BTN_TOOL_MOUSE - -btnToolLens :: Button -btnToolLens = Button #const BTN_TOOL_LENS - -btnToolQuinttap :: Button -btnToolQuinttap = Button #const BTN_TOOL_QUINTTAP - -btnStylus3 :: Button -btnStylus3 = Button #const BTN_STYLUS3 - -btnTouch :: Button -btnTouch = Button #const BTN_TOUCH - -btnStylus :: Button -btnStylus = Button #const BTN_STYLUS - -btnStylus2 :: Button -btnStylus2 = Button #const BTN_STYLUS2 - -btnToolDoubletap :: Button -btnToolDoubletap = Button #const BTN_TOOL_DOUBLETAP - -btnToolTripletap :: Button -btnToolTripletap = Button #const BTN_TOOL_TRIPLETAP - -btnToolQuadtap :: Button -btnToolQuadtap = Button #const BTN_TOOL_QUADTAP - -btnWheel :: Button -btnWheel = Button #const BTN_WHEEL - -btnGearDown :: Button -btnGearDown = Button #const BTN_GEAR_DOWN - -btnGearUp :: Button -btnGearUp = Button #const BTN_GEAR_UP diff --git a/plug/src/Wetterhorn/Dsl/Input.hs b/plug/src/Wetterhorn/Dsl/Input.hs deleted file mode 100644 index 1a0c294..0000000 --- a/plug/src/Wetterhorn/Dsl/Input.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Wetterhorn.Dsl.Input - ( InputM, - InputEvent (..), - InputProxy (..), - NoProxy, - withProxies, - forwardEvent, - forwardKey, - whenKeyEvent, - whenButtonEvent, - useInputHandler, - unwrap, - filterEvent, - isPressEvent, - nextInputEventThat, - replayEvents, - isKeyEvent, - nextInputPressEvent, - continue, - nextInputEvent, - getModifierState, - ) -where - -import Control.Concurrent (threadDelay) -import Control.Monad -import Control.Monad.Cont (MonadCont) -import Control.Monad.Loops (andM) -import Control.Monad.RWS - ( MonadIO (liftIO), - MonadReader (ask), - MonadState (get), - MonadTrans (lift), - RWST, - execRWST, - gets, - modify, - ) -import Control.Monad.Trans.Cont -import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) -import Data.IORef (newIORef, readIORef, writeIORef) -import Data.Proxy -import Data.Word (Word32) -import qualified Wetterhorn.Core.ButtonEvent as ButtonEvent -import qualified Wetterhorn.Core.KeyEvent as KeyEvent -import Wetterhorn.Core.W (W (..)) -import qualified Wetterhorn.Core.W as W -import Wetterhorn.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard) - -class InputProxy (spy :: k) where - onKeyEvent :: Proxy spy -> InputEvent -> MaybeT W InputEvent - -instance (InputProxy h, InputProxy t) => InputProxy (h ': t) where - onKeyEvent _ = onKeyEvent (Proxy :: Proxy h) <=< onKeyEvent (Proxy :: Proxy t) - -instance InputProxy '[] where - onKeyEvent _ = return - -data NoProxy - -instance InputProxy NoProxy where - onKeyEvent _ = return - -instance (InputProxy s1, InputProxy s2) => InputProxy (s1, s2) where - onKeyEvent proxy = onKeyEvent (fmap fst proxy) <=< onKeyEvent (fmap snd proxy) - --- | Union of event types. -data InputEvent - = InputButtonEvent ButtonEvent.ButtonEvent - | InputKeyEvent KeyEvent.KeyEvent - --- | Context for the input. -newtype InputContext spy = InputContext - { -- | Top of the input routine. Used in "continue" statement. - inputTop :: InputM spy () - } - -newtype InputState spy = InputState - { inputSource :: InputM spy InputEvent - } - --- | Input monad for handling all kinds of input. -newtype InputM spy a = InputM (ContT () (RWST (InputContext spy) () (InputState spy) W) a) - deriving (Monad, Functor, Applicative, MonadCont, MonadIO) - -instance MonadFail (InputM spy) where - fail _ = continue - --- | Lifts a W action to an InputM action. -instance W.Wlike (InputM spy) where - liftW = InputM . lift . lift - --- | Resets the input handler to the top. -continue :: InputM spy a -continue = do - (InputContext {inputTop = (InputM top)}) <- InputM ask - InputM $ shiftT (\_ -> resetT top) - --- | Forwards the given key event to the focused window. -forwardKey :: KeyEvent.KeyEvent -> W () -forwardKey keyEvent = do - seatPtr <- W.getSeat - W.wio $ do - wlrSeatSetKeyboard - seatPtr - (KeyEvent.device keyEvent) - - wlrSeatKeyboardNotifyKey - seatPtr - (KeyEvent.timeMs keyEvent) - (KeyEvent.keycode keyEvent) - ( case KeyEvent.state keyEvent of - KeyEvent.KeyReleased -> 0 - _ -> 1 - ) - --- | Executes a function if the input event is a key event. If it is not a key --- event, then nothing happens. -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 :: - (Monad m) => InputEvent -> (ButtonEvent.ButtonEvent -> m ()) -> m () -whenButtonEvent (InputButtonEvent be) = ($ be) -whenButtonEvent _ = const (return ()) - --- | Forwards the given input event to focused window. -forwardEvent :: (W.Wlike m) => InputEvent -> m () -forwardEvent = \case - InputKeyEvent kv -> W.liftW $ forwardKey kv - InputButtonEvent _ -> return () - --- | "Unwraps" a maybe. If the maybe is present, the handler proceeds. If the --- maybe is not present, the handler restarts execution from the top. -unwrap :: Maybe a -> InputM spy 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 spy () -replayEvents events = do - ioref <- liftIO (newIORef events) - - (InputM oldInput) <- InputM $ gets inputSource - - let newInput = - InputM $ - shiftT - ( \thingToDo -> do - r <- liftIO (readIORef ioref) - case r of - [] -> do - modify $ \st -> st {inputSource = InputM oldInput} - a <- oldInput - lift (thingToDo a) - (a : as) -> do - liftIO (writeIORef ioref as) - lift (thingToDo a) - ) - - InputM $ modify $ \st -> st {inputSource = newInput} - where - delay to act = liftIO (threadDelay to) >> act - --- | Call in the reset handler with the InputM handler you wolud like to use. -useInputHandler :: (InputProxy spy) => InputM spy () -> W () -useInputHandler (forever -> top@(InputM ctop)) = do - 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 spy InputEvent -nextInputPressEvent = nextInputEventThat (andM [isPressEvent, not . modifierKey]) - -modifierKey :: InputEvent -> Bool -modifierKey (InputKeyEvent (KeyEvent.KeyEvent {codepoint = '\NUL'})) = True -modifierKey _ = False - -nextInputEventThat :: (InputEvent -> Bool) -> InputM spy InputEvent -nextInputEventThat fn = - nextInputEvent - >>= ( \ie -> - if fn ie - then return ie - else forwardEvent ie >> nextInputEventThat fn - ) - -isKeyEvent :: InputEvent -> Bool -isKeyEvent (InputKeyEvent _) = True -isKeyEvent _ = False - -isPressEvent :: InputEvent -> Bool -isPressEvent (InputButtonEvent be) - | ButtonEvent.state be == ButtonEvent.ButtonPressed = - True -isPressEvent (InputKeyEvent ke) - | KeyEvent.state ke == KeyEvent.KeyPressed = - True -isPressEvent _ = False - --- | Returns the event only if it matches the filter. If it does not match the --- filter, execution resets to the top. -filterEvent :: (InputEvent -> Bool) -> InputEvent -> InputM spy InputEvent -filterEvent fn ev | fn ev = return ev -filterEvent _ _ = continue - -getModifierState :: W Word32 -getModifierState = do - seat <- W.getSeat - keyboard <- W.wio $ wlrSeatGetKeyboard seat - maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard) - -nextInputEvent :: InputM spy InputEvent -nextInputEvent = join $ InputM $ gets inputSource - -withProxies :: Proxy spy -> InputM spy a -> InputM spy a -withProxies _ = id - --- | Gets the next input event. -useSeatEvents :: forall spy. (InputProxy spy) => InputM spy InputEvent -useSeatEvents = - InputM $ - shiftT - ( \thingToDo -> do - putButtonHandler $ \be -> do - runSpies thingToDo (InputButtonEvent be) - - putKeyHandler $ \ke -> do - runSpies thingToDo (InputKeyEvent ke) - ) - where - runSpies fn ev = do - evM <- lift $ runMaybeT (onKeyEvent (Proxy :: Proxy spy) ev) - mapM_ - ( \ev' -> do - clearButtonHandler - clearKeyHandler - fn ev' - ) - evM - - clearButtonHandler = - lift $ - modify $ \st -> - st - { W.currentHooks = - (W.currentHooks st) - { W.buttonHook = const (return ()) - } - } - - clearKeyHandler = - lift $ - modify $ \st -> - st - { W.currentHooks = - (W.currentHooks st) - { W.keyHook = const (return ()) - } - } - - putButtonHandler h = lift $ do - (r, s) <- (,) <$> ask <*> get - lift $ - modify $ \st -> - st - { W.currentHooks = - (W.currentHooks st) - { W.buttonHook = \be -> void (execRWST (h be) r s) - } - } - - putKeyHandler h = lift $ do - (r, s) <- (,) <$> ask <*> get - lift $ - modify $ \st -> - st - { W.currentHooks = - (W.currentHooks st) - { W.keyHook = \ke -> void (execRWST (h ke) r s) - } - } diff --git a/plug/src/Wetterhorn/Foreign.hs b/plug/src/Wetterhorn/Foreign.hs deleted file mode 100644 index 2d0a42c..0000000 --- a/plug/src/Wetterhorn/Foreign.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Wetterhorn.Foreign - ( TypedIntPtr (..), - toPtr, - fromPtr, - ) -where - -import Foreign (IntPtr, Ptr) -import qualified Foreign - -toPtr :: TypedIntPtr a -> Ptr a -toPtr (TypedIntPtr ip) = Foreign.intPtrToPtr ip - -fromPtr :: Ptr a -> TypedIntPtr a -fromPtr = TypedIntPtr . Foreign.ptrToIntPtr - -newtype TypedIntPtr a = TypedIntPtr IntPtr - deriving (Show, Read, Eq, Ord, Num) diff --git a/plug/src/Wetterhorn/Foreign/Export.hs b/plug/src/Wetterhorn/Foreign/Export.hs deleted file mode 100644 index 51bd72b..0000000 --- a/plug/src/Wetterhorn/Foreign/Export.hs +++ /dev/null @@ -1,208 +0,0 @@ --- | This module does not export anything. It exists simply to provide C-symbols --- for the plugin. -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 Foreign - ( Ptr, - Storable (poke, pokeByteOff), - Word32, - Word8, - deRefStablePtr, - freeStablePtr, - mallocBytes, - newStablePtr, - ) -import Foreign.C (CChar, CInt (..)) -import Wetterhorn.Core.ButtonEvent (ButtonEvent (ButtonEvent), ButtonState (ButtonPressed, ButtonReleased)) -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.Foreign.ForeignInterface -import Wetterhorn.Foreign.WlRoots - -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 - w@(ctx, st) <- deRefStablePtr stblptr - freeStablePtr stblptr - (_, state') <- W.runW (fn $ toWetter w) (ctx, st) - newStablePtr (ctx, state') - -runForeignWithReturn :: - (Storable a) => (Wetter -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn -runForeignWithReturn fn ptr stableptr = do - w@(ctx, st) <- deRefStablePtr stableptr - freeStablePtr stableptr - (val, state') <- W.runW (fn $ toWetter w) (ctx, st) - poke ptr val - newStablePtr (ctx, state') - -runForeignWithReturn2 :: - (Storable a, Storable b) => - (Wetter -> W (a, b)) -> - Ptr a -> - Ptr b -> - Wetterhorn -> - IO Wetterhorn -runForeignWithReturn2 fn ptrA ptrB stableptr = do - w@(ctx, st) <- deRefStablePtr stableptr - freeStablePtr stableptr - ((vA, vB), state') <- W.runW (fn $ toWetter w) (ctx, st) - poke ptrA vA - poke ptrB vB - newStablePtr (ctx, state') - --- | This function is the implementation of the "hotstart" mechanism. It gives a --- pointer to the previously marshalled state and the length of that array and --- this function returns a Wetterhorn instance. -foreign export ccall "plugin_hot_start" - pluginHotStart :: - Ptr CChar -> Word32 -> IO Wetterhorn - -pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn -pluginHotStart chars len = do - bs <- BS.packCStringLen (chars, fromIntegral len) - foreignInterface <- getForeignInterface - 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 --- code as it's sort-of the equivalent of XMonad's "main" function. -foreign export ccall "plugin_cold_start" - pluginColdStart :: IO Wetterhorn - -pluginColdStart :: IO Wetterhorn -pluginColdStart = do - foreignInterface <- getForeignInterface - state <- W.initColdState config - 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" - pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8) - -pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8) -pluginMarshalState stblptr outlen = do - (_, st) <- deRefStablePtr stblptr - let bs = CH.pack (W.marshalState st) - ret <- mallocBytes (BS.length bs) - poke outlen (fromIntegral $ BS.length bs) - forM_ (zip [0 ..] (BS.unpack bs)) $ \(off, w8) -> do - pokeByteOff ret off w8 - return ret - -foreign export ccall "plugin_handle_button" - pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn - -pluginHandleButton :: Ptr WlrPointerButtonEvent -> Word32 -> Wetterhorn -> IO Wetterhorn -pluginHandleButton eventPtr modifiers = do - runForeign $ - \( _, - W.State {W.currentHooks = W.Hooks {buttonHook = buttonHook}} - ) -> do - event <- W.wio $ - runForeignDemarshal eventPtr $ do - ButtonEvent - <$> demarshal - <*> demarshal - <*> demarshal - <*> pure modifiers - <*> ( ( \u8 -> - if (u8 :: Word8) == 0 - then ButtonReleased - else ButtonPressed - ) - <$> demarshal - ) - - buttonHook event - -foreign export ccall "plugin_handle_keybinding" - pluginHandleKeybinding :: - Ptr WlrInputDevice -> - Ptr WlrEventKeyboardKey -> - Word32 -> - Word32 -> - Word32 -> - Ptr CInt -> - Wetterhorn -> - IO Wetterhorn - -pluginHandleKeybinding :: - Ptr WlrInputDevice -> - Ptr WlrEventKeyboardKey -> - Word32 -> - Word32 -> - Word32 -> - Ptr CInt -> - Wetterhorn -> - IO Wetterhorn -pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp = - 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. -foreign export ccall "plugin_handle_surface" - pluginHandleSurface :: - Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn - -pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn -pluginHandleSurface p t = - runForeign - ( \(_, 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 --- of an XWayland surface. -foreign export ccall "plugin_handle_xwayland_surface" - pluginHandleXWaylandSurface :: - Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn - -pluginHandleXWaylandSurface :: - Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn -pluginHandleXWaylandSurface p t = - runForeign - ( \( _, - W.State - { currentHooks = W.Hooks {surfaceHook = surfaceHook} - } - ) -> surfaceHook $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p) - ) diff --git a/plug/src/Wetterhorn/Foreign/ForeignInterface.hs b/plug/src/Wetterhorn/Foreign/ForeignInterface.hs deleted file mode 100644 index 471e3a9..0000000 --- a/plug/src/Wetterhorn/Foreign/ForeignInterface.hs +++ /dev/null @@ -1,81 +0,0 @@ -module Wetterhorn.Foreign.ForeignInterface - ( getForeignInterface, - ForeignInterface (..), - ForeignDemarshal (..), - runForeignDemarshal, - demarshal, - doShellExec, - ) -where - -import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT) -import Data.Void (Void) -import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr) -import Foreign.C (CChar, CInt (..)) -import Foreign.C.String -import GHC.Exts (FunPtr) -import Wetterhorn.Foreign.WlRoots - -newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a) - deriving (Functor, Monad, Applicative, MonadState (Ptr ())) - -runForeignDemarshal :: Ptr b -> ForeignDemarshal a -> IO a -runForeignDemarshal p (ForeignDemarshal dm) = evalStateT dm (castPtr p) - -demarshal :: (Storable a) => ForeignDemarshal a -demarshal = do - ptr <- get - val <- ForeignDemarshal $ lift $ peek $ castPtr ptr - put (plusPtr ptr (sizeOf val)) - return val - -type CtxT = Ptr Void - -type ForeignCallGetPtr = CtxT -> IO (Ptr ()) - -type ForeignCall = CtxT -> IO () - -type ForeignCallStr = CtxT -> CString -> IO () - -type ForeignCallInt = CtxT -> CInt -> IO () - -foreign import ccall "get_foreign_interface" foreignInterfacePtr :: IO (Ptr ()) - -foreign import ccall "dynamic" toForeignCall :: FunPtr ForeignCall -> ForeignCall - -foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> ForeignCallStr - -foreign import ccall "dynamic" toForeignCallInt :: FunPtr ForeignCallInt -> ForeignCallInt - -foreign import ccall "dynamic" toForeignCallGetPtr :: FunPtr ForeignCallGetPtr -> ForeignCallGetPtr - -foreign import ccall "shell_exec" shellExec :: Ptr CChar -> IO () - -data ForeignInterface = ForeignInterface - { requestHotReload :: IO (), - requestLog :: String -> IO (), - requestExit :: Int -> IO (), - getSeat :: IO (Ptr WlrSeat) - } - -doShellExec :: String -> IO () -doShellExec str = withCString str shellExec - -getForeignInterface :: IO ForeignInterface -getForeignInterface = do - ptr <- foreignInterfacePtr - runForeignDemarshal ptr $ do - ctx <- demarshal - requestHotReloadFn <- demarshal - doLogFn <- demarshal - doRequestExit <- demarshal - getSeatFn <- demarshal - - return $ - ForeignInterface - { requestHotReload = toForeignCall requestHotReloadFn ctx, - requestLog = \str -> - withCString str $ \cs -> toForeignCallStr doLogFn ctx cs, - requestExit = toForeignCallInt doRequestExit ctx . fromIntegral, - getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx - } diff --git a/plug/src/Wetterhorn/Foreign/WlRoots.hs b/plug/src/Wetterhorn/Foreign/WlRoots.hs deleted file mode 100644 index 0581b77..0000000 --- a/plug/src/Wetterhorn/Foreign/WlRoots.hs +++ /dev/null @@ -1,67 +0,0 @@ -module Wetterhorn.Foreign.WlRoots where - -import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr, nullPtr) -import Text.Read - -data WlrKeyboard - -data WlrPointer - -data WlrPointerButtonEvent - -data WlrSeat - -data WlrInputDevice - -data WlrEventKeyboardKey - -data WlrXdgSurface - -data WlrXWaylandSurface - -data Surface - = XdgSurface (Ptr WlrXdgSurface) - | XWaylandSurface (Ptr WlrXWaylandSurface) - deriving (Ord, Eq) - -instance Show Surface where - show (XdgSurface p) = show (XdgSerializeSurface (ptrToIntPtr p)) - show (XWaylandSurface p) = show (XWaylandSerializeSurface (ptrToIntPtr p)) - -instance Read Surface where - readPrec = fmap toSurf readPrec - where - toSurf (XdgSerializeSurface ip) = XdgSurface (intPtrToPtr ip) - toSurf (XWaylandSerializeSurface ip) = XWaylandSurface (intPtrToPtr ip) - --- | Type which exists specifically to derive instances of read and show. -data SerializableSurface - = XdgSerializeSurface IntPtr - | XWaylandSerializeSurface IntPtr - deriving (Read, Show) - -class ForeignSurface a where - toSurface :: Ptr a -> Surface - -instance ForeignSurface WlrXdgSurface where - toSurface = XdgSurface - -instance ForeignSurface WlrXWaylandSurface where - toSurface = XWaylandSurface - -guardNull :: Ptr a -> Maybe (Ptr a) -guardNull p | p == nullPtr = Nothing -guardNull p = Just p - -foreign import ccall "wlr_seat_set_keyboard" wlrSeatSetKeyboard :: - Ptr WlrSeat -> Ptr WlrInputDevice -> IO () - -foreign import ccall "wlr_seat_get_keyboard" wlrSeatGetKeyboard :: - Ptr WlrSeat -> IO (Ptr WlrKeyboard) - -foreign import ccall "wlr_keyboard_get_modifiers" wlrKeyboardGetModifiers :: - Ptr WlrKeyboard -> IO Word32 - -foreign import ccall "wlr_seat_keyboard_notify_key" - wlrSeatKeyboardNotifyKey :: - Ptr WlrSeat -> Word32 -> Word32 -> Word32 -> IO () diff --git a/plug/src/Wetterhorn/Keys/Macros.hs b/plug/src/Wetterhorn/Keys/Macros.hs deleted file mode 100644 index a794193..0000000 --- a/plug/src/Wetterhorn/Keys/Macros.hs +++ /dev/null @@ -1,145 +0,0 @@ --- There are constraints used for better type-level enforced safety rules. -{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - -module Wetterhorn.Keys.Macros - ( MacroSupport, - macroStartStopKeybind, - macroReplayKeybind, - stopMacroRecording, - startRecording, - ) -where - -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Trans (MonadTrans (lift)) -import Data.Default.Class -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Type.Bool -import Data.Type.Equality -import Data.Word -import Foreign (Ptr) -import GHC.TypeError -import Wetterhorn.Core.KeyEvent -import Wetterhorn.Core.W -import Wetterhorn.Dsl.Input -import Wetterhorn.Foreign.WlRoots (WlrInputDevice) - -data RecordedKey = RecordedKey Word32 Word32 KeyState Word32 Word32 Char - deriving (Read, Show) - -data MacrosState = MacrosState - { macros :: Map String [RecordedKey], - currentlyRecording :: Maybe String - } - deriving (Read, Show) - -instance Default MacrosState where - def = MacrosState mempty def - -instance ExtensionClass MacrosState - -type family Find a ls where - Find b (a : t) = (b == a) || Find b t - Find _ '[] = False - --- | Provides a Vim-esque keybinding behavior for macro recording. --- --- Designed to be used like: --- --- bind ev (Mod1 .+ 'q') macroStartStopKeybind -macroStartStopKeybind :: (HasMacroSupport spy) => InputM spy () -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 :: (HasMacroSupport spy) => InputM spy () -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 - { macros = Map.delete ch macros, - currentlyRecording = Just ch - } - ) - -stopMacroRecording :: (Wlike m) => m () -stopMacroRecording = xmodify (\m -> m {currentlyRecording = Nothing}) - -currentlyRecordingMacro :: (Wlike m) => m (Maybe String) -currentlyRecordingMacro = xgets currentlyRecording - -replayMacro :: Ptr WlrInputDevice -> String -> InputM spy () -replayMacro inputDevice s = do - m <- liftW (Map.lookup s <$> xgets macros) - -- 'tail' is to cut off the last keystroke which stops the recording. - mapM_ (replayEvents . map toInputEvent . reverse . tail) m - where - toInputEvent :: RecordedKey -> InputEvent - toInputEvent (RecordedKey ts kc st mo keysym cp) = - InputKeyEvent $ KeyEvent ts kc st mo keysym cp inputDevice - -pushMacroKey :: (Wlike m) => KeyEvent -> m () -pushMacroKey ke = do - cur <- xgets currentlyRecording - whenJust cur $ \ch -> do - let recordedKey = toRecordedKey ke - in xmodify $ \m@MacrosState {macros = macros} -> - m {macros = Map.insertWith (++) ch [recordedKey] macros} - where - whenJust (Just a) fn = fn a - whenJust _ _ = return () - - toRecordedKey (KeyEvent ts c s m keysym cp _) = RecordedKey ts c s m keysym cp - --- | Phantom type defining a proxy required to support macros. -data MacroSupport - --- | Instance for macro support. -instance InputProxy MacroSupport where - onKeyEvent _ ie = do - lift $ whenKeyEvent ie pushMacroKey - return ie - -class HasMacroSupport t - -instance - ( If - (Find MacroSupport t) - True - ( TypeError - ( Text "This Requires the Macro Proxy to be Enabled." - :<>: Text "Please enable this by adding MacroSupport to your" - :<>: Text "inputProxies list.\n" - :<>: Text "i.e. Change " - :<>: ShowType t - :<>: Text " to " - :<>: ShowType (MacroSupport ': t) - ) - ) - ~ True - ) => - HasMacroSupport t - -instance HasMacroSupport MacroSupport diff --git a/plug/src/Wetterhorn/Keys/MagicModifierKey.hs b/plug/src/Wetterhorn/Keys/MagicModifierKey.hs deleted file mode 100644 index 6bc8bb3..0000000 --- a/plug/src/Wetterhorn/Keys/MagicModifierKey.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Wetterhorn.Keys.MagicModifierKey where - -import Data.Data -import Data.Default.Class -import GHC.TypeNats -import Wetterhorn.Core.KeyEvent -import Wetterhorn.Core.W -import Wetterhorn.Dsl.Bind -import Wetterhorn.Dsl.Input -import Control.Monad.RWS (MonadTrans(lift)) -import Control.Monad.Trans.Maybe (MaybeT(..)) - -data MagicModifierProxy (keycode :: Natural) inputproxy - deriving (Typeable) - -newtype MagicModifierState (keycode :: Natural) = MagicModifierState {isPressed :: Bool} - deriving (Typeable, Eq, Show, Ord, Read) - -instance Default (MagicModifierState k) where - def = MagicModifierState False - -instance (KnownNat k) => ExtensionClass (MagicModifierState k) - -instance - (KnownNat keycode, InputProxy inputproxy) => - InputProxy (MagicModifierProxy keycode inputproxy) - where - onKeyEvent proxy ie = do - case ie of - (InputKeyEvent (KeyEvent {keycode = kc, state = state})) - | fromIntegral kc == natVal (keycodeProxy proxy) -> do - lift $ setMagicModifierPressed proxy (state == KeyPressed) - MaybeT (return Nothing) - _ -> do - pressed <- lift $ isMagicModifierPressed proxy - if pressed - then onKeyEvent (Proxy :: Proxy inputproxy) ie - else return ie - where - keycodeProxy :: Proxy (MagicModifierProxy kc a) -> Proxy kc - keycodeProxy _ = Proxy - - isMagicModifierPressed p = isPressed <$> getModState p - setMagicModifierPressed p = modifyModState p . const - - getModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> W (MagicModifierState kc) - getModState _ = xget - - modifyModState :: (KnownNat kc) => Proxy (MagicModifierProxy kc a) -> (MagicModifierState kc -> Bool) -> W () - modifyModState _ fn = xmodify (MagicModifierState . fn) diff --git a/plug/src/Wetterhorn/Layout/Combine.hs b/plug/src/Wetterhorn/Layout/Combine.hs deleted file mode 100644 index 10a0208..0000000 --- a/plug/src/Wetterhorn/Layout/Combine.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE ViewPatterns #-} - -module Wetterhorn.Layout.Combine where - -import Data.Typeable -import Wetterhorn.Constraints -import Wetterhorn.Core.W - -data (|||) a b = Comb LR a b - deriving (Typeable, Read, Show) - -data Next = Next - deriving (Typeable) - -data Reset = Reset - deriving (Typeable) - -(|||) :: a -> b -> (a ||| b) -a ||| b = Comb L a b - -data LR = L | R deriving (Read, Show, Ord, Eq, Enum) - -instance (HandleMessage a, HandleMessage b) => HandleMessage (a ||| b) where - handleMessage (fromMessage -> Just Next) (Comb L l r) = return (Comb R l r) - handleMessage (fromMessage -> Just Reset) (Comb _ l r) = return (Comb L l r) - handleMessage mesg (Comb L l r) = - Comb L <$> handleMessage mesg l <*> pure r - handleMessage mesg (Comb R l r) = - Comb L l <$> handleMessage mesg r - -instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where - -- In order to use this layout class, the lay-out type 'a' must satisfy BOTH - -- the left and right constraints. - type LayoutConstraint (a ||| b) = LayoutConstraint a &&&& LayoutConstraint b - - runLayout as (Comb R r l) = do - (r', ret) <- runLayout as r - return (Comb R r' l, ret) - runLayout as (Comb L r l) = do - (l', ret) <- runLayout as l - return (Comb R r l', ret) - - serializeLayout (Comb lr l r) = show (Comb lr (serializeLayout l) (serializeLayout r)) - readLayout str = Comb lr <$> l <*> r - where - (Comb lr (readLayout -> l) (readLayout -> r)) = read str - - description (Comb _ l r) = description l ++ " ||| " ++ description r diff --git a/plug/src/Wetterhorn/Layout/Full.hs b/plug/src/Wetterhorn/Layout/Full.hs deleted file mode 100644 index b7e4d91..0000000 --- a/plug/src/Wetterhorn/Layout/Full.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Wetterhorn.Layout.Full where - -import Data.Data (Typeable) -import Data.Default.Class -import Wetterhorn.Constraints -import Wetterhorn.Core.W -import Wetterhorn.StackSet - -data Full = Full - deriving (Read, Show, Typeable) - -instance Default Full where - def = Full - -instance HandleMessage Full - -instance LayoutClass Full where - type LayoutConstraint Full = Unconstrained - - runLayout = pureLayout $ \l _ -> - case l of - (focused -> Just a) -> [(a, RationalRect 1 1 1 1)] - _ -> [] diff --git a/plug/src/Wetterhorn/StackSet.hs b/plug/src/Wetterhorn/StackSet.hs deleted file mode 100644 index 86d1b8e..0000000 --- a/plug/src/Wetterhorn/StackSet.hs +++ /dev/null @@ -1,210 +0,0 @@ -module Wetterhorn.StackSet where - -import Control.Monad (void) -import Data.Monoid (First(..)) -import Control.Monad.Identity -import Control.Monad.Writer (MonadWriter (tell), execWriter) -import Data.Maybe (isJust, mapMaybe) -import Data.Maybe (isJust) - --- | The root datastructure for holding the state of the windows. -data StackSet s sd t l a = StackSet - { -- | The currently selected screen. - current :: Screen s sd t l a, - -- | Remaining visible screens. - visible :: [Screen s sd t l a], - -- | Workspaces that exist, but are not on a screen. - hidden :: [Workspace t l a] - } - deriving (Read, Show, Eq, Ord, Functor) - -class TraverseWorkspace f where - traverseWorkspaces :: - (Applicative m) => (Workspace t l a -> m (Workspace t' l' a')) -> f t l a -> m (f t' l' a') - -traverseWorkspaces_ :: (TraverseWorkspace f, Monad m) => (Workspace t l a -> m ()) -> f t l a -> m () -traverseWorkspaces_ f = void . traverseWorkspaces (\w -> f w >> pure w) - -foldMapWorkspaces :: - (Monoid m, TraverseWorkspace f) => (Workspace t l a -> m) -> f t l a -> m -foldMapWorkspaces fn = execWriter . traverseWorkspaces_ (tell . fn) - -mapWorkspaces :: - (TraverseWorkspace f) => - (Workspace t l a -> Workspace t' l' a') -> - f t l a -> - f t' l' a' -mapWorkspaces fn = runIdentity . traverseWorkspaces (pure . fn) - -instance TraverseWorkspace Workspace where - traverseWorkspaces f = f - -instance TraverseWorkspace (Screen s sd) where - traverseWorkspaces f scr = (\w' -> scr {workspace = w'}) <$> f (workspace scr) - -instance TraverseWorkspace (StackSet s sd) where - traverseWorkspaces f (StackSet cur vis hid) = - StackSet - <$> traverseWorkspaces f cur - <*> traverse (traverseWorkspaces f) vis - <*> traverse (traverseWorkspaces f) hid - -instance Traversable Stack where - traverse f (Stack u d) = - Stack <$> traverse f u <*> traverse f d - -instance (TraverseWorkspace f) => Foldable (f t l) where - foldMap fn = - execWriter - . traverseWorkspaces_ (\(Workspace _ _ s) -> tell (foldMap (fn . windowInSeat) s)) - -instance (Functor (f t l), TraverseWorkspace f) => Traversable (f t l) where - sequenceA = - traverseWorkspaces $ - \(Workspace t l sf) -> Workspace t l <$> traverse sequenceA sf - -class HasFocus f where - focused :: f a -> Maybe a - -data Rectangle = Rectangle Int Int Int Int - deriving (Read, Show, Eq, Ord) - -instance HasFocus (StackSet s sd t l) where - focused (StackSet c _ _) = focused c - -data Screen s sd t l a = Screen - { screenDetail :: sd, - screenId :: s, - workspace :: Workspace t l a - } - deriving (Read, Show, Eq, Ord, Functor) - -instance HasFocus (Screen s sd t l) where - focused (Screen _ _ w) = focused w - --- | Defines where a window should appear. -data WindowSeat a = Floating Rectangle a | Tiled a - deriving (Read, Show, Eq, Ord, Functor, Foldable) - -windowInSeat :: WindowSeat a -> a -windowInSeat (Floating _ a) = a -windowInSeat (Tiled a) = a - -instance Traversable WindowSeat where - sequenceA (Floating r fa) = Floating r <$> fa - sequenceA (Tiled fa) = Tiled <$> fa - -instance HasFocus WindowSeat where - focused (Floating _ a) = Just a - focused (Tiled a) = Just a - -data Workspace t l a = Workspace - { tag :: t, - layout :: l, - stack :: Stack (WindowSeat a) - } - deriving (Read, Show, Eq, Ord, Functor) - -instance HasFocus (Workspace t l) where - focused (Workspace _ _ s) = windowInSeat <$> focused s - -data Stack a = Stack - { -- | The elements above the focused one. - up :: ![a], - -- | The elements below the focused one including the focused one itself. - down :: ![a] - } - deriving (Read, Show, Eq, Ord, Functor, Foldable) - -instance HasFocus Stack where - focused (Stack _ (a : _)) = Just a - focused _ = Nothing - --- | Change the tag in a structure. -mapTag :: (TraverseWorkspace f) => (t -> t') -> f t l a -> f t' l a -mapTag fn = mapWorkspaces (\w -> w {tag = fn (tag w)}) - --- | Change the layout in a structure. -mapLayout :: (TraverseWorkspace f) => (l -> l') -> f t l a -> f t l' a -mapLayout fn = mapWorkspaces (\w -> w {layout = fn (layout w)}) - --- | Return all the tags in a structure. -tags :: (TraverseWorkspace f) => f t l a -> [t] -tags = foldMapWorkspaces ((: []) . tag) - --- | Insert a new window into the StackSet. The optional rectangle indicates if --- the window should be floating or tiled. --- --- The window is inserted just above the the currently focused window and is --- given focus. -insert :: a -> Maybe Rectangle -> StackSet s sd t l a -> StackSet s sd t l a -insert win rect = - runIdentity - . onCurrentStack - ( \(Stack u d) -> - return $ - (\w -> Stack u (w : d)) $ - maybe (Tiled win) (`Floating` win) rect - ) - --- | Find the tag associated with a window. -findTag :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Maybe t -findTag a = - getFirst - . foldMapWorkspaces - ( \ws -> - foldMap - ( \a' -> - First $ if a' == a then Just (tag ws) else Nothing - ) - ws - ) - --- | Return true if the window exist in a structure -elem :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Bool -elem a = isJust . findTag a - --- | Convenience function for inserting a window in stack set tiled. -insertTiled :: a -> StackSet s sd t l a -> StackSet s sd t l a -insertTiled win = insert win Nothing - -integrate :: Stack a -> [a] -integrate (Stack u d) = u ++ d - -differentiate :: [a] -> Stack a -differentiate = Stack [] - -applyStack :: - (Monad m) => - (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) -> - Workspace t l a -> - m (Workspace t l a) -applyStack fn (Workspace t l s) = Workspace t l <$> fn s - --- | Apply a function to the currently focused stack. -onCurrentStack :: - (Monad m) => - (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) -> - StackSet s sd t l a -> - m (StackSet s sd t l a) -onCurrentStack fn (StackSet cur vis hid) = - StackSet <$> cur' cur <*> pure vis <*> pure hid - where - cur' (Screen s sd ws) = Screen s sd <$> ws' ws - ws' (Workspace t l s) = Workspace t l <$> fn s - -catMaybes :: StackSet s sd t l (Maybe a) -> StackSet s sd t l a -catMaybes (StackSet cur hidden visible) = - StackSet (catMaybesS cur) (map catMaybesS hidden) (map catMaybesW visible) - where - catMaybesS (Screen a b ws) = Screen a b $ catMaybesW ws - catMaybesW (Workspace a b st) = Workspace a b $ catMaybesSt st - catMaybesSt (Stack up down) = - Stack (mapMaybe sequenceA up) (mapMaybe sequenceA down) - -filter :: (a -> Bool) -> StackSet s sd t l a -> StackSet s sd t l a -filter ffn = - Wetterhorn.StackSet.catMaybes . fmap (\a -> if ffn a then Just a else Nothing) - -delete :: (Eq a) => a -> StackSet s sd t l a -> StackSet s sd t l a -delete win = Wetterhorn.StackSet.filter (/=win) diff --git a/plug/src/harness_adapter.c b/plug/src/harness_adapter.c index 24b813c..0c27c91 100644 --- a/plug/src/harness_adapter.c +++ b/plug/src/harness_adapter.c @@ -9,7 +9,7 @@ #include #include -const char *plugin_name = "Wetterhorn"; +const char *plugin_name = "Montis"; void* foreign_interface; @@ -42,9 +42,9 @@ void shell_exec(const char* cmd) { } static const char msg[] = - "Wetterhorn Plugin v 0.01\n\n" + "Montis Plugin v 0.01\n\n" "Welcome, and thank you for your interest.\n\n" - "This is merely a plugin to the Wetterhorn Compositor and not meant to be\n" + "This is merely a plugin to the Montis Compositor and not meant to be\n" "executed as a standalone binary. This plugin requires a harness to run\n" "To use this file, please use './wtr_harness [full-path-to-wtr.so]'\n" "That will allow you to see how this compositor works in all its glory!\n"; -- cgit