[wip] rewrite plugin to a more scalable architecture.

33 files changed, 583 insertions, 2607 deletions

diff --git a/plug/src/Config.hs b/plug/src/Config.hs
index 70920fd..0904ded 100644
--- a/plug/src/Config.hs
+++ b/plug/src/Config.hs
@@ -1,88 +1,18 @@
-module Config (config) where
+module Config () where
 
-import Control.Monad (unless)
-import Data.Bits
-import Data.Data (Proxy (Proxy))
-import Montis.Core.ButtonEvent as ButtonEvent
-import Montis.Core.KeyEvent as KeyEvent
-import Montis.Core.W
-import Montis.Dsl.Bind
-import Montis.Dsl.Input
-import Montis.Keys.Macros
-import Montis.Keys.MagicModifierKey
-import Montis.Layout.Full
-import Montis.Core.Runtime (requestHotReload)
+import Montis.Core
 
-config :: Config WindowLayout
-config =
-  defaultConfig
-    { hooks =
-        defaultHooks
-          { surfaceHook = do
-              handleSurface
-          },
-      layout = WindowLayout Full,
-      resetHook = do
-        useInputHandler $
-          withProxies inputProxies $ do
-            ev <- nextInputEvent
+foreign export ccall "plugin_cold_start"
+  coldStart :: MontisColdStart
 
-            bind ev (released btnLeft) $
-              run $
-                wio $
-                  putStrLn "Left Button Released!!"
+foreign export ccall "plugin_hot_start"
+  hotStart :: MontisHotStart
 
-            unless (isPressEvent ev) $ do
-              forwardEvent ev
-              continue
+coldStart :: MontisColdStart
+coldStart = coldStartMontis config
 
-            bind ev (Shift .+ Mod1 .+ 'R') $ run requestHotReload
+hotStart :: MontisHotStart
+hotStart = hotStartMontis config
 
-            -- 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)}
+config :: MontisConfig
+config = defaultConfig
diff --git a/plug/src/Lib.hs b/plug/src/Lib.hs
deleted file mode 100644
index d36ff27..0000000
--- a/plug/src/Lib.hs
+++ /dev/null
@@ -1,6 +0,0 @@
-module Lib
-    ( someFunc
-    ) where
-
-someFunc :: IO ()
-someFunc = putStrLn "someFunc"
diff --git a/plug/src/Montis/Foreign/Import.hs b/plug/src/Montis/Base/Foreign/Runtime.hs
index e83841b..c43471e 100644
--- a/plug/src/Montis/Foreign/Import.hs
+++ b/plug/src/Montis/Base/Foreign/Runtime.hs
@@ -1,4 +1,4 @@
-module Montis.Foreign.Import where
+module Montis.Base.Foreign.Runtime where
 
 import Data.Void
 import Foreign.C (CInt (..), CString)
@@ -8,6 +8,6 @@ foreign import ccall "montis_do_request_hot_reload" foreign_doRequestHotReload :
 
 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_do_request_exit" foreign_doRequestExit :: Ptr Void -> CInt -> IO ()
 
 foreign import ccall "montis_plugin_get_seat" foreign_getSeat :: Ptr Void -> IO (Ptr Void)
diff --git a/plug/src/Montis/Base/Foreign/WlRoots.hs b/plug/src/Montis/Base/Foreign/WlRoots.hs
new file mode 100644
index 0000000..272567f
--- /dev/null
+++ b/plug/src/Montis/Base/Foreign/WlRoots.hs
@@ -0,0 +1,44 @@
+-- | Contains functions and thin wrappers via ffi to the wlroots API.
+module Montis.Base.Foreign.WlRoots where
+
+import Foreign (Ptr, Word32, nullPtr)
+import Montis.Base.Foreign.WlRoots.Types
+
+-- | Converts a null pointer into 'Nothing' to avoid dangling FFI handles.
+guardNull :: Ptr a -> Maybe (Ptr a)
+guardNull p | p == nullPtr = Nothing
+guardNull p = Just p
+
+foreign import ccall "wlr_seat_set_keyboard"
+  foreign_wlrSetSeatKeyboard ::
+    Ptr ForeignWlrSeat -> Ptr ForeignWlrInputDevice -> IO ()
+
+-- | Binds the given input device as the active keyboard for a seat.
+setSeatKeyboard :: WlrSeat -> WlrInputDevice -> IO ()
+setSeatKeyboard (WlrSeat p1) (WlrInputDevice p2) =
+  foreign_wlrSetSeatKeyboard p1 p2
+
+foreign import ccall "wlr_seat_get_keyboard"
+  foreign_wlrSeatGetKeyboard ::
+    Ptr ForeignWlrSeat -> IO (Ptr ForeignWlrKeyboard)
+
+-- | Looks up the current keyboard for a seat, if one exists.
+getSeatKeyboard :: WlrSeat -> IO (Maybe WlrKeyboard)
+getSeatKeyboard (WlrSeat p) =
+  fmap WlrKeyboard . guardNull <$> foreign_wlrSeatGetKeyboard p
+
+foreign import ccall "wlr_keyboard_get_modifiers"
+  foreign_wlrKeyboardGetModifiers ::
+    Ptr ForeignWlrKeyboard -> IO Word32
+
+-- | Returns the current keyboard modifier mask for the keyboard.
+getKeyboardModifiers :: WlrKeyboard -> IO Word32
+getKeyboardModifiers (WlrKeyboard p) = foreign_wlrKeyboardGetModifiers p
+
+foreign import ccall "wlr_seat_keyboard_notify_key"
+  foreign_wlrSeatKeyboardNotifyKey ::
+    Ptr ForeignWlrSeat -> Word32 -> Word32 -> Word32 -> IO ()
+
+-- | Forwards a key event to the seat with time, keycode, and state.
+seatKeyboardNotifyKey :: WlrSeat -> Word32 -> Word32 -> Word32 -> IO ()
+seatKeyboardNotifyKey (WlrSeat p) = foreign_wlrSeatKeyboardNotifyKey p
diff --git a/plug/src/Montis/Base/Foreign/WlRoots/Types.hs b/plug/src/Montis/Base/Foreign/WlRoots/Types.hs
new file mode 100644
index 0000000..51762d5
--- /dev/null
+++ b/plug/src/Montis/Base/Foreign/WlRoots/Types.hs
@@ -0,0 +1,85 @@
+module Montis.Base.Foreign.WlRoots.Types where
+
+import Foreign (IntPtr, Ptr, intPtrToPtr, ptrToIntPtr)
+import Text.Read
+
+-- | Opaque foreign type for a wlroots keyboard.
+data ForeignWlrKeyboard
+
+newtype WlrKeyboard where
+  WlrKeyboard :: Ptr ForeignWlrKeyboard -> WlrKeyboard
+  deriving (Show, Ord, Eq)
+
+-- | Opaque foreign type for a wlroots pointer.
+data ForeignWlrPointer
+
+newtype WlrPointer where
+  WlrPointer :: Ptr ForeignWlrPointer -> WlrPointer
+  deriving (Show, Ord, Eq)
+
+-- | Opaque foreign type for wlroots pointer button events.
+data ForeignWlrPointerButtonEvent
+
+newtype WlrPointerButtonEvent where
+  WlrPointerButtonEvent :: Ptr ForeignWlrPointerButtonEvent -> WlrPointerButtonEvent
+  deriving (Show, Ord, Eq)
+
+-- | Opaque foreign type for a wlroots seat.
+data ForeignWlrSeat
+
+newtype WlrSeat where
+  WlrSeat :: Ptr ForeignWlrSeat -> WlrSeat
+  deriving (Show, Ord, Eq)
+
+-- | Opaque foreign type for a wlroots input device.
+data ForeignWlrInputDevice
+
+newtype WlrInputDevice where
+  WlrInputDevice :: Ptr ForeignWlrInputDevice -> WlrInputDevice
+  deriving (Show, Ord, Eq)
+
+-- | Opaque foreign type for wlroots keyboard key events.
+data ForeignWlrEventKeyboardKey
+
+newtype WlrEventKeyboardKey where
+  WlrEventKeyboardKey :: Ptr ForeignWlrEventKeyboardKey -> WlrEventKeyboardKey
+  deriving (Show, Ord, Eq)
+
+-- | Opaque foreign type for xdg-shell surfaces.
+data ForeignWlrXdgSurface
+
+-- | Opaque foreign type for XWayland surfaces.
+data ForeignWlrXWaylandSurface
+
+-- | Tagged wrapper over surface pointer variants.
+data Surface where
+  XdgSurface :: Ptr ForeignWlrXdgSurface -> Surface
+  XWaylandSurface :: Ptr ForeignWlrXWaylandSurface -> Surface
+  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
+      -- Rebuild constructors from serialized pointers.
+      toSurf (XdgSerializeSurface ip) = XdgSurface (intPtrToPtr ip)
+      toSurf (XWaylandSerializeSurface ip) = XWaylandSurface (intPtrToPtr ip)
+
+-- | Serializable version of 'Surface' to enable Read/Show.
+data SerializableSurface
+  = XdgSerializeSurface IntPtr
+  | XWaylandSerializeSurface IntPtr
+  deriving (Read, Show)
+
+class ForeignSurface a where
+  -- | Converts a foreign surface pointer into the tagged wrapper.
+  toSurface :: Ptr a -> Surface
+
+instance ForeignSurface ForeignWlrXdgSurface where
+  toSurface = XdgSurface
+
+instance ForeignSurface ForeignWlrXWaylandSurface where
+  toSurface = XWaylandSurface
diff --git a/plug/src/Montis/Constraints.hs b/plug/src/Montis/Constraints.hs
deleted file mode 100644
index 242f1fb..0000000
--- a/plug/src/Montis/Constraints.hs
+++ /dev/null
@@ -1,15 +0,0 @@
-{-# OPTIONS_GHC -Wno-missing-export-lists #-}
-
--- | Contains useful constraints and constraint combinators for type-level
--- metaprogramming.
-module Montis.Constraints where
-
--- | A null constraint. All types implement this.
-class Unconstrained a
-
-instance Unconstrained a
-
--- | Combines multiple constraints by 'And'ing them together.
-class (c1 a, c2 a) => (&&&&) c1 c2 a
-
-instance (c1 a, c2 a) => (&&&&) c1 c2 a
diff --git a/plug/src/Montis/Core.hs b/plug/src/Montis/Core.hs
index e01d2f7..65dcdad 100644
--- a/plug/src/Montis/Core.hs
+++ b/plug/src/Montis/Core.hs
@@ -1,371 +1,9 @@
-{-# OPTIONS_GHC -Wno-missing-export-lists #-}
-
-module Montis.Core 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.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.
---
--- 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
-          }
+module Montis.Core
+  ( module X,
+  )
+where
+
+import Montis.Core.Events as X
+import Montis.Core.Monad as X
+import Montis.Core.Start as X
+import Montis.Core.State as X
diff --git a/plug/src/Montis/Core/ButtonEvent.hs b/plug/src/Montis/Core/ButtonEvent.hs
deleted file mode 100644
index 3a79922..0000000
--- a/plug/src/Montis/Core/ButtonEvent.hs
+++ /dev/null
@@ -1,18 +0,0 @@
-{-# OPTIONS_GHC -Wno-missing-export-lists #-}
-
-module Montis.Core.ButtonEvent where
-
-import Data.Word (Word32)
-import Foreign (Ptr)
-import Montis.Foreign.WlRoots
-
-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/Events.hs b/plug/src/Montis/Core/Events.hs
new file mode 100644
index 0000000..8c0742e
--- /dev/null
+++ b/plug/src/Montis/Core/Events.hs
@@ -0,0 +1,37 @@
+module Montis.Core.Events where
+
+import Data.Word (Word32)
+import Montis.Base.Foreign.WlRoots.Types
+
+data KeyState = KeyPressed | KeyReleased deriving (Show, Read, Eq, Enum, Ord)
+
+data KeyEvent = KeyEvent
+  { keyEvent_timeMs :: Word32,
+    keyEvent_keycode :: Word32,
+    keyEvent_state :: KeyState,
+    keyEvent_modifiers :: Word32,
+    keyEvent_keysym :: Word32,
+    keyEvent_codepoint :: Char,
+    keyEvent_device :: WlrInputDevice
+  }
+  deriving (Show, Ord, Eq)
+
+data ButtonState = ButtonReleased | ButtonPressed deriving (Show, Read, Eq, Enum, Ord)
+
+data ButtonEvent = ButtonEvent
+  { buttonEvent_pointer :: WlrPointer,
+    buttonEvent_timeMs :: Word32,
+    buttonEvent_button :: Word32,
+    buttonEvent_modifiers :: Word32,
+    buttonEvent_state :: ButtonState
+  }
+  deriving (Eq, Show, Ord)
+
+data SurfaceState = Map | Unmap | Destroy
+  deriving (Eq, Ord, Show, Read, Enum)
+
+data SurfaceEvent = SurfaceEvent
+  { surfaceEvent_state :: SurfaceState,
+    surfaceEvent_surface :: Surface
+  }
+  deriving (Eq, Ord, Show)
diff --git a/plug/src/Montis/Core/Extensions.hs b/plug/src/Montis/Core/Extensions.hs
new file mode 100644
index 0000000..a44debe
--- /dev/null
+++ b/plug/src/Montis/Core/Extensions.hs
@@ -0,0 +1,29 @@
+module Montis.Core.Extensions where
+
+import Data.Data
+  ( Typeable,
+    tyConModule,
+    tyConName,
+    tyConPackage,
+  )
+import Data.Kind (Constraint, Type)
+import Text.Printf (printf)
+import Type.Reflection (someTypeRep, someTypeRepTyCon)
+
+-- | A key to key into the Extension maps.
+data ExtensionKey where
+  ExtensionKey :: {extensionKeyValue :: String} -> ExtensionKey
+  deriving (Eq, Ord, Show)
+
+data Extension (c :: Type -> Constraint) where
+  Extension :: (Typeable a, c a) => a -> Extension c
+
+class Nil a
+
+-- | Produces a string representation of a type used to key into the extensible
+-- state map.
+typeRepr :: forall proxy a. (Typeable a) => proxy a -> ExtensionKey
+typeRepr proxy = ExtensionKey $ tyconToStr $ someTypeRepTyCon (someTypeRep proxy)
+  where
+    tyconToStr tc =
+      printf "%s.%s.%s" (tyConPackage tc) (tyConModule tc) (tyConName tc)
diff --git a/plug/src/Montis/Core/Internal/Foreign/Export.hs b/plug/src/Montis/Core/Internal/Foreign/Export.hs
new file mode 100644
index 0000000..fc535c9
--- /dev/null
+++ b/plug/src/Montis/Core/Internal/Foreign/Export.hs
@@ -0,0 +1,85 @@
+-- | This module has no public functions, but provides the surface interface
+-- between the Montis runtime and the plugin.
+module Montis.Core.Internal.Foreign.Export () where
+
+import Control.Monad (forM_)
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as CH
+import Data.Singletons.Decide (Void)
+import Foreign
+  (