aboutsummaryrefslogtreecommitdiff
path: root/plug/src
diff options
context:
space:
mode:
Diffstat (limited to 'plug/src')
-rw-r--r--plug/src/Config.hs3
-rw-r--r--plug/src/Montis/Core.hs513
-rw-r--r--plug/src/Montis/Core/Keys.hs1
-rw-r--r--plug/src/Montis/Core/Runtime.hs26
-rw-r--r--plug/src/Montis/Core/W.hs34
-rw-r--r--plug/src/Montis/Dsl/Input.hs15
-rw-r--r--plug/src/Montis/Foreign/Export.hs19
-rw-r--r--plug/src/Montis/Foreign/ForeignInterface.hs61
-rw-r--r--plug/src/Montis/Foreign/Import.hs13
-rw-r--r--plug/src/harness_adapter.c10
10 files changed, 437 insertions, 258 deletions
diff --git a/plug/src/Config.hs b/plug/src/Config.hs
index 153c483..70920fd 100644
--- a/plug/src/Config.hs
+++ b/plug/src/Config.hs
@@ -11,6 +11,7 @@ import Montis.Dsl.Input
import Montis.Keys.Macros
import Montis.Keys.MagicModifierKey
import Montis.Layout.Full
+import Montis.Core.Runtime (requestHotReload)
config :: Config WindowLayout
config =
@@ -37,7 +38,7 @@ config =
bind ev (Shift .+ Mod1 .+ 'R') $ run requestHotReload
- bind ev (Mod1 .+ 't') $ run (shellExec "alacritty")
+ -- bind ev (Mod1 .+ 't') $ run (shellExec "alacritty")
bind ev (Mod1 .+ 'p') $ do
ev2 <- nextInputPressEvent
diff --git a/plug/src/Montis/Core.hs b/plug/src/Montis/Core.hs
index 24d7f12..e01d2f7 100644
--- a/plug/src/Montis/Core.hs
+++ b/plug/src/Montis/Core.hs
@@ -2,151 +2,370 @@
module Montis.Core where
--- ( WState (..),
--- WConfig (..),
--- SurfaceState (..),
--- W,
--- getWConfig,
--- getWState,
--- runW,
--- Montis,
--- initMontis,
--- wio,
--- incrementState,
--- readWState,
--- defaultConfig,
--- requestHotReload,
--- ctxConfig,
--- KeyEvent (..),
--- KeyState (..),
--- )
-
--- import Control.Arrow (first)
--- import Control.Exception
--- import Data.ByteString (ByteString)
--- import Data.Char (ord)
--- import Data.Map (Map)
--- import Foreign (Ptr, StablePtr, Word32, newStablePtr)
--- import Text.Printf
--- import Montis.Foreign.ForeignInterface (ForeignInterface)
--- import Montis.Foreign.WlRoots
--- import qualified Data.ByteString.Char8 as CH
--- import qualified Data.Map as Map
--- import qualified Montis.Foreign.ForeignInterface as ForeignInterface
---
--- data WContext = WContext
--- { ctxForeignInterface :: ForeignInterface,
--- ctxConfig :: WConfig
--- }
---
--- -- This is the OpaqueState passed to the harness.
--- type Montis = StablePtr (WContext, WState)
---
--- requestHotReload :: W ()
--- requestHotReload = do
--- fi <- ctxForeignInterface <$> getWContext
--- wio $ ForeignInterface.requestHotReload fi
---
--- requestLog :: String -> W ()
--- requestLog str = do
--- fi <- ctxForeignInterface <$> getWContext
--- wio $ ForeignInterface.requestLog fi str
---
--- requestExit :: Int -> W ()
--- requestExit ec = do
--- fi <- ctxForeignInterface <$> getWContext
--- wio $ ForeignInterface.requestExit fi ec
---
--- initMontis :: WConfig -> IO Montis
--- initMontis conf = do
--- foreignInterface <- ForeignInterface.getForeignInterface
--- newStablePtr (WContext foreignInterface conf, WState "this is a string" 0)
---
--- defaultBindings :: Map (KeyState, Word32, Word32) (W ())
--- defaultBindings =
--- Map.fromList
--- [ ((KeyPressed, 0x9, sym 'Q'), requestHotReload),
--- ((KeyPressed, 0x8, sym 'r'), wio $ ForeignInterface.doShellExec "wofi --show run"),
--- ((KeyPressed, 0x8, sym 'l'), requestLog "This is a log statement!\n"),
--- ((KeyPressed, 0x8, sym 't'), wio $ ForeignInterface.doShellExec "alacritty"),
--- ((KeyPressed, 0x9, sym 'T'), wio $ ForeignInterface.doShellExec "gnome-terminal"),
--- ((KeyPressed, 0x8, sym 'c'), wio $ ForeignInterface.doShellExec "pavucontrol"),
--- ( (KeyPressed, 0x8, sym 'p'),
--- wio $ do
--- putStrLn "Maps:"
--- putStrLn =<< readFile "/proc/self/maps"
--- ),
--- ((KeyPressed, 0x8, sym 'q'), requestExit 0)
--- ]
--- where
--- sym = fromIntegral . ord
---
--- defaultConfig :: WConfig
--- defaultConfig =
--- WConfig
--- { keybindingHandler = \keyEvent -> do
--- seatPtr <- (wio . ForeignInterface.getSeat . ctxForeignInterface) =<< getWContext
---
--- maybe
--- ( wio $ do
--- wlrSeatSetKeyboard seatPtr (device keyEvent)
--- wlrSeatKeyboardNotifyKey
--- seatPtr
--- (timeMs keyEvent)
--- (keycode keyEvent)
--- ( case state keyEvent of
--- KeyReleased -> 0
--- _ -> 1
--- )
---
--- return True
--- )
--- (fmap (const True))
--- $ Map.lookup
--- (state keyEvent, modifiers keyEvent, keysym keyEvent)
--- defaultBindings,
--- surfaceHandler = \state surface -> wio (printf "Surface %s is %s\n" (show surface) (show state))
--- }
---
--- readWState :: ByteString -> IO WState
--- readWState bs =
--- catch
--- (return $ read (CH.unpack bs))
--- ( \e ->
--- let _ = (e :: SomeException) in return (WState "" 0)
--- )
---
--- newtype W a = W ((WContext, WState) -> IO (a, WState))
---
--- instance Functor W where
--- fmap mfn (W fn) = W $ fmap (first mfn) <$> fn
---
--- instance Applicative W where
--- pure a = W $ \(_, s) -> return (a, s)
--- mfn <*> ma = do
--- fn <- mfn
--- fn <$> ma
---
--- instance Monad W where
--- (W fntoa) >>= fnmb = W $ \(config, state) -> do
--- (a, state') <- fntoa (config, state)
--- let W fntob = fnmb a
--- fntob (config, state')
---
--- getWContext :: W WContext
--- getWContext = W pure
---
--- getWConfig :: W WConfig
--- getWConfig = ctxConfig <$> getWContext
---
--- getWState :: W WState
--- getWState = W $ \(_, s) -> pure (s, s)
---
--- runW :: W a -> (WContext, WState) -> IO (a, WState)
--- runW (W fn) = fn
---
--- incrementState :: W Int
--- incrementState = W $ \(_, WState s i) -> return (i, WState s (i + 1))
+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.Maybe
+import Data.Data (Typeable, cast, tyConModule, tyConName, tyConPackage)
+import Data.Default.Class (Default, def)
+import Data.Kind (Constraint, Type)
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Proxy
+import Data.Set (Set)
+import Data.Set qualified as Set
+import Data.Singletons.Decide (Void)
+import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr)
+import Montis.Core.ButtonEvent (ButtonEvent)
+import Montis.Core.KeyEvent
+import Montis.Core.SurfaceEvent
+import Montis.Foreign.ForeignInterface qualified as ForeignInterface
+import Montis.Foreign.WlRoots (Surface, WlrSeat)
+import Montis.StackSet hiding (layout)
+import Montis.StackSet qualified as StackSet
+import Text.Printf (printf)
+import Text.Read hiding (lift)
+import Type.Reflection (someTypeRep, someTypeRepTyCon)
+
+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 Plugin
+
+-- Read-only context under which montis is run under.
+data Context = Context
+ { ctxConfig :: Config WindowLayout,
+ ctxPluginPtr :: Ptr Plugin
+ }
+
+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.
--
--- wio :: IO a -> W a
--- wio fn = W $ \(_, b) -> fn >>= \a -> return (a, b)
+-- 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 conf pluginPtr) -> Context (fn conf) pluginPtr
+ )
+ r
+ ask = W $ ctxConfig <$> ask
+
+runW :: W a -> (Context, State) -> IO (a, State)
+runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st
+
+wio :: IO a -> W a
+wio = liftIO
+
+-- | Type class to lift an arbitrary 'W' computation into another monad.
+class (Monad m) => Wlike m where
+ liftW :: W a -> m a
+
+-- | Trivial instance of W for Wlike.
+instance Wlike W where
+ liftW = id
+
+-- Default implementations for common handlers.
+
+-- | handles a new surface event. This updates the state to reflect how it
+-- should look in the harness.
+handleSurface :: SurfaceEvent -> W ()
+handleSurface (SurfaceEvent state (Window -> win)) =
+ case state of
+ Destroy ->
+ modify $
+ \st@State
+ { allWindows = allWindows,
+ mapped = mapped
+ } ->
+ st
+ { allWindows = Set.delete win allWindows,
+ mapped = StackSet.delete win mapped
+ }
+ Unmap -> modify $
+ \st@State {mapped = mapped} ->
+ st
+ { mapped = StackSet.delete win mapped
+ }
+ Map -> modify $
+ \st@State {mapped = mapped, allWindows = allWindows} ->
+ st
+ { mapped = StackSet.insertTiled win mapped,
+ allWindows = Set.insert win allWindows
+ }
diff --git a/plug/src/Montis/Core/Keys.hs b/plug/src/Montis/Core/Keys.hs
index c9291e4..fb55cc6 100644
--- a/plug/src/Montis/Core/Keys.hs
+++ b/plug/src/Montis/Core/Keys.hs
@@ -15,6 +15,7 @@ import Montis.Core.KeyEvent
import qualified Montis.Core.KeyEvent as KeyEvent
import Montis.Core.W
import Montis.Foreign.WlRoots (wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
+import Montis.Core.Runtime (getSeat)
-- | Forwards the given key event to the focused window.
forwardKey :: KeyEvent -> W ()
diff --git a/plug/src/Montis/Core/Runtime.hs b/plug/src/Montis/Core/Runtime.hs
new file mode 100644
index 0000000..6521fba
--- /dev/null
+++ b/plug/src/Montis/Core/Runtime.hs
@@ -0,0 +1,26 @@
+module Montis.Core.Runtime where
+
+import Control.Monad.RWS (MonadReader (ask))
+import Data.Void (Void)
+import Foreign (Ptr, castPtr)
+import Montis.Core.W
+import Montis.Foreign.Import
+import Montis.Foreign.WlRoots (WlrSeat)
+
+requestHotReload :: W ()
+requestHotReload = do
+ Context {ctxPlugin = plug} <- W ask
+ wio $ foreign_doRequestHotReload plug
+
+requestLog :: String -> W ()
+requestLog = undefined
+
+requestExit :: Int -> W ()
+requestExit = undefined
+
+newtype Seat = Seat (Ptr Void)
+
+getSeat :: W (Ptr WlrSeat)
+getSeat = do
+ Context {ctxPlugin = plug} <- W ask
+ wio $ castPtr <$> foreign_getSeat plug
diff --git a/plug/src/Montis/Core/W.hs b/plug/src/Montis/Core/W.hs
index 9235b2f..3aac22a 100644
--- a/plug/src/Montis/Core/W.hs
+++ b/plug/src/Montis/Core/W.hs
@@ -13,20 +13,20 @@ import Data.Data (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.Map qualified as M
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Proxy
import Data.Set (Set)
-import qualified Data.Set as Set
+import Data.Set qualified as Set
+import Data.Void (Void)
import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr)
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.ForeignInterface qualified as ForeignInterface
import Montis.Foreign.WlRoots (Surface, WlrSeat)
import Montis.StackSet hiding (layout)
-import qualified Montis.StackSet as StackSet
+import Montis.StackSet qualified as StackSet
import Text.Printf (printf)
import Text.Read hiding (lift)
import Type.Reflection (someTypeRep, someTypeRepTyCon)
@@ -107,7 +107,7 @@ handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l
readWindowLayout :: WindowLayout -> String -> WindowLayout
readWindowLayout (WindowLayout l) s
| (Just x) <- readLayout s =
- WindowLayout (asTypeOf x l)
+ WindowLayout (asTypeOf x l)
readWindowLayout l _ = l
-- | Serializes a window layout to a string.
@@ -130,9 +130,10 @@ instance Show (ReadPtr a) where
type Montis = StablePtr (Context, State)
+-- Read-only context under which montis is run under.
data Context = Context
- { ctxForeignInterface :: ForeignInterface,
- ctxConfig :: Config WindowLayout
+ { ctxConfig :: Config WindowLayout,
+ ctxPlugin :: Ptr Void
}
defaultHooks :: Hooks
@@ -317,27 +318,12 @@ newtype W a = W (ReaderT Context (StateT State IO) a)
-- | 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
+ local fn (W r) = W $ local (\(Context conf plug) -> Context (fn conf) plug) r
ask = W $ ctxConfig <$> ask
runW :: W a -> (Context, State) -> IO (a, State)
runW (W fn) (ctx, st) = runStateT (runReaderT fn ctx) st
-foreignInterface :: W ForeignInterface
-foreignInterface = W $ ctxForeignInterface <$> ask
-
-getSeat :: W (Ptr WlrSeat)
-getSeat = (wio . ForeignInterface.getSeat) =<< foreignInterface
-
-requestHotReload :: W ()
-requestHotReload = (wio . ForeignInterface.requestHotReload) =<< foreignInterface
-
-requestExit :: Int -> W ()
-requestExit ec = (wio . flip ForeignInterface.requestExit ec) =<< foreignInterface
-
-shellExec :: String -> W ()
-shellExec = wio . ForeignInterface.doShellExec
-
wio :: IO a -> W a
wio = liftIO
diff --git a/plug/src/Montis/Dsl/Input.hs b/plug/src/Montis/Dsl/Input.hs
index a295a19..1ead0c7 100644
--- a/plug/src/Montis/Dsl/Input.hs
+++ b/plug/src/Montis/Dsl/Input.hs
@@ -42,11 +42,12 @@ import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Proxy
import Data.Word (Word32)
-import qualified Montis.Core.ButtonEvent as ButtonEvent
-import qualified Montis.Core.KeyEvent as KeyEvent
+import Montis.Core.ButtonEvent qualified as ButtonEvent
+import Montis.Core.KeyEvent qualified as KeyEvent
import Montis.Core.W (W (..))
-import qualified Montis.Core.W as W
+import Montis.Core.W qualified as W
import Montis.Foreign.WlRoots (guardNull, wlrKeyboardGetModifiers, wlrSeatGetKeyboard, wlrSeatKeyboardNotifyKey, wlrSeatSetKeyboard)
+import Montis.Core.Runtime (getSeat)
class InputProxy (spy :: k) where
onKeyEvent :: Proxy spy -> InputEvent -> MaybeT W InputEvent
@@ -100,7 +101,7 @@ continue = do
-- | Forwards the given key event to the focused window.
forwardKey :: KeyEvent.KeyEvent -> W ()
forwardKey keyEvent = do
- seatPtr <- W.getSeat
+ seatPtr <- getSeat
W.wio $ do
wlrSeatSetKeyboard
seatPtr
@@ -193,10 +194,10 @@ isKeyEvent _ = False
isPressEvent :: InputEvent -> Bool
isPressEvent (InputButtonEvent be)
| ButtonEvent.state be == ButtonEvent.ButtonPressed =
- True
+ True
isPressEvent (InputKeyEvent ke)
| KeyEvent.state ke == KeyEvent.KeyPressed =
- True
+ True
isPressEvent _ = False
-- | Returns the event only if it matches the filter. If it does not match the
@@ -207,7 +208,7 @@ filterEvent _ _ = continue
getModifierState :: W Word32
getModifierState = do
- seat <- W.getSeat
+ seat <- getSeat
keyboard <- W.wio $ wlrSeatGetKeyboard seat
maybe (return 0) (W.wio . wlrKeyboardGetModifiers) (guardNull keyboard)
diff --git a/plug/src/Montis/Foreign/Export.hs b/plug/src/Montis/Foreign/Export.hs
index 2bef0e9..bb8efeb 100644
--- a/plug/src/Montis/Foreign/Export.hs
+++ b/plug/src/Montis/Foreign/Export.hs
@@ -27,6 +27,7 @@ import Montis.Core.W (Montis, W)
import qualified Montis.Core.W as W
import Montis.Foreign.ForeignInterface
import Montis.Foreign.WlRoots
+import Data.Void (Void)
type Wetter = (W.Config W.WindowLayout, W.State)
@@ -69,15 +70,14 @@ runForeignWithReturn2 fn ptrA ptrB stableptr = do
-- this function returns a Montis instance.
foreign export ccall "plugin_hot_start"
pluginHotStart ::
- Ptr CChar -> Word32 -> IO Montis
+ Ptr Void -> Ptr CChar -> Word32 -> IO Montis
-pluginHotStart :: Ptr CChar -> Word32 -> IO Montis
-pluginHotStart chars len = do
+pluginHotStart :: Ptr Void -> Ptr CChar -> Word32 -> IO Montis
+pluginHotStart self chars len = do
bs <- BS.packCStringLen (chars, fromIntegral len)
- foreignInterface <- getForeignInterface
wtr <-
newStablePtr
- ( W.Context foreignInterface config,
+ ( W.Context config self,
W.demarshalState config (CH.unpack bs)
)
runForeign (\(conf, _) -> W.resetHook conf) wtr
@@ -86,13 +86,12 @@ pluginHotStart chars len = do
-- calles the function "wetterhorn". This function should be defined in the main
-- code as it's sort-of the equivalent of XMonad's "main" function.
foreign export ccall "plugin_cold_start"
- pluginColdStart :: IO Montis
+ pluginColdStart :: Ptr Void -> IO Montis
-pluginColdStart :: IO Montis
-pluginColdStart = do
- foreignInterface <- getForeignInterface
+pluginColdStart :: Ptr Void -> IO Montis
+pluginColdStart self = do
state <- W.initColdState config
- wtr <- newStablePtr (W.Context foreignInterface config, state)
+ wtr <- newStablePtr (W.Context config self, state)
runForeign (\(conf, _) -> W.resetHook conf) wtr
-- | Marshals the opaque state to a C-style byte array and size pointer.
diff --git a/plug/src/Montis/Foreign/ForeignInterface.hs b/plug/src/Montis/Foreign/ForeignInterface.hs
index c01e6b8..647fb98 100644
--- a/plug/src/Montis/Foreign/ForeignInterface.hs
+++ b/plug/src/Montis/Foreign/ForeignInterface.hs
@@ -1,20 +1,12 @@
module Montis.Foreign.ForeignInterface
- ( getForeignInterface,
- ForeignInterface (..),
- ForeignDemarshal (..),
+ ( ForeignDemarshal (..),
runForeignDemarshal,
demarshal,
- doShellExec,
)
where
import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT)
-import Data.Void (Void)
import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
-import Foreign.C (CChar, CInt (..))
-import Foreign.C.String
-import GHC.Exts (FunPtr)
-import Montis.Foreign.WlRoots
newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a)
deriving (Functor, Monad, Applicative, MonadState (Ptr ()))
@@ -28,54 +20,3 @@ demarshal = do
val <- ForeignDemarshal $ lift $ peek $ castPtr ptr
put (plusPtr ptr (sizeOf val))
return val
-
-type CtxT = Ptr Void
-
-type ForeignCallGetPtr = CtxT -> IO (Ptr ())
-
-type ForeignCall = CtxT -> IO ()
-
-type ForeignCallStr = CtxT -> CString -> IO ()
-
-type ForeignCallInt = CtxT -> CInt -> IO ()
-
-foreign import ccall "get_foreign_interface" foreignInterfacePtr :: IO (Ptr ())
-
-foreign import ccall "dynamic" toForeignCall :: FunPtr ForeignCall -> ForeignCall
-
-foreign import ccall "dynamic" toForeignCallStr :: FunPtr ForeignCallStr -> ForeignCallStr
-
-foreign import ccall "dynamic" toForeignCallInt :: FunPtr ForeignCallInt -> ForeignCallInt
-
-foreign import ccall "dynamic" toForeignCallGetPtr :: FunPtr ForeignCallGetPtr -> ForeignCallGetPtr
-
-foreign import ccall "shell_exec" shellExec :: Ptr CChar -> IO ()
-
-data ForeignInterface = ForeignInterface
- { requestHotReload :: IO (),
- requestLog :: String -> IO (),
- requestExit :: Int -> IO (),
- getSeat :: IO (Ptr WlrSeat)
- }
-
-doShellExec :: String -> IO ()
-doShellExec str = withCString str shellExec
-
-getForeignInterface :: IO ForeignInterface
-getForeignInterface = do
- ptr <- foreignInterfacePtr
- runForeignDemarshal ptr $ do
- ctx <- demarshal
- requestHotReloadFn <- demarshal
- doLogFn <- demarshal
- doRequestExit <- demarshal
- getSeatFn <- demarshal
-
- return $
- ForeignInterface
- { requestHotReload = toForeignCall requestHotReloadFn ctx,
- requestLog = \str ->
- withCString str $ \cs -> toForeignCallStr doLogFn ctx cs,
- requestExit = toForeignCallInt doRequestExit ctx . fromIntegral,
- getSeat = castPtr <$> toForeignCallGetPtr getSeatFn ctx
- }
diff --git a/plug/src/Montis/Foreign/Import.hs b/plug/src/Montis/Foreign/Import.hs
new file mode 100644
index 0000000..e83841b
--- /dev/null
+++ b/plug/src/Montis/Foreign/Import.hs
@@ -0,0 +1,13 @@
+module Montis.Foreign.Import where
+
+import Data.Void
+import Foreign.C (CInt (..), CString)
+import Foreign.Ptr
+
+foreign import ccall "montis_do_request_hot_reload" foreign_doRequestHotReload :: Ptr Void -> IO ()
+
+foreign import ccall "montis_do_request_log" foreign_doRequestLog :: Ptr Void -> CString -> IO ()
+
+foreign import ccall "montis_do_request_exit" foregin_doExit :: Ptr Void -> CInt -> IO ()
+
+foreign import ccall "montis_plugin_get_seat" foreign_getSeat :: Ptr Void -> IO (Ptr Void)
diff --git a/plug/src/harness_adapter.c b/plug/src/harness_adapter.c
index 0c27c91..db5e7ce 100644
--- a/plug/src/harness_adapter.c
+++ b/plug/src/harness_adapter.c
@@ -11,13 +11,6 @@
const char *plugin_name = "Montis";
-void* foreign_interface;
-
-void* get_foreign_interface()
-{
- return foreign_interface;
-}
-
extern void performMajorGC();
void plugin_metaload(int argc, char** argv)
@@ -25,9 +18,8 @@ void plugin_metaload(int argc, char** argv)
// hs_init(&argc, &argv);
}
-void plugin_load(int argc, char **argv, foreign_interface_t* fintf) {
+void plugin_load(int argc, char **argv) {
hs_init(&argc, &argv);
- foreign_interface = fintf;
}
void plugin_teardown(opqst_t st) {
generated by cgit (git 2.34.1) at 2026-01-10 22:29:24 +0000