Huge refactor for the Haskell code.HEADmain

This adds new layout configuration, preparing for actually using the
layouts. This also restructures the code and tries to keep code
interfacing with the foreign structures together and rename them to more
sensible names.

14 files changed, 674 insertions, 206 deletions

diff --git a/package.yaml b/package.yaml
index ebc64c1..fee7560 100644
--- a/package.yaml
+++ b/package.yaml
@@ -33,6 +33,8 @@ dependencies:
 - mtl
 - bytestring
 - containers
+- data-default
+
 
 ghc-options:
 - -Wall
@@ -44,10 +46,14 @@ ghc-options:
 - -Wmissing-home-modules
 - -Wpartial-fields
 - -Wredundant-constraints
-- -XTupleSections
+- -XGHC2021
+- -XTypeFamilies
+- -XUndecidableInstances
+- -XGADTs
+- -XFunctionalDependencies
+- -XUndecidableSuperClasses
+- -XDefaultSignatures
 - -XViewPatterns
-- -XGeneralizedNewtypeDeriving
-- -XRankNTypes
 - -fPIC
 
 executables:
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