Have Wetterhorn keep track of the windows.

5 files changed, 86 insertions, 15 deletions

diff --git a/src/Config.hs b/src/Config.hs
index 759e3b8..0cc1c02 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -41,7 +41,8 @@ config =
                 liftIO $ putStrLn "You Lose :("
 
               forwardEvent,
-            surfaceHook = wio . print
+            surfaceHook = do
+              handleSurface
           },
       layout = WindowLayout Full
     }
diff --git a/src/Wetterhorn/Core/Keys.hs b/src/Wetterhorn/Core/Keys.hs
index 4ed7a77..30db96d 100644
--- a/src/Wetterhorn/Core/Keys.hs
+++ b/src/Wetterhorn/Core/Keys.hs
@@ -14,7 +14,6 @@ module Wetterhorn.Core.Keys
     WeakKeyMatcher,
     nextKeyEvent,
     nextKeyPress,
-    keyEvents,
   )
 where
 
@@ -74,6 +73,7 @@ modifierToMask m =
 -- bindings. This makes it easy to make key-sequence bindings.
 newtype KeysM a = KeysM ((KeyEvent -> W ()) -> KeyEvent -> W (KeysMR a))
 
+-- Return type in the keysM monad.
 data KeysMR a = NextKey (KeysM a) | Lift a | Continue
 
 -- | Convert a KeyM operation to a KeyEvent handler.
@@ -140,12 +140,15 @@ instance Monad KeysM where
           NextKey sub -> return $ NextKey $ keysJoin sub
           Continue -> return Continue
 
+-- | KeysM can be lifted from a W action.
 instance Wlike KeysM where
   liftW act = KeysM (\_ _ -> Lift <$> act)
 
+-- | KeyM can be lifted from an IO action.
 instance MonadIO KeysM where
   liftIO = liftW . wio
 
+-- | Reads the current KeyEvent.
 instance MonadReader KeyEvent KeysM where
   ask = KeysM (\_ -> return . Lift)
   local fn (KeysM fn') = KeysM $ \a (fn -> ns) -> fn' a ns
diff --git a/src/Wetterhorn/Core/W.hs b/src/Wetterhorn/Core/W.hs
index b2c6b51..c708961 100644
--- a/src/Wetterhorn/Core/W.hs
+++ b/src/Wetterhorn/Core/W.hs
@@ -3,21 +3,23 @@
 module Wetterhorn.Core.W where
 
 import Control.Arrow (Arrow (first))
-import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState)
+import Control.Monad.RWS (MonadIO (liftIO), MonadReader (..), MonadState, modify)
 import Control.Monad.Reader (ReaderT (runReaderT))
 import Control.Monad.State (StateT (runStateT))
 import Control.Monad.Trans.Maybe
 import Data.Data (Typeable, cast)
 import Data.Kind (Constraint, Type)
 import Data.Set (Set)
+import qualified Data.Set as Set
 import Foreign (Ptr, StablePtr, intPtrToPtr, ptrToIntPtr)
 import Text.Read
 import Wetterhorn.Core.KeyEvent
 import Wetterhorn.Core.SurfaceEvent
-import Wetterhorn.Foreign.ForeignInterface (ForeignInterface (ForeignInterface))
+import Wetterhorn.Foreign.ForeignInterface (ForeignInterface)
 import qualified Wetterhorn.Foreign.ForeignInterface as ForeignInterface
-import Wetterhorn.Foreign.WlRoots (WlrSeat)
+import Wetterhorn.Foreign.WlRoots (Surface, WlrSeat)
 import Wetterhorn.StackSet hiding (layout)
+import qualified Wetterhorn.StackSet as StackSet
 
 data RationalRect = RationalRect Rational Rational Rational Rational
 
@@ -38,6 +40,11 @@ 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
@@ -90,9 +97,10 @@ handleWindowMessage m (WindowLayout l) = WindowLayout <$> handleMessage m l
 readWindowLayout :: WindowLayout -> String -> WindowLayout
 readWindowLayout (WindowLayout l) s
   | (Just x) <- readLayout s =
-    WindowLayout (asTypeOf x l)
+      WindowLayout (asTypeOf x l)
 readWindowLayout l _ = l
 
+-- | Serializes a window layout to a string.
 serializeWindowLayout :: WindowLayout -> String
 serializeWindowLayout (WindowLayout l) = serializeLayout l
 
@@ -110,10 +118,6 @@ instance Read (ReadPtr a) where
 instance Show (ReadPtr a) where
   show (ReadPtr ptr) = show (ptrToIntPtr ptr)
 
-newtype Window = Window (Ptr ())
-  deriving (Eq, Ord)
-  deriving (Read, Show) via (ReadPtr (Ptr ()))
-
 type Wetterhorn = StablePtr (Context, State)
 
 data Context = Context
@@ -125,7 +129,7 @@ defaultHooks :: Hooks
 defaultHooks =
   Hooks
     { keyHook = \_ -> return (),
-      surfaceHook = \_ -> return ()
+      surfaceHook = handleSurface
     }
 
 defaultConfig :: Config ()
@@ -228,5 +232,35 @@ wio = liftIO
 class Wlike m where
   liftW :: W a -> m a
 
+-- | Trivial instance of W for Wlike.
 instance Wlike W where
   liftW = id
+
+-- Default implementations for common handlers.
+
+-- | handles a new surface event. This updates the state to reflect how it
+-- should look in the harness.
+handleSurface :: SurfaceEvent -> W ()
+handleSurface (SurfaceEvent state (Window -> win)) =
+  case state of
+    Destroy ->
+      modify $
+        \st@State
+           { allWindows = allWindows,
+             mapped = mapped
+           } ->
+            st
+              { allWindows = Set.delete win allWindows,
+                mapped = StackSet.delete win mapped
+              }
+    Unmap -> modify $
+      \st@State {mapped = mapped} ->
+        st
+          { mapped = StackSet.delete win mapped
+          }
+    Map -> modify $
+      \st@State {mapped = mapped, allWindows = allWindows} ->
+        st
+          { mapped = StackSet.insertTiled win mapped,
+            allWindows = Set.insert win allWindows
+          }
diff --git a/src/Wetterhorn/Foreign/WlRoots.hs b/src/Wetterhorn/Foreign/WlRoots.hs
index 56f2a2c..ed6bc1c 100644
--- a/src/Wetterhorn/Foreign/WlRoots.hs
+++ b/src/Wetterhorn/Foreign/WlRoots.hs
@@ -1,6 +1,7 @@
 module Wetterhorn.Foreign.WlRoots where
 
-import Foreign (Ptr, Word32)
+import Foreign (IntPtr, Ptr, Word32, intPtrToPtr, ptrToIntPtr)
+import Text.Read
 
 data WlrSeat
 
@@ -15,7 +16,23 @@ data WlrXWaylandSurface
 data Surface
   = XdgSurface (Ptr WlrXdgSurface)
   | XWaylandSurface (Ptr WlrXWaylandSurface)
-  deriving (Show, Ord, Eq)
+  deriving (Ord, Eq)
+
+instance Show Surface where
+  show (XdgSurface p) = show (XdgSerializeSurface (ptrToIntPtr p))
+  show (XWaylandSurface p) = show (XWaylandSerializeSurface (ptrToIntPtr p))
+
+instance Read Surface where
+  readPrec = fmap toSurf readPrec
+    where
+      toSurf (XdgSerializeSurface ip) = XdgSurface (intPtrToPtr ip)
+      toSurf (XWaylandSerializeSurface ip) = XWaylandSurface (intPtrToPtr ip)
+
+-- | Type which exists specifically to derive instances of read and show.
+data SerializableSurface
+  = XdgSerializeSurface IntPtr
+  | XWaylandSerializeSurface IntPtr
+  deriving (Read, Show)
 
 class ForeignSurface a where
   toSurface :: Ptr a -> Surface
diff --git a/src/Wetterhorn/StackSet.hs b/src/Wetterhorn/StackSet.hs
index f6379eb..22005a4 100644
--- a/src/Wetterhorn/StackSet.hs
+++ b/src/Wetterhorn/StackSet.hs
@@ -2,7 +2,7 @@ module Wetterhorn.StackSet where
 
 import Control.Monad.Identity
 import Control.Monad.Writer (First (..), MonadWriter (tell), execWriter)
-import Data.Maybe (isJust)
+import Data.Maybe (isJust, mapMaybe)
 
 -- | The root datastructure for holding the state of the windows.
 data StackSet s sd t l a = StackSet
@@ -13,7 +13,7 @@ data StackSet s sd t l a = StackSet
     -- | Workspaces that exist, but are not on a screen.
     hidden :: [Workspace t l a]
   }
-  deriving (Read, Show, Eq, Ord)
+  deriving (Read, Show, Eq, Ord, Functor)
 
 class TraverseWorkspace f where
   traverseWorkspaces ::
@@ -189,3 +189,19 @@ onCurrentStack fn (StackSet cur vis hid) =
   where
     cur' (Screen s sd ws) = Screen s sd <$> ws' ws
     ws' (Workspace t l s) = Workspace t l <$> fn s
+
+catMaybes :: StackSet s sd t l (Maybe a) -> StackSet s sd t l a
+catMaybes (StackSet cur hidden visible) =
+  StackSet (catMaybesS cur) (map catMaybesS hidden) (map catMaybesW visible)
+  where
+    catMaybesS (Screen a b ws) = Screen a b $ catMaybesW ws
+    catMaybesW (Workspace a b st) = Workspace a b $ catMaybesSt st
+    catMaybesSt (Stack up down) =
+      Stack (mapMaybe sequenceA up) (mapMaybe sequenceA down)
+
+filter :: (a -> Bool) -> StackSet s sd t l a -> StackSet s sd t l a
+filter ffn =
+  Wetterhorn.StackSet.catMaybes . fmap (\a -> if ffn a then Just a else Nothing)
+
+delete :: (Eq a) => a -> StackSet s sd t l a -> StackSet s sd t l a
+delete win = Wetterhorn.StackSet.filter (/=win)