xmonad-masser/src/XMonad/TopicUtils.hs

{-# LANGUAGE TupleSections #-}
module XMonad.TopicUtils where

import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.List (isPrefixOf, nub, sortOn)
import XMonad.Actions.TopicSpace
import XMonad
import qualified Data.Map as M
import XMonad.Actions.GridSelect hiding (gridselectWorkspace)
import XMonad.Util.Run (safeSpawn)
import qualified XMonad.StackSet as W
import XMonad.Util.Dmenu (dmenu)
import XMonad.Actions.DynamicWorkspaces
import XMonad.Util.NamedWindows (getName)
import Data.Ord


realTopicDir :: M.Map String FilePath -> X String
realTopicDir tg = do
  topic <- realTopic
  return . fromMaybe "" . M.lookup topic $ tg


safeRunInTerm :: Dir -> Maybe String -> X ()
safeRunInTerm dir Nothing = safeSpawn "urxvt" ["-cd", dir]
safeRunInTerm dir (Just command) = safeSpawn "urxvt" ["-cd", dir, "-e", command]

inactiveTags :: X [WorkspaceId]
inactiveTags = map W.tag . inactive' <$> gets windowset
    where
        inactive' s =
          let current = W.currentTag s
          in W.hidden s ++ map W.workspace (filter (\w -> current /= (W.tag . W.workspace) w) (W.visible s))

gridselectMove :: GSConfig WorkspaceId -> X ()
gridselectMove conf = do
    topics <- inactiveTags
    gridselect conf [(x,x) | x <- topics] >>= maybe (return ()) (windows . W.shift)

dmenuMove :: X ()
dmenuMove = do
  topics <- inactiveTags
  dmenu topics >>= \t -> windows (W.shift t)

gsConfig :: GSConfig Window
gsConfig = def{gs_navigate = navNSearch, gs_colorizer = fromClassName}

-- Copied from gridselect and modified so that it doesn't contain current and visible
-- - Doesn't contain current and visible
-- - Takes a topicspace viewfunc
gridselectWorkspace :: GSConfig WorkspaceId -> (WorkspaceId -> X ()) -> X ()
gridselectWorkspace conf viewFunc = withWindowSet $ \ws -> do
  let wss = map W.tag . W.hidden $ ws
  gridselect conf (zip wss wss) >>= flip whenJust viewFunc

gotoSelected' :: GSConfig Window -> X ()
gotoSelected' gsconf = do
    w <- gridselectCurrentWindows gsconf
    maybe (return ()) (windows . W.focusWindow) w

gridselectCurrentWindows :: GSConfig Window -> X (Maybe Window)
gridselectCurrentWindows gsconf = windowMap >>= gridselect gsconf
    where
        getName' = fmap show . getName
        kvPair w = (, w) <$> getName' w
        windowMap = do
            ws <- gets (nub . W.integrate' . W.stack . W.workspace . W.current . windowset)
            mapM kvPair ws

visualSelect :: TopicConfig -> X ()
visualSelect cfg = gridselectWorkspace def{gs_navigate = navNSearch, gs_colorizer = stringColorizer} (switchTopic cfg)

realTopic :: X String
realTopic = gets (real . W.tag . W.workspace . W.current . windowset)
  where real = takeWhile (/= ':')

currentTopicAction' :: TopicConfig -> X ()
currentTopicAction' tg = do
  topic <- realTopic
  topicAction tg topic

copyTopic :: X ()
copyTopic = do
  currentTopic <- realTopic
  lastN <- gets (listToMaybe . sortOn Down . mapMaybe (subset currentTopic . W.tag) . W.workspaces . windowset)
  addWorkspace (currentTopic ++ ":" ++ show (maybe 2 (+1) lastN))
  where
    subset :: String -> String -> Maybe Int
    subset topic other = if topic `isPrefixOf` other then readM $ tail' $ dropWhile (/= ':') other else Nothing
    readM a = case reads a of
               [(x,_)] -> Just x
               _ -> Nothing
    tail' [] = []
    tail' xs = tail xs