module XMonad.Actions.DynamicProjects
(
Project (..)
, ProjectName
, dynamicProjects
, switchProjectPrompt
, shiftToProjectPrompt
, renameProjectPrompt
, changeProjectDirPrompt
, 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
type ProjectName = String
type ProjectTable = Map ProjectName Project
data Project = Project
{ Project -> ProjectName
projectName :: !ProjectName
, Project -> ProjectName
projectDirectory :: !FilePath
, Project -> Maybe (X ())
projectStartHook :: !(Maybe (X ()))
}
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 forall k a. Map k a
Map.empty forall a. Maybe a
Nothing
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]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
"" (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ())
in 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
auto then ProjectName
buf else ProjectName
auto
ProjectTable
ps <- forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects
case 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 | forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
name -> 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
auto then ProjectName
buf else ProjectName
auto
ProjectTable
ps <- forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects
Project -> X ()
shiftToProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe (ProjectName -> Project
defProject ProjectName
name) forall a b. (a -> b) -> a -> b
$ 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
_ =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
name) Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace ProjectName
name)) 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null ProjectName
auto then ProjectName
buf else ProjectName
auto
ProjectName
dir <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io 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 })
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 forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *). XConfig l -> X ()
startupHook XConfig a
c
, logHook :: X ()
logHook = X ()
dynamicProjectsLogHook forall a. Semigroup a => a -> a -> a
<> forall (l :: * -> *). XConfig l -> X ()
logHook XConfig a
c
}
dynamicProjectsLogHook :: X ()
dynamicProjectsLogHook :: X ()
dynamicProjectsLogHook = do
ProjectName
name <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a. Workspace i l a -> i
W.tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
ProjectState
xstate <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. a -> Maybe a
Just ProjectName
name forall a. Eq a => a -> a -> Bool
== ProjectState -> Maybe ProjectName
previousProject ProjectState
xstate) forall a b. (a -> b) -> a -> b
$ do
forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put (ProjectState
xstate {previousProject :: Maybe ProjectName
previousProject = forall a. a -> Maybe a
Just ProjectName
name})
Project -> X ()
activateProject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe (ProjectName -> Project
defProject ProjectName
name) forall a b. (a -> b) -> a -> b
$
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectName
name (ProjectState -> ProjectTable
projects ProjectState
xstate)
dynamicProjectsStartupHook :: [Project] -> X ()
dynamicProjectsStartupHook :: [Project] -> X ()
dynamicProjectsStartupHook [Project]
ps = 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 forall a b. (a -> b) -> a -> b
$ ProjectState -> ProjectTable
projects ProjectState
s}
update :: ProjectTable -> ProjectTable
update :: ProjectTable -> ProjectTable
update = forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union (forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall a b. (a -> b) -> a -> b
$ 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)
addDefaultHook :: Project -> Project
addDefaultHook :: Project -> Project
addDefaultHook Project
p = Project
p { projectStartHook :: Maybe (X ())
projectStartHook = Project -> Maybe (X ())
projectStartHook Project
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
forall a. a -> Maybe a
Just (forall (m :: * -> *) a. Monad m => a -> m a
return ())
}
lookupProject :: ProjectName -> X (Maybe Project)
lookupProject :: ProjectName -> X (Maybe Project)
lookupProject ProjectName
name = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ProjectName
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects
currentProject :: X Project
currentProject :: X Project
currentProject = do
ProjectName
name <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a. Workspace i l a -> i
W.tag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
Maybe Project
proj <- ProjectName -> X (Maybe Project)
lookupProject ProjectName
name
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (ProjectName -> Project
defProject ProjectName
name) Maybe Project
proj
modifyProject :: (Project -> Project) -> X ()
modifyProject :: (Project -> Project) -> X ()
modifyProject Project -> Project
f = do
Project
p <- X Project
currentProject
ProjectTable
ps <- forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects
let new :: Project
new = Project -> Project
f Project
p
ps' :: ProjectTable
ps' = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Project -> ProjectName
projectName Project
new) Project
new forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete (Project -> ProjectName
projectName Project
p) ProjectTable
ps
forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify forall a b. (a -> b) -> a -> b
$ \ProjectState
s -> ProjectState
s {projects :: ProjectTable
projects = ProjectTable
ps'}
Project -> X ()
activateProject Project
new
switchProject :: Project -> X ()
switchProject :: Project -> X ()
switchProject Project
p = ProjectName -> X ()
appendWorkspace (Project -> ProjectName
projectName Project
p)
switchProjectPrompt :: XPConfig -> X ()
switchProjectPrompt :: XPConfig -> X ()
switchProjectPrompt = [ProjectMode] -> XPConfig -> X ()
projectPrompt [ ProjectMode
SwitchMode
, ProjectMode
ShiftMode
, ProjectMode
RenameMode
, ProjectMode
DirMode
]
shiftToProject :: Project -> X ()
shiftToProject :: Project -> X ()
shiftToProject Project
p = do
ProjectName -> X ()
addHiddenWorkspace (Project -> ProjectName
projectName Project
p)
(WindowSet -> WindowSet) -> X ()
windows (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 forall a b. (a -> b) -> a -> b
$ Project -> ProjectName
projectName Project
p)
shiftToProjectPrompt :: XPConfig -> X ()
shiftToProjectPrompt :: XPConfig -> X ()
shiftToProjectPrompt = [ProjectMode] -> XPConfig -> X ()
projectPrompt [ ProjectMode
ShiftMode
, ProjectMode
RenameMode
, ProjectMode
SwitchMode
, ProjectMode
DirMode
]
renameProjectPrompt :: XPConfig -> X ()
renameProjectPrompt :: XPConfig -> X ()
renameProjectPrompt = [ProjectMode] -> XPConfig -> X ()
projectPrompt [ ProjectMode
RenameMode
, ProjectMode
DirMode
, ProjectMode
SwitchMode
, ProjectMode
ShiftMode
]
changeProjectDirPrompt :: XPConfig -> X ()
changeProjectDirPrompt :: XPConfig -> X ()
changeProjectDirPrompt = [ProjectMode] -> XPConfig -> X ()
projectPrompt [ ProjectMode
DirMode
, ProjectMode
SwitchMode
, ProjectMode
ShiftMode
, ProjectMode
RenameMode
]
projectPrompt :: [ProjectMode] -> XPConfig -> X ()
projectPrompt :: [ProjectMode] -> XPConfig -> X ()
projectPrompt [ProjectMode]
submodes XPConfig
c = do
[ProjectName]
ws <- forall a b. (a -> b) -> [a] -> [b]
map forall i l a. Workspace i l a -> i
W.tag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
ProjectTable
ps <- forall a (m :: * -> *) b.
(ExtensionClass a, XLike m) =>
(a -> b) -> m b
XS.gets ProjectState -> ProjectTable
projects
let names :: [ProjectName]
names = forall a. Ord a => [a] -> [a]
sort (forall k a. Map k a -> [k]
Map.keys ProjectTable
ps forall a. Eq a => [a] -> [a] -> [a]
`union` [ProjectName]
ws)
modes :: [XPType]
modes = forall a b. (a -> b) -> [a] -> [b]
map (\ProjectMode
m -> forall p. XPrompt p => p -> XPType
XPT 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
activateProject :: Project -> X ()
activateProject :: Project -> X ()
activateProject Project
p = do
[Window]
ws <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall a. Maybe (Stack a) -> [a]
W.integrate' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a sid sd. StackSet i l a sid sd -> Screen i l a sid sd
W.current forall b c a. (b -> c) -> (a -> b) -> a -> c
. XState -> WindowSet
windowset)
ProjectName
home <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO ProjectName
getHomeDirectory
forall (m :: * -> *). MonadIO m => IO () -> m ()
catchIO (ProjectName -> IO ()
setCurrentDirectory forall a b. (a -> b) -> a -> b
$ ProjectName -> ProjectName -> ProjectName
expandHome ProjectName
home forall a b. (a -> b) -> a -> b
$ Project -> ProjectName
projectDirectory Project
p)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Window]
ws) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Project -> Maybe (X ())
projectStartHook Project
p)
where
expandHome :: FilePath -> FilePath -> FilePath
expandHome :: ProjectName -> ProjectName -> ProjectName
expandHome ProjectName
home ProjectName
dir = case forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix ProjectName
"~" ProjectName
dir of
Maybe ProjectName
Nothing -> ProjectName
dir
Just ProjectName
xs -> ProjectName
home forall a. [a] -> [a] -> [a]
++ ProjectName
xs
defProject :: ProjectName -> Project
defProject :: ProjectName -> Project
defProject ProjectName
name = ProjectName -> ProjectName -> Maybe (X ()) -> Project
Project ProjectName
name ProjectName
"~/" forall a. Maybe a
Nothing