-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.NamedScratchpad
-- Description :  Toggle arbitrary windows to and from the current workspace.
-- Copyright   :  (c) Konstantin Sobolev <konstantin.sobolev@gmail.com>
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Konstantin Sobolev <konstantin.sobolev@gmail.com>
-- Stability   :  unstable
-- Portability :  unportable
--
-- Named scratchpads that support several arbitrary applications at the same time.
--
-----------------------------------------------------------------------------

module XMonad.Util.NamedScratchpad (
  -- * Usage
  -- $usage
  NamedScratchpad(..),
  scratchpadWorkspaceTag,
  nonFloating,
  defaultFloating,
  customFloating,
  NamedScratchpads,
  namedScratchpadAction,
  spawnHereNamedScratchpadAction,
  customRunNamedScratchpadAction,
  allNamedScratchpadAction,
  namedScratchpadManageHook,
  namedScratchpadFilterOutWorkspace,
  namedScratchpadFilterOutWorkspacePP,
  nsHideOnFocusLoss,
  ) where

import XMonad
import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace)
import XMonad.Actions.SpawnOn (spawnHere)
import XMonad.Hooks.StatusBar.PP (PP, ppSort)
import XMonad.Hooks.ManageHelpers (doRectFloat)
import XMonad.Hooks.RefocusLast (withRecentsIn)
import XMonad.Prelude (filterM, find, unless, when)

import qualified Data.List.NonEmpty as NE

import qualified XMonad.StackSet as W


-- $usage
-- Allows to have several floating scratchpads running different applications.
-- Bind a key to 'namedScratchpadSpawnAction'.
-- Pressing it will spawn configured application, or bring it to the current
-- workspace if it already exists.
-- Pressing the key with the application on the current workspace will
-- send it to a hidden workspace called @NSP@.
--
-- If you already have a workspace called @NSP@, it will use that.
-- @NSP@ will also appear in xmobar and dzen status bars. You can tweak your
-- @dynamicLog@ settings to filter it out if you like.
--
-- Create named scratchpads configuration in your xmonad.hs like this:
--
-- > import XMonad.StackSet as W
-- > import XMonad.ManageHook
-- > import XMonad.Util.NamedScratchpad
-- >
-- > scratchpads = [
-- > -- run htop in xterm, find it by title, use default floating window placement
-- >     NS "htop" "xterm -e htop" (title =? "htop") defaultFloating ,
-- >
-- > -- run stardict, find it by class name, place it in the floating window
-- > -- 1/6 of screen width from the left, 1/6 of screen height
-- > -- from the top, 2/3 of screen width by 2/3 of screen height
-- >     NS "stardict" "stardict" (className =? "Stardict")
-- >         (customFloating $ W.RationalRect (1/6) (1/6) (2/3) (2/3)) ,
-- >
-- > -- run gvim, find by role, don't float
-- >     NS "notes" "gvim --role notes ~/notes.txt" (role =? "notes") nonFloating
-- > ] where role = stringProperty "WM_WINDOW_ROLE"
--
-- Add keybindings:
--
-- >  , ((modm .|. controlMask .|. shiftMask, xK_t), namedScratchpadAction scratchpads "htop")
-- >  , ((modm .|. controlMask .|. shiftMask, xK_s), namedScratchpadAction scratchpads "stardict")
-- >  , ((modm .|. controlMask .|. shiftMask, xK_n), namedScratchpadAction scratchpads "notes")
--
-- ... and a manage hook:
--
-- >  , manageHook = namedScratchpadManageHook scratchpads
--
-- For detailed instruction on editing the key binding see
-- "XMonad.Doc.Extending#Editing_key_bindings"
--
-- For some applications (like displaying your workspaces in a status bar) it
-- is convenient to filter out the @NSP@ workspace when looking at all
-- workspaces. For this, you can use 'XMonad.Hooks.StatusBar.PP.filterOutWsPP',
-- or 'XMonad.Util.WorkspaceCompare.filterOutWs' together with
-- 'XMonad.Hooks.EwmhDesktops.addEwmhWorkspaceSort' if your status bar gets
-- the list of workspaces from EWMH.  See the documentation of these functions
-- for examples.
--
-- Further, there is also a @logHook@ that you can use to hide
-- scratchpads when they lose focus; this is functionality akin to what
-- some dropdown terminals provide.  See the documentation of
-- 'nsHideOnFocusLoss' for an example how to set this up.
--

-- | Single named scratchpad configuration
data NamedScratchpad = NS { NamedScratchpad -> String
name   :: String      -- ^ Scratchpad name
                          , NamedScratchpad -> String
cmd    :: String      -- ^ Command used to run application
                          , NamedScratchpad -> Query Bool
query  :: Query Bool  -- ^ Query to find already running application
                          , NamedScratchpad -> ManageHook
hook   :: ManageHook  -- ^ Manage hook called for application window, use it to define the placement. See @nonFloating@, @defaultFloating@ and @customFloating@
                          }

-- | Manage hook that makes the window non-floating
nonFloating :: ManageHook
nonFloating :: ManageHook
nonFloating = ManageHook
forall m. Monoid m => m
idHook

-- | Manage hook that makes the window floating with the default placement
defaultFloating :: ManageHook
defaultFloating :: ManageHook
defaultFloating = ManageHook
doFloat

-- | Manage hook that makes the window floating with custom placement
customFloating :: W.RationalRect -> ManageHook
customFloating :: RationalRect -> ManageHook
customFloating = RationalRect -> ManageHook
doRectFloat

-- | Named scratchpads configuration
type NamedScratchpads = [NamedScratchpad]

-- | Finds named scratchpad configuration by name
findByName :: NamedScratchpads -> String -> Maybe NamedScratchpad
findByName :: NamedScratchpads -> String -> Maybe NamedScratchpad
findByName NamedScratchpads
c String
s = (NamedScratchpad -> Bool)
-> NamedScratchpads -> Maybe NamedScratchpad
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool)
-> (NamedScratchpad -> String) -> NamedScratchpad -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedScratchpad -> String
name) NamedScratchpads
c

-- | Runs application which should appear in specified scratchpad
runApplication :: NamedScratchpad -> X ()
runApplication :: NamedScratchpad -> X ()
runApplication = String -> X ()
forall (m :: * -> *). MonadIO m => String -> m ()
spawn (String -> X ())
-> (NamedScratchpad -> String) -> NamedScratchpad -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedScratchpad -> String
cmd

-- | Runs application which should appear in a specified scratchpad on the workspace it was launched on
runApplicationHere :: NamedScratchpad -> X ()
runApplicationHere :: NamedScratchpad -> X ()
runApplicationHere = String -> X ()
spawnHere (String -> X ())
-> (NamedScratchpad -> String) -> NamedScratchpad -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedScratchpad -> String
cmd

-- | Action to pop up specified named scratchpad
namedScratchpadAction :: NamedScratchpads -- ^ Named scratchpads configuration
                      -> String           -- ^ Scratchpad name
                      -> X ()
namedScratchpadAction :: NamedScratchpads -> String -> X ()
namedScratchpadAction = (NamedScratchpad -> X ()) -> NamedScratchpads -> String -> X ()
customRunNamedScratchpadAction NamedScratchpad -> X ()
runApplication

-- | Action to pop up specified named scratchpad, initially starting it on the current workspace.
spawnHereNamedScratchpadAction :: NamedScratchpads           -- ^ Named scratchpads configuration
                               -> String                     -- ^ Scratchpad name
                               -> X ()
spawnHereNamedScratchpadAction :: NamedScratchpads -> String -> X ()
spawnHereNamedScratchpadAction = (NamedScratchpad -> X ()) -> NamedScratchpads -> String -> X ()
customRunNamedScratchpadAction NamedScratchpad -> X ()
runApplicationHere

-- | Action to pop up specified named scratchpad, given a custom way to initially start the application.
customRunNamedScratchpadAction :: (NamedScratchpad -> X ())  -- ^ Function initially running the application, given the configured @scratchpad@ cmd
                               -> NamedScratchpads           -- ^ Named scratchpads configuration
                               -> String                     -- ^ Scratchpad name
                               -> X ()
customRunNamedScratchpadAction :: (NamedScratchpad -> X ()) -> NamedScratchpads -> String -> X ()
customRunNamedScratchpadAction = ((Window -> X ()) -> NonEmpty Window -> X ())
-> (NamedScratchpad -> X ()) -> NamedScratchpads -> String -> X ()
someNamedScratchpadAction (\Window -> X ()
f NonEmpty Window
ws -> Window -> X ()
f (Window -> X ()) -> Window -> X ()
forall a b. (a -> b) -> a -> b
$ NonEmpty Window -> Window
forall a. NonEmpty a -> a
NE.head NonEmpty Window
ws)

allNamedScratchpadAction :: NamedScratchpads
                         -> String
                         -> X ()
allNamedScratchpadAction :: NamedScratchpads -> String -> X ()
allNamedScratchpadAction = ((Window -> X ()) -> NonEmpty Window -> X ())
-> (NamedScratchpad -> X ()) -> NamedScratchpads -> String -> X ()
someNamedScratchpadAction (Window -> X ()) -> NonEmpty Window -> X ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NamedScratchpad -> X ()
runApplication

-- | A @logHook@ to hide scratchpads when they lose focus.  This can be
-- useful for e.g. dropdown terminals.  Note that this also requires you
-- to use the 'XMonad.Hooks.RefocusLast.refocusLastLogHook'.
--
-- ==== __Example__
--
-- > import XMonad.Hooks.RefocusLast (refocusLastLogHook)
-- > import XMonad.Util.NamedScratchpad
-- >
-- > main = xmonad $ def
-- >   { logHook = refocusLastLogHook
-- >            >> nsHideOnFocusLoss myScratchpads
-- >               -- enable hiding for all of @myScratchpads@
-- >   }
nsHideOnFocusLoss :: NamedScratchpads -> X ()
nsHideOnFocusLoss :: NamedScratchpads -> X ()
nsHideOnFocusLoss NamedScratchpads
scratches = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
winSet -> do
    let cur :: String
cur = WindowSet -> String
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
winSet
    String -> () -> (Window -> Window -> X ()) -> X ()
forall a. String -> a -> (Window -> Window -> X a) -> X a
withRecentsIn String
cur () ((Window -> Window -> X ()) -> X ())
-> (Window -> Window -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \Window
lastFocus Window
_ ->
        Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
lastFocus Window -> [Window] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` WindowSet -> [Window]
forall i l a s sd. StackSet i l a s sd -> [a]
W.index WindowSet
winSet Bool -> Bool -> Bool
&& String
cur String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
scratchpadWorkspaceTag) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
            X Bool -> X () -> X ()
whenX (Window -> X Bool
isNS Window
lastFocus) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
                [WindowSpace] -> ((Window -> X ()) -> X ()) -> X ()
shiftToNSP (WindowSet -> [WindowSpace]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces WindowSet
winSet) ((Window -> X ()) -> Window -> X ()
forall a b. (a -> b) -> a -> b
$ Window
lastFocus)
  where
    isNS :: Window -> X Bool
    isNS :: Window -> X Bool
isNS Window
w = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> X [Bool] -> X Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamedScratchpad -> X Bool) -> NamedScratchpads -> X [Bool]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Query Bool -> Window -> X Bool
forall a. Query a -> Window -> X a
`runQuery` Window
w) (Query Bool -> X Bool)
-> (NamedScratchpad -> Query Bool) -> NamedScratchpad -> X Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedScratchpad -> Query Bool
query) NamedScratchpads
scratches

-- | execute some action on a named scratchpad
someNamedScratchpadAction :: ((Window -> X ()) -> NE.NonEmpty Window -> X ())
                          -> (NamedScratchpad -> X ())
                          -> NamedScratchpads
                          -> String
                          -> X ()
someNamedScratchpadAction :: ((Window -> X ()) -> NonEmpty Window -> X ())
-> (NamedScratchpad -> X ()) -> NamedScratchpads -> String -> X ()
someNamedScratchpadAction (Window -> X ()) -> NonEmpty Window -> X ()
f NamedScratchpad -> X ()
runApp NamedScratchpads
scratchpadConfig String
scratchpadName =
    case NamedScratchpads -> String -> Maybe NamedScratchpad
findByName NamedScratchpads
scratchpadConfig String
scratchpadName of
        Just NamedScratchpad
conf -> (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \WindowSet
winSet -> do
            let focusedWspWindows :: [Window]
focusedWspWindows = [Window]
-> (Stack Window -> [Window]) -> Maybe (Stack Window) -> [Window]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Stack Window -> [Window]
forall a. Stack a -> [a]
W.integrate (WindowSpace -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (WindowSpace -> Maybe (Stack Window))
-> (WindowSet -> WindowSpace) -> WindowSet -> Maybe (Stack Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> WindowSpace
forall i l a sid sd. Screen i l a sid sd -> Workspace i l a
W.workspace (Screen String (Layout Window) Window ScreenId ScreenDetail
 -> WindowSpace)
-> (WindowSet
    -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> WindowSet
-> WindowSpace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSet
-> Screen String (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 (WindowSet -> Maybe (Stack Window))
-> WindowSet -> Maybe (Stack Window)
forall a b. (a -> b) -> a -> b
$ WindowSet
winSet)
                allWindows :: [Window]
allWindows        = WindowSet -> [Window]
forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
winSet
            [Window]
matchingOnCurrent <- (Window -> X Bool) -> [Window] -> X [Window]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Query Bool -> Window -> X Bool
forall a. Query a -> Window -> X a
runQuery (NamedScratchpad -> Query Bool
query NamedScratchpad
conf)) [Window]
focusedWspWindows
            [Window]
matchingOnAll     <- (Window -> X Bool) -> [Window] -> X [Window]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Query Bool -> Window -> X Bool
forall a. Query a -> Window -> X a
runQuery (NamedScratchpad -> Query Bool
query NamedScratchpad
conf)) [Window]
allWindows

            case [Window] -> Maybe (NonEmpty Window)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Window]
matchingOnCurrent of
                -- no matching window on the current workspace -> scratchpad not running or in background
                Maybe (NonEmpty Window)
Nothing -> case [Window] -> Maybe (NonEmpty Window)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Window]
matchingOnAll of
                    Maybe (NonEmpty Window)
Nothing   -> NamedScratchpad -> X ()
runApp NamedScratchpad
conf
                    Just NonEmpty Window
wins -> (Window -> X ()) -> NonEmpty Window -> X ()
f ((WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (Window -> WindowSet -> WindowSet) -> Window -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Window -> WindowSet -> WindowSet
forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> a -> StackSet i l a s sd -> StackSet i l a s sd
W.shiftWin (WindowSet -> String
forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
winSet)) NonEmpty Window
wins

                -- matching window running on current workspace -> window should be shifted to scratchpad workspace
                Just NonEmpty Window
wins -> [WindowSpace] -> ((Window -> X ()) -> X ()) -> X ()
shiftToNSP (WindowSet -> [WindowSpace]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces WindowSet
winSet) ((Window -> X ()) -> NonEmpty Window -> X ()
`f` NonEmpty Window
wins)
        Maybe NamedScratchpad
Nothing -> () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Tag of the scratchpad workspace
scratchpadWorkspaceTag :: String
scratchpadWorkspaceTag :: String
scratchpadWorkspaceTag = String
"NSP"

-- | Manage hook to use with named scratchpads
namedScratchpadManageHook :: NamedScratchpads -- ^ Named scratchpads configuration
                          -> ManageHook
namedScratchpadManageHook :: NamedScratchpads -> ManageHook
namedScratchpadManageHook = [ManageHook] -> ManageHook
forall m. Monoid m => [m] -> m
composeAll ([ManageHook] -> ManageHook)
-> (NamedScratchpads -> [ManageHook])
-> NamedScratchpads
-> ManageHook
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedScratchpad -> ManageHook) -> NamedScratchpads -> [ManageHook]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NamedScratchpad
c -> NamedScratchpad -> Query Bool
query NamedScratchpad
c Query Bool -> ManageHook -> ManageHook
forall (m :: * -> *) a. (Monad m, Monoid a) => m Bool -> m a -> m a
--> NamedScratchpad -> ManageHook
hook NamedScratchpad
c)

-- | Shift some windows to the scratchpad workspace according to the
-- given function.  The workspace is created if necessary.
shiftToNSP :: [WindowSpace] -> ((Window -> X ()) -> X ()) -> X ()
shiftToNSP :: [WindowSpace] -> ((Window -> X ()) -> X ()) -> X ()
shiftToNSP [WindowSpace]
ws (Window -> X ()) -> X ()
f = do
    Bool -> X () -> X ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((WindowSpace -> Bool) -> [WindowSpace] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String
scratchpadWorkspaceTag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool) -> (WindowSpace -> String) -> WindowSpace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WindowSpace -> String
forall i l a. Workspace i l a -> i
W.tag) [WindowSpace]
ws) (X () -> X ()) -> X () -> X ()
forall a b. (a -> b) -> a -> b
$
        String -> X ()
addHiddenWorkspace String
scratchpadWorkspaceTag
    (Window -> X ()) -> X ()
f ((WindowSet -> WindowSet) -> X ()
windows ((WindowSet -> WindowSet) -> X ())
-> (Window -> WindowSet -> WindowSet) -> Window -> X ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Window -> WindowSet -> WindowSet
forall a s i l sd.
(Ord a, Eq s, Eq i) =>
i -> a -> StackSet i l a s sd -> StackSet i l a s sd
W.shiftWin String
scratchpadWorkspaceTag)

-- | Transforms a workspace list containing the NSP workspace into one that
-- doesn't contain it. Intended for use with logHooks.
namedScratchpadFilterOutWorkspace :: [WindowSpace] -> [WindowSpace]
namedScratchpadFilterOutWorkspace :: [WindowSpace] -> [WindowSpace]
namedScratchpadFilterOutWorkspace = (WindowSpace -> Bool) -> [WindowSpace] -> [WindowSpace]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(W.Workspace String
tag Layout Window
_ Maybe (Stack Window)
_) -> String
tag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
scratchpadWorkspaceTag)
{-# DEPRECATED namedScratchpadFilterOutWorkspace "Use XMonad.Util.WorkspaceCompare.filterOutWs [scratchpadWorkspaceTag] instead" #-}

-- | Transforms a pretty-printer into one not displaying the NSP workspace.
--
-- A simple use could be:
--
-- > logHook = dynamicLogWithPP . namedScratchpadFilterOutWorkspace $ def
--
-- Here is another example, when using "XMonad.Layout.IndependentScreens".
-- If you have handles @hLeft@ and @hRight@ for bars on the left and right screens, respectively, and @pp@ is a pretty-printer function that takes a handle, you could write
--
-- > logHook = let log screen handle = dynamicLogWithPP . namedScratchpadFilterOutWorkspacePP . marshallPP screen . pp $ handle
-- >           in log 0 hLeft >> log 1 hRight
namedScratchpadFilterOutWorkspacePP :: PP -> PP
namedScratchpadFilterOutWorkspacePP :: PP -> PP
namedScratchpadFilterOutWorkspacePP PP
pp = PP
pp {
  ppSort :: X ([WindowSpace] -> [WindowSpace])
ppSort = (([WindowSpace] -> [WindowSpace])
 -> [WindowSpace] -> [WindowSpace])
-> X ([WindowSpace] -> [WindowSpace])
-> X ([WindowSpace] -> [WindowSpace])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([WindowSpace] -> [WindowSpace])
-> ([WindowSpace] -> [WindowSpace])
-> [WindowSpace]
-> [WindowSpace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [WindowSpace] -> [WindowSpace]
namedScratchpadFilterOutWorkspace) (PP -> X ([WindowSpace] -> [WindowSpace])
ppSort PP
pp)
  }
{-# DEPRECATED namedScratchpadFilterOutWorkspacePP "Use XMonad.Hooks.StatusBar.PP.filterOutWsPP [scratchpadWorkspaceTag] instead" #-}

-- vim:ts=4:shiftwidth=4:softtabstop=4:expandtab:foldlevel=20: