{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, PatternGuards #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Layout.WorkspaceDir
-- Description :  A layout modifier to set the current directory in a workspace.
-- Copyright   :  (c) 2007  David Roundy <droundy@darcs.net>
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  none
-- Stability   :  unstable
-- Portability :  unportable
--
-- WorkspaceDir is an extension to set the current directory in a workspace.
--
-- Actually, it sets the current directory in a layout, since there's no way I
-- know of to attach a behavior to a workspace.  This means that any terminals
-- (or other programs) pulled up in that workspace (with that layout) will
-- execute in that working directory.  Sort of handy, I think.
--
-- Note this extension requires the 'directory' package to be installed.
--
-----------------------------------------------------------------------------

module XMonad.Layout.WorkspaceDir (
                                   -- * Usage
                                   -- $usage
                                   workspaceDir,
                                   changeDir,
                                   WorkspaceDir,
                                   Chdir(Chdir),
                                  ) where

import System.Directory ( setCurrentDirectory, getCurrentDirectory )
import XMonad.Prelude ( when )

import XMonad hiding ( focus )
import XMonad.Prompt ( XPConfig )
import XMonad.Prompt.Directory ( directoryPrompt )
import XMonad.Layout.LayoutModifier
import XMonad.StackSet ( tag, currentTag )

-- $usage
-- You can use this module with the following in your @~\/.xmonad\/xmonad.hs@:
--
-- > import XMonad.Layout.WorkspaceDir
--
-- Then edit your @layoutHook@ by adding the Workspace layout modifier
-- to some layout:
--
-- > myLayout = workspaceDir "~" (Tall 1 (3/100) (1/2))  ||| Full ||| etc..
-- > main = xmonad def { layoutHook = myLayout }
--
-- For more detailed instructions on editing the layoutHook see:
--
-- "XMonad.Doc.Extending#Editing_the_layout_hook"
--
-- WorkspaceDir provides also a prompt. To use it you need to import
-- "XMonad.Prompt" and add something like this to your key bindings:
--
-- >  , ((modm .|. shiftMask, xK_x     ), changeDir def)
--
-- If you prefer a prompt with case-insensitive completion:
--
-- >  , ((modm .|. shiftMask, xK_x     ),
--       changeDir def {complCaseSensitivity = CaseInSensitive})
--
-- For detailed instruction on editing the key binding see:
--
-- "XMonad.Doc.Extending#Editing_key_bindings".

newtype Chdir = Chdir String
instance Message Chdir

newtype WorkspaceDir a = WorkspaceDir String deriving ( ReadPrec [WorkspaceDir a]
ReadPrec (WorkspaceDir a)
Int -> ReadS (WorkspaceDir a)
ReadS [WorkspaceDir a]
(Int -> ReadS (WorkspaceDir a))
-> ReadS [WorkspaceDir a]
-> ReadPrec (WorkspaceDir a)
-> ReadPrec [WorkspaceDir a]
-> Read (WorkspaceDir a)
forall a. ReadPrec [WorkspaceDir a]
forall a. ReadPrec (WorkspaceDir a)
forall a. Int -> ReadS (WorkspaceDir a)
forall a. ReadS [WorkspaceDir a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [WorkspaceDir a]
$creadListPrec :: forall a. ReadPrec [WorkspaceDir a]
readPrec :: ReadPrec (WorkspaceDir a)
$creadPrec :: forall a. ReadPrec (WorkspaceDir a)
readList :: ReadS [WorkspaceDir a]
$creadList :: forall a. ReadS [WorkspaceDir a]
readsPrec :: Int -> ReadS (WorkspaceDir a)
$creadsPrec :: forall a. Int -> ReadS (WorkspaceDir a)
Read, Int -> WorkspaceDir a -> ShowS
[WorkspaceDir a] -> ShowS
WorkspaceDir a -> String
(Int -> WorkspaceDir a -> ShowS)
-> (WorkspaceDir a -> String)
-> ([WorkspaceDir a] -> ShowS)
-> Show (WorkspaceDir a)
forall a. Int -> WorkspaceDir a -> ShowS
forall a. [WorkspaceDir a] -> ShowS
forall a. WorkspaceDir a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WorkspaceDir a] -> ShowS
$cshowList :: forall a. [WorkspaceDir a] -> ShowS
show :: WorkspaceDir a -> String
$cshow :: forall a. WorkspaceDir a -> String
showsPrec :: Int -> WorkspaceDir a -> ShowS
$cshowsPrec :: forall a. Int -> WorkspaceDir a -> ShowS
Show )

instance LayoutModifier WorkspaceDir Window where
    modifyLayout :: forall (l :: * -> *).
LayoutClass l Window =>
WorkspaceDir Window
-> Workspace String (l Window) Window
-> Rectangle
-> X ([(Window, Rectangle)], Maybe (l Window))
modifyLayout (WorkspaceDir String
d) Workspace String (l Window) Window
w Rectangle
r = do String
tc <- (XState -> String) -> X String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (StackSet String (Layout Window) Window ScreenId ScreenDetail
-> String
forall i l a s sd. StackSet i l a s sd -> i
currentTag(StackSet String (Layout Window) Window ScreenId ScreenDetail
 -> String)
-> (XState
    -> StackSet String (Layout Window) Window ScreenId ScreenDetail)
-> XState
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.XState
-> StackSet String (Layout Window) Window ScreenId ScreenDetail
windowset)
                                           Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
tc String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Workspace String (l Window) Window -> String
forall i l a. Workspace i l a -> i
tag Workspace String (l Window) Window
w) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$ String -> X ()
scd String
d
                                           Workspace String (l Window) Window
-> Rectangle -> X ([(Window, Rectangle)], Maybe (l Window))
forall (layout :: * -> *) a.
LayoutClass layout a =>
Workspace String (layout a) a
-> Rectangle -> X ([(a, Rectangle)], Maybe (layout a))
runLayout Workspace String (l Window) Window
w Rectangle
r
    handleMess :: WorkspaceDir Window
-> SomeMessage -> X (Maybe (WorkspaceDir Window))
handleMess (WorkspaceDir String
_) SomeMessage
m
        | Just (Chdir String
wd) <- SomeMessage -> Maybe Chdir
forall m. Message m => SomeMessage -> Maybe m
fromMessage SomeMessage
m = do String
wd' <- String -> X String
cleanDir String
wd
                                                Maybe (WorkspaceDir Window) -> X (Maybe (WorkspaceDir Window))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (WorkspaceDir Window) -> X (Maybe (WorkspaceDir Window)))
-> Maybe (WorkspaceDir Window) -> X (Maybe (WorkspaceDir Window))
forall a b. (a -> b) -> a -> b
$ WorkspaceDir Window -> Maybe (WorkspaceDir Window)
forall a. a -> Maybe a
Just (WorkspaceDir Window -> Maybe (WorkspaceDir Window))
-> WorkspaceDir Window -> Maybe (WorkspaceDir Window)
forall a b. (a -> b) -> a -> b
$ String -> WorkspaceDir Window
forall a. String -> WorkspaceDir a
WorkspaceDir String
wd'
        | Bool
otherwise = Maybe (WorkspaceDir Window) -> X (Maybe (WorkspaceDir Window))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (WorkspaceDir Window)
forall a. Maybe a
Nothing

workspaceDir :: LayoutClass l a => String -> l a
             -> ModifiedLayout WorkspaceDir l a
workspaceDir :: forall (l :: * -> *) a.
LayoutClass l a =>
String -> l a -> ModifiedLayout WorkspaceDir l a
workspaceDir String
s = WorkspaceDir a -> l a -> ModifiedLayout WorkspaceDir l a
forall (m :: * -> *) (l :: * -> *) a.
m a -> l a -> ModifiedLayout m l a
ModifiedLayout (String -> WorkspaceDir a
forall a. String -> WorkspaceDir a
WorkspaceDir String
s)

cleanDir :: String -> X String
cleanDir :: String -> X String
cleanDir String
x = String -> X ()
scd String
x X () -> X String -> X String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO String -> X String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO String
getCurrentDirectory

scd :: String -> X ()
scd :: String -> X ()
scd String
x = IO () -> X ()
forall (m :: * -> *). MonadIO m => IO () -> m ()
catchIO (IO () -> X ()) -> IO () -> X ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
x

changeDir :: XPConfig -> X ()
changeDir :: XPConfig -> X ()
changeDir XPConfig
c = XPConfig -> String -> (String -> X ()) -> X ()
directoryPrompt XPConfig
c String
"Set working directory: " (Chdir -> X ()
forall a. Message a => a -> X ()
sendMessage (Chdir -> X ()) -> (String -> Chdir) -> String -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Chdir
Chdir)