diff options
Diffstat (limited to 'plug/src/Montis/Core')
| -rw-r--r-- | plug/src/Montis/Core/ButtonEvent.hs | 15 | ||||
| -rw-r--r-- | plug/src/Montis/Core/KeyEvent.hs | 22 | ||||
| -rw-r--r-- | plug/src/Montis/Core/Keys.hs | 239 | ||||
| -rw-r--r-- | plug/src/Montis/Core/SurfaceEvent.hs | 16 | ||||
| -rw-r--r-- | plug/src/Montis/Core/W.hs | 379 |
5 files changed, 671 insertions, 0 deletions
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 + } |