Take focused window to new context, Remember renamed workspaces

XMonad/Actions/Contexts.hs

@@ -1,40 +1,53 @@
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE StandaloneDeriving   #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TupleSections #-}
 
 module XMonad.Actions.Contexts (
     createContext,
     switchContext,
+    switchContextFixedWs,
     createAndSwitchContext,
+    createAndSwitchContextFixedWs,
     deleteContext,
+    deleteContextFixedWs,
     showCurrentContextName,
     listContextNames,
+    moveWindowToContext,
+    moveWindowToContextFixedWs,
     defaultContextName,
     showContextStorage
 ) where
 
+import System.IO
 
 import           Control.Monad               (when)
 import           Data.Foldable               (for_)
 import qualified Data.Map.Strict             as Map
+import           Data.Maybe                  (fromMaybe)
+import           Data.List                   as L
 
 import           XMonad
 import qualified XMonad.StackSet             as W
 import qualified XMonad.Util.ExtensibleState as XS
+import XMonad.Actions.WorkspaceNames         (setWorkspaceName, getWorkspaceName)
 
 
 type ContextName = String
 type ContextMap = Map.Map ContextName Context
 
-newtype Context = Context
-    { ctxWS :: WindowSet
+type WorkspaceNames = [(WorkspaceId, String)]
+
+data Context = Context
+    { windowSet      :: WindowSet
+    , workspaceNames :: WorkspaceNames
     } deriving Show
 
 deriving instance Read (Layout Window) => Read Context
 
 data ContextStorage = ContextStorage
     { currentCtxName :: !ContextName
-    , ctxMap         :: !ContextMap
+    , contextMap     :: !ContextMap
     } deriving Show
 
 deriving instance Read (Layout Window) => Read ContextStorage
@@ -44,52 +57,188 @@ instance Read (Layout Window) => ExtensionClass ContextStorage where
     extensionType = PersistentExtension
 
 defaultContextName :: ContextName
-defaultContextName = "default"
+defaultContextName = "Main"
 
 -------------------------------------------------------------------------------
 switchContext :: Read (Layout Window) => ContextName -> X Bool
-switchContext name = do
+switchContext = switchContextFixedWs []
+
+switchContextFixedWs :: Read (Layout Window) => [WorkspaceId] -> ContextName -> X Bool
+switchContextFixedWs fixedWs newContextName = do
     ctxStorage <- XS.get :: X ContextStorage
-    let (maybeNewCtx, newCtxMap) = findAndDelete name (ctxMap ctxStorage)
+    let (maybeNewCtx, ctxMap) = findAndDelete newContextName (contextMap ctxStorage) -- get new
     case maybeNewCtx of
         Nothing     -> return False
         Just newCtx -> do
             xstate <- get
-            let currentCtx = Context (windowset xstate)
-                newCtxMap' = Map.insert (currentCtxName ctxStorage) currentCtx newCtxMap
-            XS.put $ ContextStorage name newCtxMap'
-            windows (const $ ctxWS newCtx)
+            wsMap <- currentWorkspaceMap -- list of current workspaces
+
+            let oldContext = Context (windowset xstate) wsMap -- current Context, including current names of workspaces
+
+            let ctxMap' = Map.insert oldContextName oldContext ctxMap -- store current context in map
+                    where oldContextName = currentCtxName ctxStorage
+
+            XS.put $ ContextStorage newContextName ctxMap' -- store context
+
+            setWindowsAndWorkspaces fixedWs oldContext newCtx
+
             return True
 
 createAndSwitchContext :: Read (Layout Window) => ContextName -> X ()
-createAndSwitchContext name = do
+createAndSwitchContext = createAndSwitchContextFixedWs []
+
+createAndSwitchContextFixedWs :: Read (Layout Window) => [WorkspaceId] -> ContextName -> X ()
+createAndSwitchContextFixedWs fixedWs name = do
     createContext name
-    _ <- switchContext name
+    _ <- switchContextFixedWs fixedWs name
     return ()
 
+
+-- merge windows from second set into first set if the
+-- corresponding workspace id is in the list
+-- First Contxt is old; Second context is new
+-- Note: visible, hidden, and current workspace(s) have to be handled separately
+mergeContexts :: [WorkspaceId] -> Context -> Context -> Context
+mergeContexts ids ctxOld ctxNew = do
+
+    let stackNew = windowSet ctxNew -- Workspaces of new context
+
+    -- first, merge hidden workspaces
+    let newHidden = map selectWorkspace (W.hidden stackNew)
+
+    -- secondly, we merge visible workspaces
+    let newVisible = map selectScreen (W.visible stackNew)
+
+    -- finally, we handle the currently focused workspace
+    let newFocused = selectScreen (W.current stackNew)
+
+    -- update workspaces
+    let mergedStack = stackNew  {
+        W.hidden = newHidden,
+        W.visible = newVisible,
+        W.current = newFocused
+    }
+
+    -- copy workspace names
+    let mergedWsNames = zipWith selectWsName (workspaceNames ctxOld) (workspaceNames ctxNew)
+
+    Context mergedStack mergedWsNames
+
+        where
+            selectScreen screen = do
+                let ws = W.workspace screen
+                screen { W.workspace = selectWorkspace ws }
+
+            selectWorkspace ws = if W.tag ws `elem` ids then oldWs ws else ws
+
+            workspacesOld = W.workspaces (windowSet ctxOld)
+
+            oldWs ws = fromMaybe ws (find (\x -> W.tag ws == W.tag x) workspacesOld) -- if tag is not found in workspacesOld, return new ws
+
+
+            selectWsName (tag, nameOld) (_, nameNew) = if tag `elem` ids then (tag, nameOld) else (tag, nameNew)
+
+
+-- set the window set and apply the workspaceNames
+setWindowsAndWorkspaces :: [WorkspaceId] -> Context -> Context -> X ()
+setWindowsAndWorkspaces fixedWs oldContext newContext = do
+
+    -- copy fixed workspaces from curren context
+    let mergedContext = mergeContexts fixedWs oldContext newContext
+
+    -- let Context windowSet workspaceNames = mergeContexts
+    let Context windowSet workspaceNames = mergedContext
+
+    windows $ const windowSet -- hide old windows and show windows from new context
+    mapM_ (uncurry setWorkspaceName) workspaceNames
+
+
+-- Returns a map that contains all workspaces
+currentWorkspaceMap :: X WorkspaceNames
+currentWorkspaceMap = do
+    ws <- asks (workspaces . config) -- get list of Workspace tags
+
+    -- helper function to load the current name of the workspace
+    let f :: WorkspaceId -> X (WorkspaceId, String)
+        f tag = do
+            name <- getWorkspaceName tag :: X (Maybe String)
+            return (tag, fromMaybe "" name)
+
+    traverse f ws :: X WorkspaceNames -- traverse: Applies the functions and converts from [X (WorkspaceId, String)] to X [ (WorkspaceId, String) ]
+
+-- return the default workspace map
+defaultWorkspaces :: X WorkspaceNames
+defaultWorkspaces = do
+    ws <- asks (workspaces . config)
+    return $ map (,"") ws -- set every name to ""
+
+moveWindowToContext :: Read (Layout Window) => ContextName -> X Bool
+moveWindowToContext = moveWindowToContextFixedWs []
+
+-- switch to new context while taking the current active window with you
+moveWindowToContextFixedWs :: Read (Layout Window) => [WorkspaceId] -> ContextName -> X Bool
+moveWindowToContextFixedWs fixedWs name = do
+    ctxStorage <- XS.get :: X ContextStorage
+    let (maybeNewCtx, ctxMap) = findAndDelete name (contextMap ctxStorage)
+    case maybeNewCtx of
+        Nothing     -> return False -- context not found
+        Just newCtx -> do
+            maybeWindow <- W.peek <$> gets windowset -- get current active window
+            case maybeWindow of
+                Nothing -> return False -- no active window found
+                Just window -> do
+                    xstate <- get
+                    wsMap <- currentWorkspaceMap -- list of current workspaces
+
+                    let newWindowSet = W.delete  window (windowset xstate)
+                    let oldContext = Context newWindowSet wsMap -- current Context, including current names of workspaces
+                    let ctxMap' = Map.insert oldContextName oldContext ctxMap -- store current context in map
+                            where oldContextName = currentCtxName ctxStorage
+
+                    XS.put $ ContextStorage name ctxMap' -- store changes
+
+                    let newCtx' = Context newWindowSet newWorkspaceNames -- insert focused window in new context
+                            where newWindowSet = W.insertUp window (windowSet newCtx)
+                                  newWorkspaceNames = workspaceNames newCtx
+
+                    setWindowsAndWorkspaces fixedWs oldContext newCtx' -- load new context
+
+                    return True
+
+-- Creates a new context if not already existant
 createContext :: Read (Layout Window) => ContextName -> X ()
 createContext name = do
     ctxStorage <- XS.get :: X ContextStorage
     when (not (null name)
           && name /= currentCtxName ctxStorage
-          && name `Map.notMember` ctxMap ctxStorage) $ do
+          && name `Map.notMember` contextMap ctxStorage) $ do
         newWS' <- newWS
-        let newCtx = Context newWS'
-            newCtxMap = Map.insert name newCtx (ctxMap ctxStorage)
-        XS.put $ ctxStorage { ctxMap = newCtxMap }
+        defWs <- defaultWorkspaces
+        let newCtx = Context newWS' defWs -- create new context with new workspace names
+            newCtxMap = Map.insert name newCtx (contextMap ctxStorage)
+        XS.put $ ctxStorage { contextMap = newCtxMap }
+
 
 deleteContext :: Read (Layout Window) => ContextName -> X Bool
-deleteContext name = do
+deleteContext = deleteContextFixedWs []
+
+deleteContextFixedWs :: Read (Layout Window) => [WorkspaceId] -> ContextName -> X Bool
+deleteContextFixedWs ids name = do
     ctxStorage <- XS.get :: X ContextStorage
-    let (maybeCtx, newCtxMap) = findAndDelete name (ctxMap ctxStorage)
+    let (maybeCtx, newCtxMap) = findAndDelete name (contextMap ctxStorage)
     case maybeCtx of
-      Nothing  -> return False
-      Just ctx -> do
-          -- Kill all windows in that context
-          let windows' = W.allWindows $ ctxWS ctx
-          for_ windows' killWindow
-          XS.put $ ctxStorage { ctxMap = newCtxMap }
-          return True
+        Nothing  -> return False
+        Just ctx -> do
+            -- Kill windows in that context that are not on fixed workspaces
+            let workspaces' = filter (\ws -> W.tag ws `notElem` ids) $ W.workspaces $ windowSet ctx
+
+            for_ workspaces' killWindowsOnWs
+            XS.put $ ctxStorage { contextMap = newCtxMap }
+            return True
+
+                where
+                    getWindows = W.integrate' . W.stack
+                    killWindowsOnWs ws = for_ (getWindows ws) killWindow
 
 showCurrentContextName :: Read (Layout Window) => X String
 showCurrentContextName = do
@@ -99,7 +248,7 @@ showCurrentContextName = do
 listContextNames :: Read (Layout Window) => X [ContextName]
 listContextNames = do
     ctxStorage <- XS.get :: X ContextStorage
-    return $ Map.keys (ctxMap ctxStorage)
+    return $ Map.keys (contextMap ctxStorage)
 
 newWS :: X WindowSet
 newWS = withDisplay $ \dpy -> do
@@ -112,6 +261,7 @@ newWS = withDisplay $ \dpy -> do
         sds = map SD xinesc
     return $ W.new layout workspaces' sds
 
+
 findAndDelete :: ContextName -> ContextMap -> (Maybe Context, ContextMap)
 findAndDelete = Map.updateLookupWithKey (\_ _ -> Nothing)