--------------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Actions.DynamicProjects
-- Description :  Treat workspaces as individual project areas.
-- 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
       , modifyProject
       ) where

--------------------------------------------------------------------------------
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import System.Directory (setCurrentDirectory, getHomeDirectory, makeAbsolute)
import XMonad.Prelude
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
  { Project -> ProjectName
projectName      :: !ProjectName    -- ^ Workspace name.
  , Project -> ProjectName
projectDirectory :: !FilePath       -- ^ Working directory.
  , Project -> Maybe (X ())
projectStartHook :: !(Maybe (X ())) -- ^ Optional start-up hook.
  }

--------------------------------------------------------------------------------
-- | Internal project state.
data ProjectState = ProjectState
  { ProjectState -> ProjectTable
projects        :: !ProjectTable
  , ProjectState -> Maybe ProjectName
previousProject :: !(Maybe WorkspaceId)
  }

--------------------------------------------------------------------------------
instance ExtensionClass ProjectState where
  initialValue :: ProjectState
initialValue = ProjectTable -> Maybe ProjectName -> ProjectState
ProjectState ProjectTable
forall k a. Map k a
Map.empty Maybe ProjectName
forall a. Maybe a
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 -> ProjectName
showXPrompt (ProjectPrompt XPConfig
_ ProjectMode
submode [ProjectName]
_) =
    case ProjectMode
submode of
      ProjectMode
SwitchMode -> ProjectName
"Switch or Create Project: "
      ProjectMode
ShiftMode  -> ProjectName
"Send Window to Project: "
      ProjectMode
RenameMode -> ProjectName
"New Project Name: "
      ProjectMode
DirMode    -> ProjectName
"Change Project Directory: "

  completionFunction :: ProjectPrompt -> ComplFunction
completionFunction (ProjectPrompt XPConfig
_ ProjectMode
RenameMode [ProjectName]
_) = [ProjectName] -> IO [ProjectName]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ProjectName] -> IO [ProjectName])
-> (ProjectName -> [ProjectName]) -> ComplFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectName -> [ProjectName] -> [ProjectName]
forall a. a -> [a] -> [a]
:[])
  completionFunction (ProjectPrompt XPConfig
c ProjectMode
DirMode [ProjectName]
_) =
    let xpt :: XPType
xpt = ComplCaseSensitivity
-> ProjectName -> (ProjectName -> X ()) -> XPType
directoryMultipleModes' (XPConfig -> ComplCaseSensitivity
complCaseSensitivity XPConfig
c) ProjectName
"" (X () -> ProjectName -> X ()
forall a b. a -> b -> a
const (X () -> ProjectName -> X ()) -> X () -> ProjectName -> X ()
forall a b. (a -> b) -> a -> b
$ () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    in XPType -> ComplFunction
forall t. XPrompt t => t -> ComplFunction
completionFunction XPType
xpt
  completionFunction (ProjectPrompt XPConfig
c ProjectMode
_ [ProjectName]
ns) = XPConfig -> [ProjectName] -> ComplFunction
mkComplFunFromList' XPConfig
c [ProjectName]
ns

  modeAction :: ProjectPrompt -> ProjectName -> ProjectName -> X ()
modeAction (ProjectPrompt XPConfig
_ ProjectMode
SwitchMode [ProjectName]
_) ProjectName
buf ProjectName
auto = do
    let name :: ProjectName
name = if ProjectName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
auto then ProjectName
buf else ProjectName
auto
    ProjectTable
ps <- (ProjectState -> ProjectTable) -> X ProjectTable
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects

    case ProjectName -> ProjectTable -> Maybe Project
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectName
name ProjectTable
ps of
      Just Project
p              -> Project -> X ()
switchProject Project
p
      Maybe Project
Nothing | ProjectName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
name -> () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              | Bool
otherwise -> Project -> X ()
switchProject (ProjectName -> Project
defProject ProjectName
name)

  modeAction (ProjectPrompt XPConfig
_ ProjectMode
ShiftMode [ProjectName]
_) ProjectName
buf ProjectName
auto = do
    let name :: ProjectName
name = if ProjectName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
auto then ProjectName
buf else ProjectName
auto
    ProjectTable
ps <- (ProjectState -> ProjectTable) -> X ProjectTable
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects
    Project -> X ()
shiftToProject (Project -> X ())
-> (Maybe Project -> Project) -> Maybe Project -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Project -> Maybe Project -> Project
forall a. a -> Maybe a -> a
fromMaybe (ProjectName -> Project
defProject ProjectName
name) (Maybe Project -> X ()) -> Maybe Project -> X ()
forall a b. (a -> b) -> a -> b
$ ProjectName -> ProjectTable -> Maybe Project
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectName
name ProjectTable
ps

  modeAction (ProjectPrompt XPConfig
_ ProjectMode
RenameMode [ProjectName]
_) ProjectName
name ProjectName
_ =
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (ProjectName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
name) Bool -> Bool -> Bool
&& Bool -> Bool
not ((Char -> Bool) -> ProjectName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace ProjectName
name)) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
      ProjectName -> X ()
renameWorkspaceByName ProjectName
name
      (Project -> Project) -> X ()
modifyProject (\Project
p -> Project
p { projectName :: ProjectName
projectName = ProjectName
name })

  modeAction (ProjectPrompt XPConfig
_ ProjectMode
DirMode [ProjectName]
_) ProjectName
buf ProjectName
auto = do
    let dir' :: ProjectName
dir' = if ProjectName -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
auto then ProjectName
buf else ProjectName
auto
    ProjectName
dir <- IO ProjectName -> X ProjectName
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ProjectName -> X ProjectName)
-> IO ProjectName -> X ProjectName
forall a b. (a -> b) -> a -> b
$ ProjectName -> IO ProjectName
makeAbsolute ProjectName
dir'
    (Project -> Project) -> X ()
modifyProject (\Project
p -> Project
p { projectDirectory :: ProjectName
projectDirectory = ProjectName
dir })

--------------------------------------------------------------------------------
-- | Add dynamic projects support to the given config.
dynamicProjects :: [Project] -> XConfig a -> XConfig a
dynamicProjects :: forall (a :: * -> *). [Project] -> XConfig a -> XConfig a
dynamicProjects [Project]
ps XConfig a
c =
  XConfig a
c { startupHook :: X ()
startupHook     = [Project] -> X ()
dynamicProjectsStartupHook [Project]
ps X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> XConfig a -> X ()
forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig a
c
    , logHook :: X ()
logHook         = X ()
dynamicProjectsLogHook        X () -> X () -> X ()
forall a. Semigroup a => a -> a -> a
<> XConfig a -> X ()
forall (l :: * -> *). XConfig l -> X ()
logHook XConfig a
c
    }

--------------------------------------------------------------------------------
-- | Log hook for tracking workspace changes.
dynamicProjectsLogHook :: X ()
dynamicProjectsLogHook :: X ()
dynamicProjectsLogHook = do
  ProjectName
name   <- (XState -> ProjectName) -> X ProjectName
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Workspace ProjectName (Layout Window) Window -> ProjectName
forall i l a. Workspace i l a -> i
W.tag (Workspace ProjectName (Layout Window) Window -> ProjectName)
-> (XState -> Workspace ProjectName (Layout Window) Window)
-> XState
-> ProjectName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
-> Workspace ProjectName (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> Workspace ProjectName (Layout Window) Window)
-> (XState
    -> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Workspace ProjectName (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
-> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> (XState
    -> StackSet
         ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     ProjectName (Layout Window) Window ScreenId ScreenDetail
windowset)
  ProjectState
xstate <- X ProjectState
forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get

  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just ProjectName
name Maybe ProjectName -> Maybe ProjectName -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectState -> Maybe ProjectName
previousProject ProjectState
xstate) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    ProjectState -> X ()
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (ProjectState
xstate {previousProject :: Maybe ProjectName
previousProject = ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just ProjectName
name})
    Project -> X ()
activateProject (Project -> X ())
-> (Maybe Project -> Project) -> Maybe Project -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Project -> Maybe Project -> Project
forall a. a -> Maybe a -> a
fromMaybe (ProjectName -> Project
defProject ProjectName
name) (Maybe Project -> X ()) -> Maybe Project -> X ()
forall a b. (a -> b) -> a -> b
$
      ProjectName -> ProjectTable -> Maybe Project
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectName
name (ProjectState -> ProjectTable
projects ProjectState
xstate)

--------------------------------------------------------------------------------
-- | Start-up hook for recording configured projects.
dynamicProjectsStartupHook :: [Project] -> X ()
dynamicProjectsStartupHook :: [Project] -> X ()
dynamicProjectsStartupHook [Project]
ps = (ProjectState -> ProjectState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ProjectState -> ProjectState
go
  where
    go :: ProjectState -> ProjectState
    go :: ProjectState -> ProjectState
go ProjectState
s = ProjectState
s {projects :: ProjectTable
projects = ProjectTable -> ProjectTable
update (ProjectTable -> ProjectTable) -> ProjectTable -> ProjectTable
forall a b. (a -> b) -> a -> b
$ ProjectState -> ProjectTable
projects ProjectState
s}

    update :: ProjectTable -> ProjectTable
    update :: ProjectTable -> ProjectTable
update = ProjectTable -> ProjectTable -> ProjectTable
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([(ProjectName, Project)] -> ProjectTable
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ProjectName, Project)] -> ProjectTable)
-> [(ProjectName, Project)] -> ProjectTable
forall a b. (a -> b) -> a -> b
$ (Project -> (ProjectName, Project))
-> [Project] -> [(ProjectName, Project)]
forall a b. (a -> b) -> [a] -> [b]
map Project -> (ProjectName, Project)
entry [Project]
ps)

    entry :: Project -> (ProjectName, Project)
    entry :: Project -> (ProjectName, Project)
entry Project
p = (Project -> ProjectName
projectName Project
p, Project -> Project
addDefaultHook Project
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 :: Project -> Project
addDefaultHook Project
p = Project
p { projectStartHook :: Maybe (X ())
projectStartHook = Project -> Maybe (X ())
projectStartHook Project
p Maybe (X ()) -> Maybe (X ()) -> Maybe (X ())
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                                              X () -> Maybe (X ())
forall a. a -> Maybe a
Just (() -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                         }

--------------------------------------------------------------------------------
-- | Find a project based on its name.
lookupProject :: ProjectName -> X (Maybe Project)
lookupProject :: ProjectName -> X (Maybe Project)
lookupProject ProjectName
name = ProjectName -> ProjectTable -> Maybe Project
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectName
name (ProjectTable -> Maybe Project)
-> X ProjectTable -> X (Maybe Project)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ProjectState -> ProjectTable) -> X ProjectTable
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects

--------------------------------------------------------------------------------
-- | Fetch the current project (the one being used for the currently
-- active workspace).
currentProject :: X Project
currentProject :: X Project
currentProject = do
  ProjectName
name <- (XState -> ProjectName) -> X ProjectName
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Workspace ProjectName (Layout Window) Window -> ProjectName
forall i l a. Workspace i l a -> i
W.tag (Workspace ProjectName (Layout Window) Window -> ProjectName)
-> (XState -> Workspace ProjectName (Layout Window) Window)
-> XState
-> ProjectName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
-> Workspace ProjectName (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> Workspace ProjectName (Layout Window) Window)
-> (XState
    -> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Workspace ProjectName (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
-> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> (XState
    -> StackSet
         ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     ProjectName (Layout Window) Window ScreenId ScreenDetail
windowset)
  Maybe Project
proj <- ProjectName -> X (Maybe Project)
lookupProject ProjectName
name
  Project -> X Project
forall (m :: * -> *) a. Monad m => a -> m a
return (Project -> X Project) -> Project -> X Project
forall a b. (a -> b) -> a -> b
$ Project -> Maybe Project -> Project
forall a. a -> Maybe a -> a
fromMaybe (ProjectName -> Project
defProject ProjectName
name) Maybe Project
proj

--------------------------------------------------------------------------------
-- | Modify the current project using a pure function.
modifyProject :: (Project -> Project) -> X ()
modifyProject :: (Project -> Project) -> X ()
modifyProject Project -> Project
f = do
  Project
p  <- X Project
currentProject
  ProjectTable
ps <- (ProjectState -> ProjectTable) -> X ProjectTable
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects

  -- If a project is renamed to match another project, the old project
  -- will be removed and replaced with this one.
  let new :: Project
new = Project -> Project
f Project
p
      ps' :: ProjectTable
ps' = ProjectName -> Project -> ProjectTable -> ProjectTable
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Project -> ProjectName
projectName Project
new) Project
new (ProjectTable -> ProjectTable) -> ProjectTable -> ProjectTable
forall a b. (a -> b) -> a -> b
$ ProjectName -> ProjectTable -> ProjectTable
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Project -> ProjectName
projectName Project
p) ProjectTable
ps

  (ProjectState -> ProjectState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify ((ProjectState -> ProjectState) -> X ())
-> (ProjectState -> ProjectState) -> X ()
forall a b. (a -> b) -> a -> b
$ \ProjectState
s -> ProjectState
s {projects :: ProjectTable
projects = ProjectTable
ps'}
  Project -> X ()
activateProject Project
new

--------------------------------------------------------------------------------
-- | Switch to the given project.
switchProject :: Project -> X ()
switchProject :: Project -> X ()
switchProject Project
p = do
  Workspace ProjectName (Layout Window) Window
oldws <- (XState -> Workspace ProjectName (Layout Window) Window)
-> X (Workspace ProjectName (Layout Window) Window)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
-> Workspace ProjectName (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> Workspace ProjectName (Layout Window) Window)
-> (XState
    -> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Workspace ProjectName (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
-> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> (XState
    -> StackSet
         ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     ProjectName (Layout Window) Window ScreenId ScreenDetail
windowset)
  Project
oldp <- X Project
currentProject

  let name :: ProjectName
name = Workspace ProjectName (Layout Window) Window -> ProjectName
forall i l a. Workspace i l a -> i
W.tag Workspace ProjectName (Layout Window) Window
oldws
      ws :: [Window]
ws   = Maybe (Stack Window) -> [Window]
forall a. Maybe (Stack a) -> [a]
W.integrate' (Workspace ProjectName (Layout Window) Window
-> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack Workspace ProjectName (Layout Window) Window
oldws)

  -- If the project we are switching away from has no windows, and
  -- it's a dynamic project, remove it from the configuration.
  Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Window] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Window]
ws Bool -> Bool -> Bool
&& Maybe (X ()) -> Bool
forall a. Maybe a -> Bool
isNothing (Project -> Maybe (X ())
projectStartHook Project
oldp)) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ do
    ProjectName -> X ()
removeWorkspaceByTag ProjectName
name -- also remove the old workspace
    (ProjectState -> ProjectState) -> X ()
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify (\ProjectState
s -> ProjectState
s {projects :: ProjectTable
projects = ProjectName -> ProjectTable -> ProjectTable
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ProjectName
name (ProjectTable -> ProjectTable) -> ProjectTable -> ProjectTable
forall a b. (a -> b) -> a -> b
$ ProjectState -> ProjectTable
projects ProjectState
s})

  ProjectName -> X ()
appendWorkspace (Project -> ProjectName
projectName Project
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 :: XPConfig -> X ()
switchProjectPrompt = [ProjectMode] -> XPConfig -> X ()
projectPrompt [ ProjectMode
SwitchMode
                                    , ProjectMode
ShiftMode
                                    , ProjectMode
RenameMode
                                    , ProjectMode
DirMode
                                    ]

--------------------------------------------------------------------------------
-- | Shift the currently focused window to the given project.
shiftToProject :: Project -> X ()
shiftToProject :: Project -> X ()
shiftToProject Project
p = do
  ProjectName -> X ()
addHiddenWorkspace (Project -> ProjectName
projectName Project
p)
  (StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> StackSet
      ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> X ()
windows (ProjectName
-> StackSet
     ProjectName (Layout Window) Window ScreenId ScreenDetail
-> StackSet
     ProjectName (Layout Window) Window ScreenId ScreenDetail
forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> StackSet i l a s sd -> StackSet i l a s sd
W.shift (ProjectName
 -> StackSet
      ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> StackSet
      ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> ProjectName
-> StackSet
     ProjectName (Layout Window) Window ScreenId ScreenDetail
-> StackSet
     ProjectName (Layout Window) Window ScreenId ScreenDetail
forall a b. (a -> b) -> a -> b
$ Project -> ProjectName
projectName Project
p)

--------------------------------------------------------------------------------
-- | Prompts for a project name and then shifts the currently focused
-- window to that project.
shiftToProjectPrompt :: XPConfig -> X ()
shiftToProjectPrompt :: XPConfig -> X ()
shiftToProjectPrompt = [ProjectMode] -> XPConfig -> X ()
projectPrompt [ ProjectMode
ShiftMode
                                     , ProjectMode
RenameMode
                                     , ProjectMode
SwitchMode
                                     , ProjectMode
DirMode
                                     ]

--------------------------------------------------------------------------------
-- | Rename the current project.
renameProjectPrompt :: XPConfig -> X ()
renameProjectPrompt :: XPConfig -> X ()
renameProjectPrompt = [ProjectMode] -> XPConfig -> X ()
projectPrompt [ ProjectMode
RenameMode
                                    , ProjectMode
DirMode
                                    , ProjectMode
SwitchMode
                                    , ProjectMode
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 :: XPConfig -> X ()
changeProjectDirPrompt = [ProjectMode] -> XPConfig -> X ()
projectPrompt [ ProjectMode
DirMode
                                       , ProjectMode
SwitchMode
                                       , ProjectMode
ShiftMode
                                       , ProjectMode
RenameMode
                                       ]

--------------------------------------------------------------------------------
-- | Prompt for a project name.
projectPrompt :: [ProjectMode] -> XPConfig -> X ()
projectPrompt :: [ProjectMode] -> XPConfig -> X ()
projectPrompt [ProjectMode]
submodes XPConfig
c = do
  [ProjectName]
ws <- (Workspace ProjectName (Layout Window) Window -> ProjectName)
-> [Workspace ProjectName (Layout Window) Window] -> [ProjectName]
forall a b. (a -> b) -> [a] -> [b]
map Workspace ProjectName (Layout Window) Window -> ProjectName
forall i l a. Workspace i l a -> i
W.tag ([Workspace ProjectName (Layout Window) Window] -> [ProjectName])
-> X [Workspace ProjectName (Layout Window) Window]
-> X [ProjectName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XState -> [Workspace ProjectName (Layout Window) Window])
-> X [Workspace ProjectName (Layout Window) Window]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
-> [Workspace ProjectName (Layout Window) Window]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces (StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> [Workspace ProjectName (Layout Window) Window])
-> (XState
    -> StackSet
         ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> [Workspace ProjectName (Layout Window) Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     ProjectName (Layout Window) Window ScreenId ScreenDetail
windowset)
  ProjectTable
ps <- (ProjectState -> ProjectTable) -> X ProjectTable
forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects

  let names :: [ProjectName]
names = [ProjectName] -> [ProjectName]
forall a. Ord a => [a] -> [a]
sort (ProjectTable -> [ProjectName]
forall k a. Map k a -> [k]
Map.keys ProjectTable
ps [ProjectName] -> [ProjectName] -> [ProjectName]
forall a. Eq a => [a] -> [a] -> [a]
`union` [ProjectName]
ws)
      modes :: [XPType]
modes = (ProjectMode -> XPType) -> [ProjectMode] -> [XPType]
forall a b. (a -> b) -> [a] -> [b]
map (\ProjectMode
m -> ProjectPrompt -> XPType
forall p. XPrompt p => p -> XPType
XPT (ProjectPrompt -> XPType) -> ProjectPrompt -> XPType
forall a b. (a -> b) -> a -> b
$ XPConfig -> ProjectMode -> [ProjectName] -> ProjectPrompt
ProjectPrompt XPConfig
c ProjectMode
m [ProjectName]
names) [ProjectMode]
submodes

  [XPType] -> XPConfig -> X ()
mkXPromptWithModes [XPType]
modes XPConfig
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 :: Project -> X ()
activateProject Project
p = do
    [Window]
ws   <- (XState -> [Window]) -> X [Window]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Maybe (Stack Window) -> [Window]
forall a. Maybe (Stack a) -> [a]
W.integrate' (Maybe (Stack Window) -> [Window])
-> (XState -> Maybe (Stack Window)) -> XState -> [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace ProjectName (Layout Window) Window
-> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace ProjectName (Layout Window) Window
 -> Maybe (Stack Window))
-> (XState -> Workspace ProjectName (Layout Window) Window)
-> XState
-> Maybe (Stack Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
-> Workspace ProjectName (Layout Window) Window
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> Workspace ProjectName (Layout Window) Window)
-> (XState
    -> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Workspace ProjectName (Layout Window) Window
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
-> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current (StackSet ProjectName (Layout Window) Window ScreenId ScreenDetail
 -> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> (XState
    -> StackSet
         ProjectName (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> Screen ProjectName (Layout Window) Window ScreenId ScreenDetail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState
-> StackSet
     ProjectName (Layout Window) Window ScreenId ScreenDetail
windowset)
    ProjectName
home <- IO ProjectName -> X ProjectName
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO ProjectName
getHomeDirectory

    -- Change to the project's directory.
    IO () -> X ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
catchIO (ProjectName -> IO ()
setCurrentDirectory (ProjectName -> IO ()) -> ProjectName -> IO ()
forall a b. (a -> b) -> a -> b
$ ProjectName -> ProjectName -> ProjectName
expandHome ProjectName
home (ProjectName -> ProjectName) -> ProjectName -> ProjectName
forall a b. (a -> b) -> a -> b
$ Project -> ProjectName
projectDirectory Project
p)

    -- Possibly run the project's startup hook.
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Window] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Window]
ws) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ X () -> Maybe (X ()) -> X ()
forall a. a -> Maybe a -> a
fromMaybe (() -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Project -> Maybe (X ())
projectStartHook Project
p)

  where

    -- Replace an initial @~@ character with the home directory.
    expandHome :: FilePath -> FilePath -> FilePath
    expandHome :: ProjectName -> ProjectName -> ProjectName
expandHome ProjectName
home ProjectName
dir = case ProjectName -> ProjectName -> Maybe ProjectName
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ProjectName
"~" ProjectName
dir of
      Maybe ProjectName
Nothing -> ProjectName
dir
      Just ProjectName
xs -> ProjectName
home ProjectName -> ProjectName -> ProjectName
forall a. [a] -> [a] -> [a]
++ ProjectName
xs

--------------------------------------------------------------------------------
-- | Default project.
defProject :: ProjectName -> Project
defProject :: ProjectName -> Project
defProject ProjectName
name = ProjectName -> ProjectName -> Maybe (X ()) -> Project
Project ProjectName
name ProjectName
"~/" Maybe (X ())
forall a. Maybe a
Nothing