mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-05-19 03:20:21 -07:00
78d526d1dd
Starting with 5240116f3cdf169e3aa226d9f8206a5f5b99c867 we only support GHC versions 8.4.4 and up (more precisely, the GHC version associated with stackage lts-12 and up). The imports in question are now in Prelude and need not be imported explicitly.
364 lines
14 KiB
Haskell
364 lines
14 KiB
Haskell
{-# LANGUAGE DeriveDataTypeable #-}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- |
|
|
-- Module : XMonad.Actions.DynamicProjects
|
|
-- Copyright : (c) Peter J. Jones
|
|
-- License : BSD3-style (see LICENSE)
|
|
--
|
|
-- Maintainer : Peter Jones <pjones@devalot.com>
|
|
-- Stability : unstable
|
|
-- Portability : not portable
|
|
--
|
|
-- Imbues workspaces with additional features so they can be treated
|
|
-- as individual project areas.
|
|
--------------------------------------------------------------------------------
|
|
module XMonad.Actions.DynamicProjects
|
|
( -- * Overview
|
|
-- $overview
|
|
|
|
-- * Usage
|
|
-- $usage
|
|
|
|
-- * Types
|
|
Project (..)
|
|
, ProjectName
|
|
|
|
-- * Hooks
|
|
, dynamicProjects
|
|
|
|
-- * Bindings
|
|
, switchProjectPrompt
|
|
, shiftToProjectPrompt
|
|
, renameProjectPrompt
|
|
, changeProjectDirPrompt
|
|
|
|
-- * Helper Functions
|
|
, switchProject
|
|
, shiftToProject
|
|
, lookupProject
|
|
, currentProject
|
|
, activateProject
|
|
) where
|
|
|
|
--------------------------------------------------------------------------------
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad (when, unless)
|
|
import Data.Char (isSpace)
|
|
import Data.List (sort, union, stripPrefix)
|
|
import Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe (fromMaybe, isNothing)
|
|
import System.Directory (setCurrentDirectory, getHomeDirectory, makeAbsolute)
|
|
import XMonad
|
|
import XMonad.Actions.DynamicWorkspaces
|
|
import XMonad.Prompt
|
|
import XMonad.Prompt.Directory
|
|
import qualified XMonad.StackSet as W
|
|
import qualified XMonad.Util.ExtensibleState as XS
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- $overview
|
|
-- Inspired by @TopicSpace@, @DynamicWorkspaces@, and @WorkspaceDir@,
|
|
-- @DynamicProjects@ treats workspaces as projects while maintaining
|
|
-- compatibility with all existing workspace-related functionality in
|
|
-- XMonad.
|
|
--
|
|
-- Instead of using generic workspace names such as @3@ or @work@,
|
|
-- @DynamicProjects@ allows you to dedicate workspaces to specific
|
|
-- projects and then switch between projects easily.
|
|
--
|
|
-- A project is made up of a name, working directory, and a start-up
|
|
-- hook. When you switch to a workspace, @DynamicProjects@ changes
|
|
-- the working directory to the one configured for the matching
|
|
-- project. If the workspace doesn't have any windows, the project's
|
|
-- start-up hook is executed. This allows you to launch applications
|
|
-- or further configure the workspace/project.
|
|
--
|
|
-- When using the @switchProjectPrompt@ function, workspaces are
|
|
-- created as needed. This means you can create new project spaces
|
|
-- (and therefore workspaces) on the fly. (These dynamic projects are
|
|
-- not preserved across restarts.)
|
|
--
|
|
-- Additionally, frequently used projects can be configured statically
|
|
-- in your XMonad configuration. Doing so allows you to configure the
|
|
-- per-project start-up hook.
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- $usage
|
|
-- To use @DynamicProjects@ you need to add it to your XMonad
|
|
-- configuration and then configure some optional key bindings.
|
|
--
|
|
-- > import XMonad.Actions.DynamicProjects
|
|
--
|
|
-- Start by defining some projects:
|
|
--
|
|
-- > projects :: [Project]
|
|
-- > projects =
|
|
-- > [ Project { projectName = "scratch"
|
|
-- > , projectDirectory = "~/"
|
|
-- > , projectStartHook = Nothing
|
|
-- > }
|
|
-- >
|
|
-- > , Project { projectName = "browser"
|
|
-- > , projectDirectory = "~/download"
|
|
-- > , projectStartHook = Just $ do spawn "conkeror"
|
|
-- > spawn "chromium"
|
|
-- > }
|
|
-- > ]
|
|
--
|
|
-- Then inject @DynamicProjects@ into your XMonad configuration:
|
|
--
|
|
-- > main = xmonad $ dynamicProjects projects def
|
|
--
|
|
-- And finally, configure some optional key bindings:
|
|
--
|
|
-- > , ((modm, xK_space), switchProjectPrompt)
|
|
-- > , ((modm, xK_slash), shiftToProjectPrompt)
|
|
--
|
|
-- For detailed instructions on editing your key bindings, see
|
|
-- "XMonad.Doc.Extending#Editing_key_bindings".
|
|
|
|
--------------------------------------------------------------------------------
|
|
type ProjectName = String
|
|
type ProjectTable = Map ProjectName Project
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Details about a workspace that represents a project.
|
|
data Project = Project
|
|
{ projectName :: !ProjectName -- ^ Workspace name.
|
|
, projectDirectory :: !FilePath -- ^ Working directory.
|
|
, projectStartHook :: !(Maybe (X ())) -- ^ Optional start-up hook.
|
|
} deriving Typeable
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Internal project state.
|
|
data ProjectState = ProjectState
|
|
{ projects :: !ProjectTable
|
|
, previousProject :: !(Maybe WorkspaceId)
|
|
} deriving Typeable
|
|
|
|
--------------------------------------------------------------------------------
|
|
instance ExtensionClass ProjectState where
|
|
initialValue = ProjectState Map.empty Nothing
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Internal types for working with XPrompt.
|
|
data ProjectPrompt = ProjectPrompt XPConfig ProjectMode [ProjectName]
|
|
data ProjectMode = SwitchMode | ShiftMode | RenameMode | DirMode
|
|
|
|
instance XPrompt ProjectPrompt where
|
|
showXPrompt (ProjectPrompt _ submode _) =
|
|
case submode of
|
|
SwitchMode -> "Switch or Create Project: "
|
|
ShiftMode -> "Send Window to Project: "
|
|
RenameMode -> "New Project Name: "
|
|
DirMode -> "Change Project Directory: "
|
|
|
|
completionFunction (ProjectPrompt _ RenameMode _) = return . (:[])
|
|
completionFunction (ProjectPrompt c DirMode _) =
|
|
let xpt = directoryMultipleModes' (complCaseSensitivity c) "" (const $ return ())
|
|
in completionFunction xpt
|
|
completionFunction (ProjectPrompt c _ ns) = mkComplFunFromList' c ns
|
|
|
|
modeAction (ProjectPrompt _ SwitchMode _) buf auto = do
|
|
let name = if null auto then buf else auto
|
|
ps <- XS.gets projects
|
|
|
|
case Map.lookup name ps of
|
|
Just p -> switchProject p
|
|
Nothing | null name -> return ()
|
|
| otherwise -> switchProject (defProject name)
|
|
|
|
modeAction (ProjectPrompt _ ShiftMode _) buf auto = do
|
|
let name = if null auto then buf else auto
|
|
ps <- XS.gets projects
|
|
shiftToProject . fromMaybe (defProject name) $ Map.lookup name ps
|
|
|
|
modeAction (ProjectPrompt _ RenameMode _) name _ =
|
|
when (not (null name) && not (all isSpace name)) $ do
|
|
renameWorkspaceByName name
|
|
modifyProject (\p -> p { projectName = name })
|
|
|
|
modeAction (ProjectPrompt _ DirMode _) buf auto = do
|
|
let dir' = if null auto then buf else auto
|
|
dir <- io $ makeAbsolute dir'
|
|
modifyProject (\p -> p { projectDirectory = dir })
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Add dynamic projects support to the given config.
|
|
dynamicProjects :: [Project] -> XConfig a -> XConfig a
|
|
dynamicProjects ps c =
|
|
c { startupHook = dynamicProjectsStartupHook ps <> startupHook c
|
|
, logHook = dynamicProjectsLogHook <> logHook c
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Log hook for tracking workspace changes.
|
|
dynamicProjectsLogHook :: X ()
|
|
dynamicProjectsLogHook = do
|
|
name <- gets (W.tag . W.workspace . W.current . windowset)
|
|
xstate <- XS.get
|
|
|
|
unless (Just name == previousProject xstate) $ do
|
|
XS.put (xstate {previousProject = Just name})
|
|
activateProject . fromMaybe (defProject name) $
|
|
Map.lookup name (projects xstate)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Start-up hook for recording configured projects.
|
|
dynamicProjectsStartupHook :: [Project] -> X ()
|
|
dynamicProjectsStartupHook ps = XS.modify go
|
|
where
|
|
go :: ProjectState -> ProjectState
|
|
go s = s {projects = update $ projects s}
|
|
|
|
update :: ProjectTable -> ProjectTable
|
|
update = Map.union (Map.fromList $ map entry ps)
|
|
|
|
entry :: Project -> (ProjectName, Project)
|
|
entry p = (projectName p, addDefaultHook p)
|
|
|
|
-- Force the hook to be a @Just@ so that it doesn't automatically
|
|
-- get deleted when switching away from a workspace with no
|
|
-- windows.
|
|
addDefaultHook :: Project -> Project
|
|
addDefaultHook p = p { projectStartHook = projectStartHook p <|>
|
|
Just (return ())
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Find a project based on its name.
|
|
lookupProject :: ProjectName -> X (Maybe Project)
|
|
lookupProject name = Map.lookup name <$> XS.gets projects
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Fetch the current project (the one being used for the currently
|
|
-- active workspace).
|
|
currentProject :: X Project
|
|
currentProject = do
|
|
name <- gets (W.tag . W.workspace . W.current . windowset)
|
|
proj <- lookupProject name
|
|
return $ fromMaybe (defProject name) proj
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Modify the current project using a pure function.
|
|
modifyProject :: (Project -> Project) -> X ()
|
|
modifyProject f = do
|
|
p <- currentProject
|
|
ps <- XS.gets projects
|
|
|
|
-- If a project is renamed to match another project, the old project
|
|
-- will be removed and replaced with this one.
|
|
let new = f p
|
|
ps' = Map.insert (projectName new) new $ Map.delete (projectName p) ps
|
|
|
|
XS.modify $ \s -> s {projects = ps'}
|
|
activateProject new
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Switch to the given project.
|
|
switchProject :: Project -> X ()
|
|
switchProject p = do
|
|
oldws <- gets (W.workspace . W.current . windowset)
|
|
oldp <- currentProject
|
|
|
|
let name = W.tag oldws
|
|
ws = W.integrate' (W.stack oldws)
|
|
|
|
-- If the project we are switching away from has no windows, and
|
|
-- it's a dynamic project, remove it from the configuration.
|
|
when (null ws && isNothing (projectStartHook oldp)) $ do
|
|
removeWorkspaceByTag name -- also remove the old workspace
|
|
XS.modify (\s -> s {projects = Map.delete name $ projects s})
|
|
|
|
appendWorkspace (projectName p)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Prompt for a project name and then switch to it. Automatically
|
|
-- creates a project if a new name is returned from the prompt.
|
|
switchProjectPrompt :: XPConfig -> X ()
|
|
switchProjectPrompt = projectPrompt [ SwitchMode
|
|
, ShiftMode
|
|
, RenameMode
|
|
, DirMode
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Shift the currently focused window to the given project.
|
|
shiftToProject :: Project -> X ()
|
|
shiftToProject p = do
|
|
addHiddenWorkspace (projectName p)
|
|
windows (W.shift $ projectName p)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Prompts for a project name and then shifts the currently focused
|
|
-- window to that project.
|
|
shiftToProjectPrompt :: XPConfig -> X ()
|
|
shiftToProjectPrompt = projectPrompt [ ShiftMode
|
|
, RenameMode
|
|
, SwitchMode
|
|
, DirMode
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Rename the current project.
|
|
renameProjectPrompt :: XPConfig -> X ()
|
|
renameProjectPrompt = projectPrompt [ RenameMode
|
|
, DirMode
|
|
, SwitchMode
|
|
, ShiftMode
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Change the working directory used for the current project.
|
|
--
|
|
-- NOTE: This will only affect new processed started in this project.
|
|
-- Existing processes will maintain the previous working directory.
|
|
changeProjectDirPrompt :: XPConfig -> X ()
|
|
changeProjectDirPrompt = projectPrompt [ DirMode
|
|
, SwitchMode
|
|
, ShiftMode
|
|
, RenameMode
|
|
]
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Prompt for a project name.
|
|
projectPrompt :: [ProjectMode] -> XPConfig -> X ()
|
|
projectPrompt submodes c = do
|
|
ws <- map W.tag <$> gets (W.workspaces . windowset)
|
|
ps <- XS.gets projects
|
|
|
|
let names = sort (Map.keys ps `union` ws)
|
|
modes = map (\m -> XPT $ ProjectPrompt c m names) submodes
|
|
|
|
mkXPromptWithModes modes c
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Activate a project by updating the working directory and
|
|
-- possibly running its start-up hook. This function is automatically
|
|
-- invoked when the workspace changes.
|
|
activateProject :: Project -> X ()
|
|
activateProject p = do
|
|
ws <- gets (W.integrate' . W.stack . W.workspace . W.current . windowset)
|
|
home <- io getHomeDirectory
|
|
|
|
-- Change to the project's directory.
|
|
catchIO (setCurrentDirectory $ expandHome home $ projectDirectory p)
|
|
|
|
-- Possibly run the project's startup hook.
|
|
when (null ws) $ fromMaybe (return ()) (projectStartHook p)
|
|
|
|
where
|
|
|
|
-- Replace an initial @~@ character with the home directory.
|
|
expandHome :: FilePath -> FilePath -> FilePath
|
|
expandHome home dir = case stripPrefix "~" dir of
|
|
Nothing -> dir
|
|
Just xs -> home ++ xs
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Default project.
|
|
defProject :: ProjectName -> Project
|
|
defProject name = Project name "~/" Nothing
|