diff options
Diffstat (limited to 'plug/src')
22 files changed, 2504 insertions, 0 deletions
diff --git a/plug/src/Config.hs b/plug/src/Config.hs new file mode 100644 index 0000000..e76e6ea --- /dev/null +++ b/plug/src/Config.hs @@ -0,0 +1,88 @@ +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 + +config :: Config WindowLayout +config = + defaultConfig + { hooks = + defaultHooks + { surfaceHook = do + handleSurface + }, + layout = WindowLayout Full, + resetHook = do + useInputHandler $ + withProxies inputProxies $ do + ev <- nextInputEvent + + bind ev (released btnLeft) $ + run $ + wio $ + putStrLn "Left Button Released!!" + + unless (isPressEvent ev) $ do + forwardEvent ev + continue + + bind ev (Shift .+ Mod1 .+ 'R') $ run requestHotReload + + bind ev (Mod1 .+ 't') $ run (shellExec "alacritty") + + bind ev (Mod1 .+ 'p') $ do + ev2 <- nextInputPressEvent + + bind ev2 (Mod1 .+ 'p') $ + run $ + wio $ + putStrLn "Test" + + bind ev (Mod1 .+ btnLeft) $ + run $ + wio $ + putStrLn "Left Button Press!!" + + bind ev (Mod1 .+ 'q') macroStartStopKeybind + + bind ev (weak $ Mod1 .+ '@') macroReplayKeybind + + bind ev (weak $ ModX 5 .+ btnLeft) $ + run $ + wio $ + putStrLn "Fake Modifier With Button!!!" + + bind ev (weak $ ModX 5 .+ 't') $ + run $ + wio $ + putStrLn "Fake Modifier!!" + + forwardEvent ev + } + where + inputProxies :: + Proxy + '[ MacroSupport, + MagicModifierProxy 59 SetXtra -- Only log keys when F1 (keycode 59 is pressed) + ] + inputProxies = Proxy + +data SetXtra + +instance InputProxy SetXtra where + onKeyEvent _ ie = + case ie of + (InputKeyEvent ke@(KeyEvent {KeyEvent.modifiers = modifiers})) -> + return $ InputKeyEvent ke {KeyEvent.modifiers = modifiers .|. modifierToMask (ModX 5)} + (InputButtonEvent be@(ButtonEvent {ButtonEvent.modifiers = modifiers})) -> + return $ InputButtonEvent be {ButtonEvent.modifiers = modifiers .|. modifierToMask (ModX 5)} + _ -> return ie diff --git a/plug/src/Lib.hs b/plug/src/Lib.hs new file mode 100644 index 0000000..d36ff27 --- /dev/null +++ b/plug/src/Lib.hs @@ -0,0 +1,6 @@ +module Lib + ( someFunc + ) where + +someFunc :: IO () +someFunc = putStrLn "someFunc" diff --git a/plug/src/Wetterhorn/Constraints.hs b/plug/src/Wetterhorn/Constraints.hs new file mode 100644 index 0000000..129fd6c --- /dev/null +++ b/plug/src/Wetterhorn/Constraints.hs @@ -0,0 +1,13 @@ +-- | 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 new file mode 100644 index 0000000..d853191 --- /dev/null +++ b/plug/src/Wetterhorn/Core.hs @@ -0,0 +1,152 @@ +{-# 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 new file mode 100644 index 0000000..cc3d905 --- /dev/null +++ b/plug/src/Wetterhorn/Core/ButtonEvent.hs @@ -0,0 +1,15 @@ +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 new file mode 100644 index 0000000..77d273f --- /dev/null +++ b/plug/src/Wetterhorn/Core/KeyEvent.hs @@ -0,0 +1,22 @@ +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 new file mode 100644 index 0000000..54d7125 --- /dev/null +++ b/plug/src/Wetterhorn/Core/Keys.hs @@ -0,0 +1,239 @@ +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 new file mode 100644 index 0000000..3e7eaf3 --- /dev/null +++ b/plug/src/Wetterhorn/Core/SurfaceEvent.hs @@ -0,0 +1,16 @@ +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 new file mode 100644 index 0000000..862f9fa --- /dev/null +++ b/plug/src/Wetterhorn/Core/W.hs @@ -0,0 +1,379 @@ +{-# 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 new file mode 100644 index 0000000..0b6adaf --- /dev/null +++ b/plug/src/Wetterhorn/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 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 new file mode 100644 index 0000000..c3e049c --- /dev/null +++ b/plug/src/Wetterhorn/Dsl/Buttons.hsc @@ -0,0 +1,229 @@ +module Wetterhorn.Dsl.Buttons where + +import Data.Word + +#include </usr/include/linux/input-event-codes.h> + +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 new file mode 100644 index 0000000..1a0c294 --- /dev/null +++ b/plug/src/Wetterhorn/Dsl/Input.hs @@ -0,0 +1,286 @@ +{-# 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 new file mode 100644 index 0000000..2d0a42c --- /dev/null +++ b/plug/src/Wetterhorn/Foreign.hs @@ -0,0 +1,18 @@ +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 new file mode 100644 index 0000000..51bd72b --- /dev/null +++ b/plug/src/Wetterhorn/Foreign/Export.hs @@ -0,0 +1,208 @@ +-- | 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 new file mode 100644 index 0000000..471e3a9 --- /dev/null +++ b/plug/src/Wetterhorn/Foreign/ForeignInterface.hs @@ -0,0 +1,81 @@ +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 new file mode 100644 index 0000000..0581b77 --- /dev/null +++ b/plug/src/Wetterhorn/Foreign/WlRoots.hs @@ -0,0 +1,67 @@ +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 new file mode 100644 index 0000000..a794193 --- /dev/null +++ b/plug/src/Wetterhorn/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 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 new file mode 100644 index 0000000..6bc8bb3 --- /dev/null +++ b/plug/src/Wetterhorn/Keys/MagicModifierKey.hs @@ -0,0 +1,50 @@ +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 new file mode 100644 index 0000000..10a0208 --- /dev/null +++ b/plug/src/Wetterhorn/Layout/Combine.hs @@ -0,0 +1,48 @@ +{-# 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 new file mode 100644 index 0000000..b7e4d91 --- /dev/null +++ b/plug/src/Wetterhorn/Layout/Full.hs @@ -0,0 +1,23 @@ +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 new file mode 100644 index 0000000..86d1b8e --- /dev/null +++ b/plug/src/Wetterhorn/StackSet.hs @@ -0,0 +1,210 @@ +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 new file mode 100644 index 0000000..24b813c --- /dev/null +++ b/plug/src/harness_adapter.c @@ -0,0 +1,81 @@ +// This file provides functions for the wetterhorn harness that are not +// expressible directly in haskell. +// +// Currently these functions exclusively enable/disable the Haskell runtime. + +#include "HsFFI.h" +#include "plugin_interface.h" +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> + +const char *plugin_name = "Wetterhorn"; + +void* foreign_interface; + +void* get_foreign_interface() +{ + return foreign_interface; +} + +extern void performMajorGC(); + +void plugin_metaload(int argc, char** argv) +{ + // hs_init(&argc, &argv); +} + +void plugin_load(int argc, char **argv, foreign_interface_t* fintf) { + hs_init(&argc, &argv); + foreign_interface = fintf; +} + +void plugin_teardown(opqst_t st) { + hs_exit(); +} + +void shell_exec(const char* cmd) { + if (fork() == 0) { + execl("/bin/sh", "/bin/sh", "-c", cmd, NULL); + exit(1); + } +} + +static const char msg[] = + "Wetterhorn 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" + "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"; +static const int msg_sz = sizeof(msg); + +/* + * Implemens a basic _start that prints inforamtion and exits for users on an + * x86_64 system. + */ +__attribute__((naked)) void _start() +{ + + // Make system call to print the message + asm( + // Load the address of the string into rsi + "mov %0, %%rsi\n" + // Load the string length into edx + "mov %1, %%edx\n" + // Load the file descriptor for stdout into edi + "mov $1, %%edi\n" + // Load the syscall number for sys_write into eax + "mov $1, %%eax\n" + // Make the syscall + "syscall\n" + + // Exit the program. + "mov $0, %%rdi\n" + "mov $60, %%rax\n" + "syscall\n" + : + : "r"(msg), "r"(msg_sz) // Input: address of msg + : "%rsi", "%edx", "%edi" // Clobbered registers + ); +} |