13 files changed, 665 insertions, 203 deletions

diff --git a/src/Config.hs b/src/Config.hs
index 818150e..e49a869 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -1,6 +1,14 @@
-module Config (wetterhorn) where
+module Config where
 
-import Wetterhorn.Core
+import Wetterhorn.Core.W
+import Wetterhorn.Layout.Full
+import Wetterhorn.Layout.Combine
 
-wetterhorn :: IO Wetterhorn
-wetterhorn = initWetterhorn defaultConfig
+config = defaultConfig {
+  keyHook = wio . print,
+  surfaceHook = wio . print,
+  layout = WindowLayout Full
+}
+
+-- wetterhorn :: IO Wetterhorn
+-- wetterhorn = initWetterhorn defaultConfig
diff --git a/src/Wetterhorn/Constraints.hs b/src/Wetterhorn/Constraints.hs
new file mode 100644
index 0000000..cdc5afe
--- /dev/null
+++ b/src/Wetterhorn/Constraints.hs
@@ -0,0 +1,12 @@
+-- | Contains useful constraints and constraint combinators.
+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/src/Wetterhorn/Core.hs b/src/Wetterhorn/Core.hs
index d3515fc..d853191 100644
--- a/src/Wetterhorn/Core.hs
+++ b/src/Wetterhorn/Core.hs
@@ -1,176 +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 (..),
-  )
+--   ( 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 Control.Monad (when)
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as CH
-import Data.Char (chr, ord)
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe)
-import Foreign (Ptr, StablePtr, Word32, castForeignPtr, newStablePtr, ptrToIntPtr)
-import Numeric (showHex)
-import Text.Printf
-import Wetterhorn.Core.ForeignInterface (ForeignInterface)
-import qualified Wetterhorn.Core.ForeignInterface as ForeignInterface
-import Wetterhorn.WlRoots
-
-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)
-
-data WState = WState
-  { someString :: String,
-    integer :: Int
-  }
-  deriving (Show, Read)
-
-data SurfaceState = Map | Unmap | Destroy deriving (Eq, Ord, Show, Enum)
-
-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)
-
-data WConfig = WConfig
-  { keybindingHandler :: KeyEvent -> W Bool,
-    surfaceHandler :: SurfaceState -> Surface -> W ()
-  }
-
-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 '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)
+-- 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/src/Wetterhorn/Core/KeyEvent.hs b/src/Wetterhorn/Core/KeyEvent.hs
new file mode 100644
index 0000000..77d273f
--- /dev/null
+++ b/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/src/Wetterhorn/Core/SurfaceEvent.hs b/src/Wetterhorn/Core/SurfaceEvent.hs
new file mode 100644
index 0000000..3e7eaf3
--- /dev/null
+++ b/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/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs
new file mode 100644
index 0000000..89ebf4b
--- /dev/null
+++ b/src/Wetterhorn/Core/W.hs
@@ -0,0 +1,151 @@
+module Wetterhorn.Core.W where
+
+import Control.Arrow (Arrow (first))
+import Control.Monad.RWS (MonadIO (liftIO), MonadReader, MonadState)
+import Control.Monad.Reader (ReaderT (runReaderT))
+import Control.Monad.State (StateT (runStateT))
+import Data.Data (Typeable, cast)
+import Data.Kind (Constraint, Type)
+import Data.Set (Set)
+import Foreign (StablePtr)
+import Text.Read
+import Wetterhorn.Core.KeyEvent
+import Wetterhorn.Core.SurfaceEvent
+import Wetterhorn.Foreign
+import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
+import Wetterhorn.StackSet hiding (layout)
+
+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
+
+-- | Types of this class "lay out" windows by assigning rectangles and handle
+-- messages.
+class (Typeable 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 C l :: Type -> Constraint
+
+  -- | Executes the layout on some windows in a pure way. Returns a list of
+  -- windows to their assigned rectangle.
+  pureLayout :: (C l a) => [a] -> l -> [(a, RationalRect)]
+  pureLayout as _ = map (,RationalRect 0 0 0 0) as
+
+  -- | Runs the layout in an impure way returning a modified layout and the list
+  -- of windows to their rectangles under a monad.
+  runLayout :: (C l a) => [a] -> l -> W (l, [(a, RationalRect)])
+  runLayout as l = return (l, pureLayout as l)
+
+  -- | Handles a message in a pure way. Returns the new layout after handling
+  -- the message.
+  pureMessage :: Message -> l -> l
+  pureMessage _ = id
+
+  -- | Handles a message in an impure way.
+  handleMessage :: Message -> l -> W l
+  handleMessage m = return . pureMessage m
+
+  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
+
+-- 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, C l a, a ~ Window) => WindowLayout l
+
+runWindowLayout :: [Window] -> WindowLayout -> W (WindowLayout, [(Window, RationalRect)])
+runWindowLayout as (WindowLayout l) = first WindowLayout <$> runLayout as l
+
+handleWindowMessage :: Message -> WindowLayout -> 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
+
+serializeWindowLayout :: WindowLayout -> String
+serializeWindowLayout (WindowLayout l) = serializeLayout l
+
+type ScreenId = ()
+
+type ScreenDetail = ()
+
+type Tag = String
+
+newtype Window = Window (TypedIntPtr ())
+  deriving (Eq, Ord, Show, Read)
+
+type Wetterhorn = StablePtr (Context, State)
+
+data Context = Context
+  { ctxForeignInterface :: ForeignInterface,
+    ctxConfig :: Config WindowLayout
+  }
+
+defaultConfig :: Config ()
+defaultConfig =
+  Config
+    { keyHook = \_ -> return (),
+      surfaceHook = \_ -> return (),
+      layout = ()
+    }
+
+data Config l = Config
+  { keyHook :: KeyEvent -> W (),
+    surfaceHook :: SurfaceEvent -> W (),
+    layout :: l
+  }
+
+data State = State
+  { mapped :: StackSet ScreenId ScreenDetail Tag WindowLayout Window,
+    allWindows :: Set Window
+  }
+
+initColdState :: WindowLayout -> IO State
+initColdState l = return $ State (StackSet (Screen () () (Workspace "0" l (Stack [] []))) [] []) mempty
+
+marshalState :: State -> String
+marshalState (State mapped allWindows) =
+  show
+    ( mapLayout serializeWindowLayout mapped,
+      allWindows
+    )
+
+demarshalState :: WindowLayout -> String -> State
+demarshalState witness str = State mapped allWindows
+  where
+    (mapLayout (readWindowLayout witness) -> mapped, allWindows) = read str
+
+newtype W a = W (ReaderT Context (StateT State IO) a)
+  deriving (Functor, Applicative, Monad, MonadState State, MonadReader Context, MonadIO)
+
+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
diff --git a/src/Wetterhorn/Foreign.hs b/src/Wetterhorn/Foreign.hs
new file mode 100644
index 0000000..2d0a42c
--- /dev/null
+++ b/src/Wetterhorn/Foreign.hs
@@ -0,0 +1,18 @@
+module Wetterhorn.Foreign
+  ( TypedIntPtr (..),
+    toPtr,
+    fromPtr,
+  )
+where
+
+import Foreign (IntPtr, Ptr)
+import qualified Foreign
+
+toPtr :: TypedIntPtr a -> Ptr a
+toPtr (TypedIntPtr ip) = Foreign.intPtrToPtr ip
+
+fromPtr :: Ptr a -> TypedIntPtr a
+fromPtr = TypedIntPtr . Foreign.ptrToIntPtr
+
+newtype TypedIntPtr a = TypedIntPtr IntPtr
+  deriving (Show, Read, Eq, Ord, Num)
diff --git a/src/Wetterhorn/FFI.hs b/src/Wetterhorn/Foreign/Export.hs
index 6173291..0d71a4e 100644
--- a/src/Wetterhorn/FFI.hs
+++ b/src/Wetterhorn/Foreign/Export.hs
@@ -1,6 +1,6 @@
 -- | This module does not export anything. It exists simply to provide C-symbols
 -- for the plugin.
-module Wetterhorn.FFI () where
+module Wetterhorn.Foreign.Export () where
 
 import Config
 import Control.Monad (forM_)
@@ -17,30 +17,33 @@ import Foreign
     newStablePtr,
   )
 import Foreign.C (CChar, CInt (..))
-import Wetterhorn.Core
-import Wetterhorn.Core.ForeignInterface
-import Wetterhorn.WlRoots
-
-runForeign :: (WConfig -> W ()) -> Wetterhorn -> IO Wetterhorn
+import Wetterhorn.Core.KeyEvent (KeyEvent (..), KeyState (..))
+import Wetterhorn.Core.SurfaceEvent (SurfaceEvent (SurfaceEvent))
+import Wetterhorn.Core.W (W, Wetterhorn)
+import qualified Wetterhorn.Core.W as W
+import Wetterhorn.Foreign.ForeignInterface
+import Wetterhorn.Foreign.WlRoots
+
+runForeign :: (forall l. W.Config l -> W ()) -> Wetterhorn -> IO Wetterhorn
 runForeign fn stblptr = do
   (ctx, st) <- deRefStablePtr stblptr
   freeStablePtr stblptr
-  (_, state') <- runW (fn $ ctxConfig ctx) (ctx, st)
+  (_, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
   newStablePtr (ctx, state')
 
-runForeignWithReturn :: (Storable a) => (WConfig -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
+runForeignWithReturn :: (Storable a) => (forall l. W.Config l -> W a) -> Ptr a -> Wetterhorn -> IO Wetterhorn
 runForeignWithReturn fn ptr stableptr = do
   (ctx, st) <- deRefStablePtr stableptr
   freeStablePtr stableptr
-  (val, state') <- runW (fn $ ctxConfig ctx) (ctx, st)
+  (val, state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
   poke ptr val
   newStablePtr (ctx, state')
 
-runForeignWithReturn2 :: (Storable a, Storable b) => (WConfig -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
+runForeignWithReturn2 :: (Storable a, Storable b) => (forall l. W.Config l -> W (a, b)) -> Ptr a -> Ptr b -> Wetterhorn -> IO Wetterhorn
 runForeignWithReturn2 fn ptrA ptrB stableptr = do
   (ctx, st) <- deRefStablePtr stableptr
   freeStablePtr stableptr
-  ((vA, vB), state') <- runW (fn $ ctxConfig ctx) (ctx, st)
+  ((vA, vB), state') <- W.runW (fn $ W.ctxConfig ctx) (ctx, st)
   poke ptrA vA
   poke ptrB vB
   newStablePtr (ctx, state')
@@ -55,10 +58,11 @@ foreign export ccall "plugin_hot_start"
 pluginHotStart :: Ptr CChar -> Word32 -> IO Wetterhorn
 pluginHotStart chars len = do
   bs <- BS.packCStringLen (chars, fromIntegral len)
-  wtrPtr <- wetterhorn
-  (conf, _) <- deRefStablePtr wtrPtr
-  freeStablePtr wtrPtr
-  newStablePtr . (conf,) =<< readWState bs
+  foreignInterface <- getForeignInterface
+  newStablePtr
+    ( W.Context foreignInterface config,
+      W.demarshalState (W.layout config) (CH.unpack bs)
+    )
 
 -- | This function is called when a "coldstart" request is receieved. It just
 -- calles the function "wetterhorn". This function should be defined in the main
@@ -67,7 +71,10 @@ foreign export ccall "plugin_cold_start"
   pluginColdStart :: IO Wetterhorn
 
 pluginColdStart :: IO Wetterhorn
-pluginColdStart = wetterhorn
+pluginColdStart = do
+  foreignInterface <- getForeignInterface
+  state <- W.initColdState (W.layout config)
+  newStablePtr (W.Context foreignInterface config, state)
 
 -- | Marshals the opaque state to a C-style byte array and size pointer.
 foreign export ccall "plugin_marshal_state"
@@ -76,7 +83,7 @@ foreign export ccall "plugin_marshal_state"
 pluginMarshalState :: Wetterhorn -> Ptr Word32 -> IO (Ptr Word8)
 pluginMarshalState stblptr outlen = do
   (_, st) <- deRefStablePtr stblptr
-  let bs = CH.pack (show st)
+  let bs = CH.pack (W.marshalState st)
   ret <- mallocBytes (BS.length bs)
   poke outlen (fromIntegral $ BS.length bs)
   forM_ (zip [0 ..] (BS.unpack bs)) $ \(off, w8) -> do
@@ -105,7 +112,7 @@ pluginHandleKeybinding ::
   IO Wetterhorn
 pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
   runForeignWithReturn $ \config -> do
-    event <- wio $
+    event <- W.wio $
       runForeignDemarshal eventPtr $ do
         tMs <- demarshal
         kc <- demarshal
@@ -120,7 +127,8 @@ pluginHandleKeybinding inputDevicePtr eventPtr mods sym cp =
             sym
             (toEnum $ fromIntegral cp)
             inputDevicePtr
-    (\b -> if b then 1 else 0) <$> keybindingHandler config event
+    W.keyHook config event
+    return 1
 
 -- | Function exported to the harness to handle the mapping/unmapping/deletion
 -- of an XDG surface.
@@ -130,7 +138,12 @@ foreign export ccall "plugin_handle_surface"
 
 pluginHandleSurface :: Ptr WlrXdgSurface -> CInt -> Wetterhorn -> IO Wetterhorn
 pluginHandleSurface p t =
-  runForeign (\c -> surfaceHandler c (toEnum $ fromIntegral t) (toSurface p))
+  runForeign
+    ( \c ->
+        W.surfaceHook
+          c
+          $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p)
+    )
 
 -- | Function exported to the harness to handle the mapping/unmapping/deletion
 -- of an XWayland surface.
@@ -140,4 +153,4 @@ foreign export ccall "plugin_handle_xwayland_surface"
 
 pluginHandleXWaylandSurface :: Ptr WlrXWaylandSurface -> CInt -> Wetterhorn -> IO Wetterhorn
 pluginHandleXWaylandSurface p t =
-  runForeign (\c -> surfaceHandler c (toEnum $ fromIntegral t) (toSurface p))
+  runForeign (\c -> W.surfaceHook c $ SurfaceEvent (toEnum $ fromIntegral t) (toSurface p))
diff --git a/src/Wetterhorn/Core/ForeignInterface.hs b/src/Wetterhorn/Foreign/ForeignInterface.hs
index 5dc1454..471e3a9 100644
--- a/src/Wetterhorn/Core/ForeignInterface.hs
+++ b/src/Wetterhorn/Foreign/ForeignInterface.hs
@@ -1,22 +1,20 @@
-module Wetterhorn.Core.ForeignInterface
+module Wetterhorn.Foreign.ForeignInterface
   ( getForeignInterface,
     ForeignInterface (..),
     ForeignDemarshal (..),
     runForeignDemarshal,
     demarshal,
-    doShellExec
+    doShellExec,
   )
 where
 
 import Control.Monad.State (MonadState (get, put), MonadTrans (lift), StateT, evalStateT)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BC
 import Data.Void (Void)
-import Foreign (Ptr, Storable (peek, sizeOf), Word8, castPtr, plusPtr)
+import Foreign (Ptr, Storable (peek, sizeOf), castPtr, plusPtr)
 import Foreign.C (CChar, CInt (..))
 import Foreign.C.String
 import GHC.Exts (FunPtr)
-import Wetterhorn.WlRoots
+import Wetterhorn.Foreign.WlRoots
 
 newtype ForeignDemarshal a = ForeignDemarshal (StateT (Ptr ()) IO a)
   deriving (Functor, Monad, Applicative, MonadState (Ptr ()))
diff --git a/src/Wetterhorn/WlRoots.hs b/src/Wetterhorn/Foreign/WlRoots.hs
index 7a2a237..56f2a2c 100644
--- a/src/Wetterhorn/WlRoots.hs
+++ b/src/Wetterhorn/Foreign/WlRoots.hs
@@ -1,4 +1,4 @@
-module Wetterhorn.WlRoots where
+module Wetterhorn.Foreign.WlRoots where
 
 import Foreign (Ptr, Word32)
 
diff --git a/src/Wetterhorn/Layout/Combine.hs b/src/Wetterhorn/Layout/Combine.hs
new file mode 100644
index 0000000..983ceb1
--- /dev/null
+++ b/src/Wetterhorn/Layout/Combine.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module Wetterhorn.Layout.Combine where
+
+import Data.Typeable
+import Wetterhorn.Constraints
+import Wetterhorn.Core.W
+
+data (|||) a b = Comb LR a b
+  deriving (Typeable, Read, Show)
+
+data Next = Next
+  deriving (Typeable)
+
+data Reset = Reset
+  deriving (Typeable)
+
+(|||) :: a -> b -> (a ||| b)
+a ||| b = Comb L a b
+
+data LR = L | R deriving (Read, Show, Ord, Eq, Enum)
+
+instance (LayoutClass a, LayoutClass b) => LayoutClass (a ||| b) where
+  type C (a ||| b) = C a &&&& C b
+
+  runLayout as (Comb R r l) = do
+    (r', ret) <- runLayout as r
+    return (Comb R r' l, ret)
+  runLayout as (Comb L r l) = do
+    (l', ret) <- runLayout as l
+    return (Comb R r l', ret)
+
+  handleMessage (fromMessage -> Just Next) (Comb L l r) = return (Comb R l r)
+  handleMessage (fromMessage -> Just Reset) (Comb _ l r) = return (Comb L l r)
+  handleMessage mesg (Comb L l r) =
+    Comb L <$> handleMessage mesg l <*> pure r
+  handleMessage mesg (Comb R l r) =
+    Comb L l <$> handleMessage mesg r
+
+  serializeLayout (Comb lr l r) = show (Comb lr (serializeLayout l) (serializeLayout r))
+  readLayout str = Comb lr <$> l <*> r
+    where
+      (Comb lr (readLayout -> l) (readLayout -> r)) = read str
+
+  description (Comb _ l r) = description l ++ " ||| " ++ description r
diff --git a/src/Wetterhorn/Layout/Full.hs b/src/Wetterhorn/Layout/Full.hs
new file mode 100644
index 0000000..8296c7b
--- /dev/null
+++ b/src/Wetterhorn/Layout/Full.hs
@@ -0,0 +1,18 @@
+module Wetterhorn.Layout.Full where
+
+import Data.Data (Typeable)
+import Data.Default
+import Wetterhorn.Constraints
+import Wetterhorn.Core.W
+
+data Full = Full
+  deriving (Read, Show, Typeable)
+
+instance Default Full where
+  def = Full
+
+instance LayoutClass Full where
+  type C Full = Unconstrained
+
+  pureLayout (a : _) _ = [(a, RationalRect 1 1 1 1)]
+  pureLayout _ _ = []
diff --git a/src/Wetterhorn/StackSet.hs b/src/Wetterhorn/StackSet.hs
new file mode 100644
index 0000000..464fd54
--- /dev/null
+++ b/src/Wetterhorn/StackSet.hs
@@ -0,0 +1,185 @@
+module Wetterhorn.StackSet where
+
+import Control.Monad.Identity
+import Control.Monad.Writer (First (..), MonadWriter (tell), execWriter)
+import Data.Maybe (isJust)
+
+-- | The root datastructure for holding the state of the windows.
+data StackSet s sd t l a = StackSet
+  { -- | The currently selected screen.
+    current :: Screen s sd t l a,
+    -- | Remaining visible screens.
+    visible :: [Screen s sd t l a],
+    -- | Workspaces that exist, but are not on a screen.
+    hidden :: [Workspace t l a]
+  }
+  deriving (Read, Show, Eq, Ord)
+
+class TraverseWorkspace f where
+  traverseWorkspaces ::
+    (Applicative m) => (Workspace t l a -> m (Workspace t' l' a')) -> f t l a -> m (f t' l' a')
+
+traverseWorkspaces_ :: (TraverseWorkspace f, Monad m) => (Workspace t l a -> m ()) -> f t l a -> m ()
+traverseWorkspaces_ f = void . traverseWorkspaces (\w -> f w >> pure w)
+
+foldMapWorkspaces ::
+  (Monoid m, TraverseWorkspace f) => (Workspace t l a -> m) -> f t l a -> m
+foldMapWorkspaces fn = execWriter . traverseWorkspaces_ (tell . fn)
+
+mapWorkspaces ::
+  (TraverseWorkspace f) =>
+  (Workspace t l a -> Workspace t' l' a') ->
+  f t l a ->
+  f t' l' a'
+mapWorkspaces fn = runIdentity . traverseWorkspaces (pure . fn)
+
+instance TraverseWorkspace Workspace where
+  traverseWorkspaces f = f
+
+instance TraverseWorkspace (Screen s sd) where
+  traverseWorkspaces f scr = (\w' -> scr {workspace = w'}) <$> f (workspace scr)
+
+instance TraverseWorkspace (StackSet s sd) where
+  traverseWorkspaces f (StackSet cur vis hid) =
+    StackSet
+      <$> traverseWorkspaces f cur
+      <*> traverse (traverseWorkspaces f) vis
+      <*> traverse (traverseWorkspaces f) hid
+
+instance Traversable Stack where
+  traverse f (Stack u d) =
+    Stack <$> traverse f u <*> traverse f d
+
+instance (TraverseWorkspace f) => Foldable (f t l) where
+  foldMap fn =
+    execWriter
+      . traverseWorkspaces_ (\(Workspace _ _ s) -> tell (foldMap (fn . windowInSeat) s))
+
+instance (Functor (f t l), TraverseWorkspace f) => Traversable (f t l) where
+  sequenceA =
+    traverseWorkspaces $
+      \(Workspace t l sf) -> Workspace t l <$> traverse sequenceA sf
+
+class HasFocus f where
+  focused :: f a -> Maybe a
+
+data Rectangle = Rectangle Int Int Int Int
+  deriving (Read, Show, Eq, Ord)
+
+instance HasFocus (StackSet s sd t l) where
+  focused (StackSet c _ _) = focused c
+
+data Screen s sd t l a = Screen
+  { screenDetail :: sd,
+    screenId :: s,
+    workspace :: Workspace t l a
+  }
+  deriving (Read, Show, Eq, Ord, Functor)
+
+instance HasFocus (Screen s sd t l) where
+  focused (Screen _ _ w) = focused w
+
+-- | Defines where a window should appear.
+data WindowSeat a = Floating Rectangle a | Tiled a
+  deriving (Read, Show, Eq, Ord, Functor, Foldable)
+
+windowInSeat :: WindowSeat a -> a
+windowInSeat (Floating _ a) = a
+windowInSeat (Tiled a) = a
+
+instance Traversable WindowSeat where
+  sequenceA (Floating r fa) = Floating r <$> fa
+  sequenceA (Tiled fa) = Tiled <$> fa
+
+instance HasFocus WindowSeat where
+  focused (Floating _ a) = Just a
+  focused (Tiled a) = Just a
+
+data Workspace t l a = Workspace
+  { tag :: t,
+    layout :: l,
+    stack :: Stack (WindowSeat a)
+  }
+  deriving (Read, Show, Eq, Ord, Functor)
+
+instance HasFocus (Workspace t l) where
+  focused (Workspace _ _ s) = windowInSeat <$> focused s
+
+data Stack a = Stack
+  { -- | The elements above the focused one.
+    up :: ![a],
+    -- | The elements below the focused one including the focused one itself.
+    down :: ![a]
+  }
+  deriving (Read, Show, Eq, Ord, Functor, Foldable)
+
+instance HasFocus Stack where
+  focused (Stack _ (a : _)) = Just a
+  focused _ = Nothing
+
+-- | Change the tag in a structure.
+mapTag :: (TraverseWorkspace f) => (t -> t') -> f t l a -> f t' l a
+mapTag fn = mapWorkspaces (\w -> w {tag = fn (tag w)})
+
+-- | Change the layout in a structure.
+mapLayout :: (TraverseWorkspace f) => (l -> l') -> f t l a -> f t l' a
+mapLayout fn = mapWorkspaces (\w -> w {layout = fn (layout w)})
+
+-- | Return all the tags in a structure.
+tags :: (TraverseWorkspace f) => f t l a -> [t]
+tags = foldMapWorkspaces ((: []) . tag)
+
+-- | Insert a new window into the StackSet. The optional rectangle indicates if
+-- the window should be floating or tiled.
+--
+-- The window is inserted just above the the currently focused window and is
+-- given focus.
+insert :: a -> Maybe Rectangle -> StackSet s sd t l a -> StackSet s sd t l a
+insert win rect =
+  runIdentity
+    . onCurrentStack
+      ( \(Stack u d) ->
+          return $
+            (\w -> Stack u (w : d)) $
+              maybe (Tiled win) (`Floating` win) rect
+      )
+
+-- | Find the tag associated with a window.
+findTag :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Maybe t
+findTag a =
+  getFirst
+    . foldMapWorkspaces
+      ( \ws ->
+          foldMap
+            ( \a' ->
+                First $ if a' == a then Just (tag ws) else Nothing
+            )
+            ws
+      )
+
+-- | Return true if the window exist in a structure
+elem :: (TraverseWorkspace f, Eq a) => a -> f t l a -> Bool
+elem a = isJust . findTag a
+
+-- | Convenience function for inserting a window in stack set tiled.
+insertTiled :: a -> StackSet s sd t l a -> StackSet s sd t l a
+insertTiled win = insert win Nothing
+
+applyStack ::
+  (Monad m) =>
+  (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) ->
+  Workspace t l a ->
+  m (Workspace t l a)
+applyStack fn (Workspace t l s) = Workspace t l <$> fn s
+
+-- | Apply a function to the currently focused stack.
+onCurrentStack ::
+  (Monad m) =>
+  (Stack (WindowSeat a) -> m (Stack (WindowSeat a))) ->
+  StackSet s sd t l a ->
+  m (StackSet s sd t l a)
+onCurrentStack fn (StackSet cur vis hid) =
+  StackSet <$> cur' cur <*> pure vis <*> pure hid
+  where
+    cur' (Screen s sd ws) = Screen s sd <$> ws' ws
+    ws' (Workspace t l s) = Workspace t l <$> fn s