mirror of
https://github.com/xmonad/xmonad-contrib.git
synced 2025-05-19 11:30:22 -07:00
312 lines
11 KiB
Haskell
312 lines
11 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
|
|
|
|
-- * Helper Functions
|
|
, switchProject
|
|
, shiftToProject
|
|
, lookupProject
|
|
, currentProject
|
|
, activateProject
|
|
) where
|
|
|
|
--------------------------------------------------------------------------------
|
|
import Control.Applicative ((<|>))
|
|
import Control.Monad (when, unless)
|
|
import Data.List (sort, union, stripPrefix)
|
|
import Data.Map.Strict (Map)
|
|
import qualified Data.Map.Strict as Map
|
|
import Data.Maybe (fromMaybe, isNothing)
|
|
import Data.Monoid ((<>))
|
|
import System.Directory (setCurrentDirectory, getHomeDirectory)
|
|
import XMonad
|
|
import XMonad.Actions.DynamicWorkspaces
|
|
import XMonad.Prompt
|
|
import XMonad.Prompt.Directory (directoryPrompt)
|
|
import XMonad.Prompt.Workspace (Wor(..))
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Add dynamic projects support to the given config.
|
|
dynamicProjects :: [Project] -> XConfig a -> XConfig a
|
|
dynamicProjects ps c =
|
|
c { startupHook = startupHook c <> dynamicProjectsStartupHook ps
|
|
, logHook = logHook c <> dynamicProjectsLogHook
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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 `fmap` 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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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)) $
|
|
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 c = projectPrompt c switch
|
|
where
|
|
switch :: ProjectTable -> ProjectName -> X ()
|
|
switch ps name = case Map.lookup name ps of
|
|
Just p -> switchProject p
|
|
Nothing | null name -> return ()
|
|
| otherwise -> directoryPrompt dirC "Project Dir: " (mkProject name)
|
|
|
|
dirC :: XPConfig
|
|
dirC = c { alwaysHighlight = False } -- Fix broken tab completion.
|
|
|
|
mkProject :: ProjectName -> FilePath -> X ()
|
|
mkProject name dir = do
|
|
let p = Project name dir Nothing
|
|
XS.modify $ \s -> s {projects = Map.insert name p $ projects s}
|
|
switchProject p
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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 c = projectPrompt c go
|
|
where
|
|
go :: ProjectTable -> ProjectName -> X ()
|
|
go ps name = shiftToProject . fromMaybe (defProject name) $
|
|
Map.lookup name ps
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Prompt for a project name.
|
|
projectPrompt :: XPConfig -> (ProjectTable -> ProjectName -> X ()) -> X ()
|
|
projectPrompt c f = do
|
|
ws <- map W.tag `fmap` gets (W.workspaces . windowset)
|
|
ps <- XS.gets projects
|
|
|
|
let names = sort (Map.keys ps `union` ws)
|
|
label = "Switch or Create Project: "
|
|
|
|
mkXPrompt (Wor label) c (mkComplFunFromList' names) (f ps)
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | Rename the current project.
|
|
renameProjectPrompt :: XPConfig -> X ()
|
|
renameProjectPrompt c = mkXPrompt (Wor "New Project Name: ") c (return . (:[])) go
|
|
where
|
|
go :: String -> X ()
|
|
go name = do
|
|
p <- currentProject
|
|
ps <- XS.gets projects
|
|
renameWorkspaceByName name
|
|
|
|
let p' = fromMaybe (p { projectName = name }) $ Map.lookup name ps
|
|
ps' = Map.insert name p' $ Map.delete (projectName p) ps
|
|
|
|
XS.modify $ \s -> s {projects = ps'}
|
|
activateProject p'
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- | 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
|