Have Meson orchestrate the whole build rather than stack.

As a part of this, I changed the file layout to:

rt/ - the Montis runtime
plug/ - the Montis plugin
wlroots/ - wlroots

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
+