New module: XMonad.Actions.DynamicProjects

XMonad/Actions/DynamicProjects.hs

@@ -0,0 +1,289 @@
+{-# 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
+
+         -- * 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 (Map)
+import qualified Data.Map 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 and deleted as necessary.  This means you can create new
+-- project spaces on the fly as needed.  (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
+-- 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)
+  state <- XS.get
+  
+  unless (Just name == previousProject state) $ do
+    XS.modify $ \s -> s {previousProject = Just name}
+    activateProject $ case Map.lookup name (projects state) of
+      Nothing -> Project name "~/" Nothing
+      Just p  -> p
+
+--------------------------------------------------------------------------------
+-- | 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 $ case proj of
+    Just p  -> p
+    Nothing -> Project name "~/" Nothing
+
+--------------------------------------------------------------------------------
+-- | 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})
+          
+  -- Remove the old workspace (if empty) and activate the new
+  -- workspace.  The project will be activated by the log hook.
+  removeEmptyWorkspace
+  addWorkspace (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 c "Project Dir: " (mkProject name)
+
+    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 $ case Map.lookup name ps of
+      Just p  -> p
+      Nothing -> Project name "~/" Nothing
+
+--------------------------------------------------------------------------------
+-- | 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)
+  mkXPrompt (Wor "Project: ") c (mkComplFunFromList' names) (f ps)
+
+--------------------------------------------------------------------------------
+-- | 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

xmonad-contrib.cabal

@@ -101,6 +101,7 @@ library
                         XMonad.Actions.DynamicWorkspaces
                         XMonad.Actions.DynamicWorkspaceGroups
                         XMonad.Actions.DynamicWorkspaceOrder
+                        XMonad.Actions.DynamicProjects
                         XMonad.Actions.FindEmptyWorkspace
                         XMonad.Actions.FlexibleManipulate
                         XMonad.Actions.FlexibleResize