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.

1 files changed, 185 insertions, 0 deletions

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