REF move dynamic workspace code to workspace mon module

bin/xmonad.hs

@@ -18,13 +18,7 @@ import           WorkspaceMon
 
 import           Control.Arrow                    (first)
 import           Control.Concurrent
-import           Control.Monad
+import           Control.Monad                    (forM_, mapM_, void, when)
-    ( forM_
-    , liftM2
-    , mapM_
-    , void
-    , when
-    )
 
 import           Data.List                        (isPrefixOf, sortBy, sortOn)
 import qualified Data.Map.Lazy                    as M
@@ -35,7 +29,6 @@ import           Graphics.X11.Types
 import           Graphics.X11.Xlib.Atom
 import           Graphics.X11.Xlib.Extras
 
-
 import           System.Directory
 import           System.Exit
 import           System.IO
@@ -48,7 +41,6 @@ import           Xmobar.Common
 import           XMonad
 import           XMonad.Actions.CopyWindow
 import           XMonad.Actions.CycleWS
-import           XMonad.Actions.DynamicWorkspaces
 import           XMonad.Actions.PhysicalScreens
 import           XMonad.Actions.Volume
 import           XMonad.Actions.Warp
@@ -66,13 +58,12 @@ import qualified XMonad.StackSet                  as W
 import           XMonad.Util.EZConfig
 import           XMonad.Util.NamedActions
 
-
 main :: IO ()
 main = do
   cl <- startXMonadService
   (p, h) <- spawnPipe' "xmobar"
   _ <- forkIO runPowermon
-  _ <- forkIO $ runWorkspaceMon matchPatterns
+  _ <- forkIO $ runWorkspaceMon allDWs
   let ts = ThreadState
         { client = cl
         , childPIDs = [p]
@@ -95,27 +86,75 @@ main = do
           , focusedBorderColor = T.selectedBordersColor
           }
 
-myStartupHook :: X ()
+-- Data structure to hold the dbus client, threadIDs, and process IDs started
-myStartupHook = docksStartupHook <+> startupHook def
+-- outside the main Xmonad thread. Maybe I could use a ReaderT here but I'm lazy
-
 data ThreadState = ThreadState
     { client       :: Client
     , childPIDs    :: [Pid]
     , childHandles :: [Handle]
     }
 
-matchPatterns :: M.Map String String
+-- | Startuphook configuration
-matchPatterns = fromList
-  [ (myGimpClass, myGimpWorkspace)
-  , (myVMClass, myVMWorkspace)
-  , (myXSaneClass, myXSaneWorkspace)
-  ]
 
-myWorkspaces :: [String]
+myStartupHook :: X ()
+myStartupHook = docksStartupHook <+> startupHook def
+
+-- | Workspace configuration
+
+myWorkspaces :: [WorkspaceId]
 myWorkspaces = map show [1..10 :: Int]
 
-myLayouts = onWorkspace myVMWorkspace vmLayout
+gimpDynamicWorkspace :: DynWorkspace
-  $ onWorkspace myGimpWorkspace gimpLayout
+gimpDynamicWorkspace = DynWorkspace
+  { dwName = "Gimp"
+  , dwTag = t
+  , dwClass = c
+  , dwHook =
+    [ matchGimpRole "gimp-image-window" -?> appendViewShift t
+    , matchGimpRole "gimp-dock" -?> doF (toBottom . W.focusMaster)
+    , matchGimpRole "gimp-toolbox" -?> doF (toBottom . W.focusMaster)
+    , className =? c -?> appendViewShift t
+    ]
+  , dwCmd = Just ("g", spawnCmd "gimp-2.10" [])
+  }
+  where
+    matchGimpRole role = isPrefixOf role <$> stringProperty "WM_WINDOW_ROLE"
+      <&&> className =? c
+    toBottom = W.modify' $ \(W.Stack f tp bt) -> W.Stack f (reverse bt ++ tp) []
+    t = "GIMP"
+    c = "Gimp-2.10" -- TODO I don't feel like changing the version long term
+
+wmDynamicWorkspace :: DynWorkspace
+wmDynamicWorkspace = DynWorkspace
+  { dwName = "Windows VirtualBox"
+  , dwTag = t
+  , dwClass = c
+  , dwHook = [ className =? c -?> appendViewShift t ]
+  , dwCmd = Just ("v", spawnCmd "vbox-start" ["win8raw"])
+  }
+  where
+    t = "VM"
+    c = "VirtualBoxVM"
+
+xsaneDynamicWorkspace :: DynWorkspace
+xsaneDynamicWorkspace = DynWorkspace
+  { dwName = "XSane"
+  , dwTag = t
+  , dwClass = c
+  , dwHook = [ className =? c -?> appendViewShift t >> doFloat ]
+  , dwCmd = Just ("x", spawnCmd "xsane" [])
+  }
+  where
+    t = "XSANE"
+    c = "Xsane"
+
+allDWs :: [DynWorkspace]
+allDWs = [xsaneDynamicWorkspace, wmDynamicWorkspace, gimpDynamicWorkspace]
+
+-- | Layout configuration
+
+myLayouts = onWorkspace (dwTag wmDynamicWorkspace) vmLayout
+  $ onWorkspace (dwTag gimpDynamicWorkspace) gimpLayout
   $ tall ||| single ||| full
   where
     addTopBar = noFrillsDeco shrinkText T.tabbedTheme
@@ -138,7 +177,7 @@ myLayouts = onWorkspace myVMWorkspace vmLayout
       $ addTopBar
       $ Tall 1 0.025 0.8
 
--- | Format workspace and layout in loghook
+-- | Loghook configuration
 -- The format will be like "[<1> 2 3] 4 5 | LAYOUT" where each digit
 -- is the workspace and LAYOUT is the current layout. Each workspace
 -- in the brackets is currently visible and the order reflects the
@@ -177,35 +216,14 @@ myWindowSetXinerama ws = wsString ++ sep ++ layout
         (_, Rectangle x0 _ _ _) = getScreenIdAndRectangle s0
         (_, Rectangle x1 _ _ _) = getScreenIdAndRectangle s1
 
-viewShift = doF . liftM2 (.) W.view W.shift
+-- | Managehook configuration
-
-appendViewShift tag = liftX (appendWorkspace tag) >> viewShift tag
-
-($?) :: Query a -> (a -> Bool) -> Query Bool
-($?) q f = f <$> q
-
-matchGimpRole :: String -> Query Bool
-matchGimpRole role = stringProperty "WM_WINDOW_ROLE" $? isPrefixOf role
-  <&&> className =? myGimpClass
-
-moveBottom :: W.StackSet i l a s sd -> W.StackSet i l a s sd
-moveBottom = W.modify' $ \(W.Stack f t b) -> W.Stack f (reverse b ++ t) []
 
 myManageHook :: ManageHook
 myManageHook = manageApps <+> manageDocks <+> manageHook def
 
 manageApps :: ManageHook
-manageApps = composeOne
+manageApps = composeOne $ concatMap dwHook allDWs ++
   [ isDialog -?> doCenterFloat
-  -- VM window
-  , className =? myVMClass -?> appendViewShift myVMWorkspace
-  -- GIMP
-  , matchGimpRole "gimp-image-window" -?> appendViewShift myGimpWorkspace
-  , matchGimpRole "gimp-dock" -?> doF (moveBottom . W.focusMaster)
-  , matchGimpRole "gimp-toolbox" -?> doF (moveBottom . W.focusMaster)
-  , className =? myGimpClass -?> appendViewShift myGimpWorkspace
-  -- XSane
-  , className =? myXSaneClass -?> appendViewShift myXSaneWorkspace >> doFloat
   -- the seafile applet
   , className =? "Seafile Client" -?> doFloat
   -- gnucash
@@ -221,6 +239,8 @@ manageApps = composeOne
   , (className =? "Zotero" <&&> resource =? "Toplevel") -?> doFloat
   ]
 
+-- | Eventhook configuration
+
 myEventHook :: Event -> X All
 myEventHook = monitorEventHook <+> docksEventHook <+> handleEventHook def
 
@@ -229,7 +249,7 @@ monitorEventHook ClientMessageEvent { ev_message_type = t, ev_data = d }
   | t == bITMAP = do
     let (xtype, tag) = splitXMsg d
     case xtype of
-      Workspace -> removeEmptyWorkspaceByTag tag
+      Workspace -> removeDynamicWorkspace tag
       ACPI -> do
          let acpiTag = toEnum <$> readMaybe tag :: Maybe ACPIEvent
          forM_ acpiTag $ \case
@@ -432,46 +452,7 @@ runMaxBacklight = io $ void callMaxBrightness
 runToggleDPMS :: X ()
 runToggleDPMS = io $ void callToggle
 
--- keybindings
+-- | Keymap configuration
-
-myVMWorkspace :: String
-myVMWorkspace = "VM"
-
-myVMClass :: String
-myVMClass = "VirtualBoxVM"
-
-myGimpWorkspace :: String
-myGimpWorkspace = "GIMP"
-
--- TODO I don't feel like changing the version long term
-myGimpClass :: String
-myGimpClass = "Gimp-2.10"
-
-myXSaneWorkspace :: String
-myXSaneWorkspace = "XSANE"
-
-myXSaneClass :: String
-myXSaneClass = "Xsane"
-
-wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
-wsOccupied tag ws = elem tag $ map W.tag $ filter (isJust .  W.stack)
-  -- list of all workspaces with windows on them
-  -- TODO is there not a better way to do this?
-  $ W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
-
-spawnOrSwitch :: WorkspaceId -> X () -> X ()
-spawnOrSwitch tag cmd = do
-  occupied <- withWindowSet $ return . wsOccupied tag
-  if occupied then windows $ W.view tag else cmd
-
-runVBox :: X ()
-runVBox = spawnOrSwitch myVMWorkspace $ spawnCmd "vbox-start" ["win8raw"]
-
-runGimp :: X ()
-runGimp = spawnOrSwitch myGimpWorkspace $ spawnCmd "gimp-2.10" []
-
-runXSane :: X ()
-runXSane = spawnOrSwitch myXSaneWorkspace $ spawnCmd "xsane" []
 
 myModMask :: KeyMask
 myModMask = mod4Mask
@@ -513,6 +494,11 @@ mkKeys ts c =
    , ("M-M1-h", "move down workspace", moveTo Prev HiddenNonEmptyWS)
    ]) ++
 
+  mkNamedSubmap "Dynamic Workspaces"
+  [ ("M-C-" ++ k, "launch/switch to " ++ n, spawnOrSwitch t a)
+  |  DynWorkspace { dwTag = t, dwCmd = Just (k, a), dwName = n } <- allDWs
+  ] ++
+
   mkNamedSubmap "Screens"
   [ ("M-l", "move up screen", nextScreen)
   , ("M-h", "move down screen", prevScreen)
@@ -543,9 +529,6 @@ mkKeys ts c =
   , ("M-C-t", "launch terminal", runTerm)
   , ("M-C-q", "launch calc", runCalc)
   , ("M-C-f", "launch file manager", runFileManager)
-  , ("M-C-v", "launch windows VM", runVBox)
-  , ("M-C-g", "launch GIMP", runGimp)
-  , ("M-C-x", "launch XSane", runXSane)
   ] ++
 
   mkNamedSubmap "Multimedia"

lib/WorkspaceMon.hs

@@ -1,11 +1,45 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
-module WorkspaceMon (M.fromList, runWorkspaceMon) where
+--------------------------------------------------------------------------------
+-- | Automatically Manage Dynamic Workspaces
+-- This is a somewhat convoluted wrapper for the Dymamic Workspaces module
+-- in the contrib library. The general behavior this allows:
+-- 1) launch app
+-- 2) move app to its own dynamic workspace
+-- 3) close app and remove dynamic workspace
+--
+-- The only sane way to do this is to monitor the lifetime of a PID on a dynamic
+-- workspace (effectively tying each dynamic workspace to a single PID). Xmonad
+-- is single threaded and thus cannot "wait" for PIDs to exit, so this spawns
+-- a separate thread outside XMonad that will in turn spawn monitor threads
+-- for each dynamic workspace. When these monitor threads detect that the app
+-- has closed, they will send an event to X which can be caught by Xmonad so
+-- the workspace can be removed.
+--
+-- What is the motivation? Some apps suck and don't play nice with others on
+-- normal workspaces, so I would rather have them go in their own little
+-- environment and misbehave.
+--
+-- Examples:
+-- 1) Gimp (lots of trays and floating windows)
+-- 2) Xsane (see Gimp)
+-- 3) Virtualbox (should always be by itself anyways)
+
+module WorkspaceMon
+  ( DynWorkspace(..)
+  , appendViewShift
+  , removeDynamicWorkspace
+  , runWorkspaceMon
+  , spawnOrSwitch
+  )
+where
 
 import           Process
 import           SendXMsg
 
-import qualified Data.Map                  as M
+import qualified Data.Map                         as M
+import           Data.Maybe
+import           Data.Semigroup
 
 import           Control.Concurrent
 import           Control.Monad
@@ -20,17 +54,49 @@ import           Graphics.X11.Xlib.Extras
 import           Graphics.X11.Xlib.Misc
 import           Graphics.X11.Xlib.Types
 
-import           System.Process            (Pid)
+import           System.Process                   (Pid)
+
+import           XMonad.Actions.DynamicWorkspaces
+import           XMonad.Core
+    ( Query
+    , ScreenId
+    , WorkspaceId
+    , X
+    , withWindowSet
+    )
+import           XMonad.Hooks.ManageHelpers       (MaybeManageHook)
+import           XMonad.ManageHook
+import           XMonad.Operations
+import qualified XMonad.StackSet                  as W
+
+--------------------------------------------------------------------------------
+-- | Dynamic Workspace datatype
+-- This hold all the data needed to tie an app to a particular dynamic workspace
+
+data DynWorkspace = DynWorkspace
+    { dwName  :: String
+    , dwTag   :: WorkspaceId
+    , dwClass :: String
+    , dwHook  :: [MaybeManageHook]
+    , dwCmd   :: Maybe (String, X ())
+    -- TODO this should also have the layout for this workspace
+    }
+
+--------------------------------------------------------------------------------
+-- | Manager thread
+-- The main thread that watches for new windows. When a match is found, this
+-- thread spawns a new thread the waits for the PID of the window to exit. When
+-- the PID exits, it sends a ClientMessage event to X
 
 -- TOOD it would be really nice if the manner we used to match windows was
 -- the same as that in XMonad itself (eg with Query types)
-type MatchTags = M.Map String String
+-- type MatchTags = M.Map String String
 
 type WatchedPIDs = MVar [Pid]
 
 data WConf = WConf
-    { display   :: Display
+    { display       :: Display
-    , matchTags :: MatchTags
+    , dynWorkspaces :: [DynWorkspace]
     }
 
 newtype W a = W (ReaderT WConf IO a)
@@ -46,8 +112,8 @@ runW c (W a) = runReaderT a c
 io :: MonadIO m => IO a -> m a
 io = liftIO
 
-runWorkspaceMon :: MatchTags -> IO ()
+runWorkspaceMon :: [DynWorkspace] -> IO ()
-runWorkspaceMon mts = do
+runWorkspaceMon dws = do
   dpy <- openDisplay ""
   root <- rootWindow dpy $ defaultScreen dpy
   curPIDs <- newMVar [] -- TODO this is ugly, use a mutable state monad
@@ -55,7 +121,7 @@ runWorkspaceMon mts = do
   allocaSetWindowAttributes $ \a -> do
     set_event_mask a substructureNotifyMask
     changeWindowAttributes dpy root cWEventMask a
-  let c = WConf { display = dpy, matchTags = mts }
+  let c = WConf { display = dpy, dynWorkspaces = dws }
   _ <- allocaXEvent $ \e ->
     runW c $ forever $ handle curPIDs =<< io (nextEvent dpy e >> getEvent e)
   return ()
@@ -67,8 +133,9 @@ handle :: WatchedPIDs -> Event -> W ()
 handle curPIDs MapNotifyEvent { ev_window = w } = do
   dpy <- asks display
   hint <- io $ getClassHint dpy w
-  mts <- asks matchTags
+  dws <- asks dynWorkspaces
-  let tag = M.lookup (resClass hint) mts
+  let m = M.fromList $ fmap (\DynWorkspace { dwTag = t, dwClass = c } -> (c, t)) dws
+  let tag = M.lookup (resClass hint) m
   io $ forM_ tag $ \t -> do
     a <- internAtom dpy "_NET_WM_PID" False
     pid <- getWindowProperty32 dpy a w
@@ -83,7 +150,6 @@ handle _ _ = return ()
 waitAndKill :: String -> Pid -> IO ()
 waitAndKill tag pid = waitUntilExit pid >> sendXMsg Workspace tag
 
-
 withUniquePid :: WatchedPIDs -> Pid -> IO () -> IO ()
 withUniquePid curPIDs pid f = do
   pids <- readMVar curPIDs
@@ -91,3 +157,39 @@ withUniquePid curPIDs pid f = do
     modifyMVar_ curPIDs (return . (pid:))
     f
     modifyMVar_ curPIDs (return . filter (/=pid))
+
+--------------------------------------------------------------------------------
+-- | Launching apps
+-- When launching apps on dymamic workspaces, first check if they are running
+-- and launch if not, then switch to their workspace
+
+wsOccupied :: Eq a1 => a1 -> W.StackSet a1 l a2 sid sd -> Bool
+wsOccupied tag ws = elem tag $ map W.tag $ filter (isJust . W.stack)
+  -- list of all workspaces with windows on them
+  -- TODO is there not a better way to do this?
+  $ W.workspace (W.current ws) : W.hidden ws ++ map W.workspace (W.visible ws)
+
+spawnOrSwitch :: WorkspaceId -> X () -> X ()
+spawnOrSwitch tag cmd = do
+  occupied <- withWindowSet $ return . wsOccupied tag
+  if occupied then windows $ W.view tag else cmd
+
+--------------------------------------------------------------------------------
+-- | Managehook
+-- Move windows to new workspace if they are part of a dynamic workspace
+
+viewShift
+  :: WorkspaceId -> Query (Endo (W.StackSet WorkspaceId l Window ScreenId sd))
+viewShift = doF . liftM2 (.) W.view W.shift
+
+appendViewShift
+  :: String -> Query (Endo (W.StackSet WorkspaceId l Window ScreenId sd))
+appendViewShift tag = liftX (appendWorkspace tag) >> viewShift tag
+
+--------------------------------------------------------------------------------
+-- | Eventhook
+-- When an app is closed, this will respond the event that is sent in the main
+-- XMonad thread
+
+removeDynamicWorkspace :: WorkspaceId -> X ()
+removeDynamicWorkspace = removeEmptyWorkspaceByTag