Improve prompts for X.A.DynamicProjects

CHANGES.md

@@ -75,6 +75,13 @@
     as we do for wrong key press.
 
 
+  * `XMonad.Actions.DynamicProjects`
+
+    - Added function to change the working directory (`changeProjectDirPrompt`)
+
+    - All of the prompts are now multiple mode prompts.  Try using the
+      `changeModeKey` in a prompt and see what happens!
+
 ## 0.12 (December 14, 2015)
 
 ### Breaking Changes

XMonad/Actions/DynamicProjects.hs

@@ -31,6 +31,7 @@ module XMonad.Actions.DynamicProjects
        , switchProjectPrompt
        , shiftToProjectPrompt
        , renameProjectPrompt
+       , changeProjectDirPrompt
 
          -- * Helper Functions
        , switchProject
@@ -43,6 +44,7 @@ module XMonad.Actions.DynamicProjects
 --------------------------------------------------------------------------------
 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
@@ -52,8 +54,7 @@ import System.Directory (setCurrentDirectory, getHomeDirectory)
 import XMonad
 import XMonad.Actions.DynamicWorkspaces
 import XMonad.Prompt
-import XMonad.Prompt.Directory (directoryPrompt)
+import XMonad.Prompt.Directory
-import XMonad.Prompt.Workspace (Wor(..))
 import qualified XMonad.StackSet as W
 import qualified XMonad.Util.ExtensibleState as XS
 
@@ -142,6 +143,48 @@ data ProjectState = ProjectState
 instance ExtensionClass ProjectState where
   initialValue = ProjectState Map.empty Nothing
 
+--------------------------------------------------------------------------------
+-- Internal types for working with XPrompt.
+data ProjectPrompt = ProjectPrompt 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 DirMode _) =
+    let xpt = directoryMultipleModes "" (const $ return ())
+    in completionFunction xpt
+  completionFunction (ProjectPrompt _ ns) = mkComplFunFromList' 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
+    modifyProject (\p -> p { projectDirectory = dir })
+
 --------------------------------------------------------------------------------
 -- | Add dynamic projects support to the given config.
 dynamicProjects :: [Project] -> XConfig a -> XConfig a
@@ -198,6 +241,21 @@ currentProject = do
   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 ()
@@ -220,22 +278,11 @@ switchProject p = do
 -- | 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
+switchProjectPrompt = projectPrompt [ SwitchMode
-  where
+                                    , ShiftMode
-    switch :: ProjectTable -> ProjectName -> X ()
+                                    , RenameMode
-    switch ps name = case Map.lookup name ps of
+                                    , DirMode
-      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.
@@ -248,40 +295,44 @@ shiftToProject p = do
 -- | Prompts for a project name and then shifts the currently focused
 -- window to that project.
 shiftToProjectPrompt :: XPConfig -> X ()
-shiftToProjectPrompt c = projectPrompt c go
+shiftToProjectPrompt = projectPrompt [ ShiftMode
-  where
+                                     , RenameMode
-    go :: ProjectTable -> ProjectName -> X ()
+                                     , SwitchMode
-    go ps name = shiftToProject . fromMaybe (defProject name) $
+                                     , DirMode
-                 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
+renameProjectPrompt = projectPrompt [ RenameMode
-  where
+                                    , DirMode
-    go :: String -> X ()
+                                    , SwitchMode
-    go name = do
+                                    , ShiftMode
-      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
+-- | 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
+                                       ]
 
-      XS.modify $ \s -> s {projects = ps'}
+--------------------------------------------------------------------------------
-      activateProject p'
+-- | Prompt for a project name.
+projectPrompt :: [ProjectMode] -> XPConfig -> X ()
+projectPrompt submodes c = do
+  ws <- map W.tag `fmap` gets (W.workspaces . windowset)
+  ps <- XS.gets projects
+
+  let names = sort (Map.keys ps `union` ws)
+      modes = map (\m -> XPT $ ProjectPrompt m names) submodes
+
+  mkXPromptWithModes modes c
 
 --------------------------------------------------------------------------------
 -- | Activate a project by updating the working directory and