{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.NamedScratchpad
-- 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(..),
  nonFloating,
  defaultFloating,
  customFloating,
  NamedScratchpads,
  namedScratchpadAction,
  allNamedScratchpadAction,
  namedScratchpadManageHook,
  namedScratchpadFilterOutWorkspace,
  namedScratchpadFilterOutWorkspacePP
  ) where

import XMonad
import XMonad.Hooks.ManageHelpers (doRectFloat)
import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace)
import XMonad.Hooks.DynamicLog (PP, ppSort)

import Control.Monad (filterM)
import Data.Maybe (listToMaybe)

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"
--

-- | 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 c :: NamedScratchpads
c s :: String
s = NamedScratchpads -> Maybe NamedScratchpad
forall a. [a] -> Maybe a
listToMaybe (NamedScratchpads -> Maybe NamedScratchpad)
-> NamedScratchpads -> Maybe NamedScratchpad
forall a b. (a -> b) -> a -> b
$ (NamedScratchpad -> Bool) -> NamedScratchpads -> NamedScratchpads
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
sString -> 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

-- | Action to pop up specified named scratchpad
namedScratchpadAction :: NamedScratchpads -- ^ Named scratchpads configuration
                      -> String           -- ^ Scratchpad name
                      -> X ()
namedScratchpadAction :: NamedScratchpads -> String -> X ()
namedScratchpadAction = ((Window -> X ()) -> [Window] -> X ())
-> NamedScratchpads -> String -> X ()
someNamedScratchpadAction (\f :: Window -> X ()
f ws :: [Window]
ws -> Window -> X ()
f (Window -> X ()) -> Window -> X ()
forall a b. (a -> b) -> a -> b
$ [Window] -> Window
forall a. [a] -> a
head [Window]
ws)

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

someNamedScratchpadAction :: ((Window -> X ()) -> [Window] -> X ())
                          -> NamedScratchpads
                          -> String
                          -> X ()
someNamedScratchpadAction :: ((Window -> X ()) -> [Window] -> X ())
-> NamedScratchpads -> String -> X ()
someNamedScratchpadAction f :: (Window -> X ()) -> [Window] -> X ()
f confs :: NamedScratchpads
confs n :: String
n
    | Just conf :: NamedScratchpad
conf <- NamedScratchpads -> String -> Maybe NamedScratchpad
findByName NamedScratchpads
confs String
n = (WindowSet -> X ()) -> X ()
forall a. (WindowSet -> X a) -> X a
withWindowSet ((WindowSet -> X ()) -> X ()) -> (WindowSet -> X ()) -> X ()
forall a b. (a -> b) -> a -> b
$ \s :: WindowSet
s -> do
                     [Window]
filterCurrent <- (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]
-> (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 (Maybe (Stack Window) -> [Window])
-> (WindowSet -> Maybe (Stack Window)) -> WindowSet -> [Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace String (Layout Window) Window -> Maybe (Stack Window)
forall i l a. Workspace i l a -> Maybe (Stack a)
W.stack (Workspace String (Layout Window) Window -> Maybe (Stack Window))
-> (WindowSet -> Workspace String (Layout Window) Window)
-> WindowSet
-> Maybe (Stack Window)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Screen String (Layout Window) Window ScreenId ScreenDetail
-> Workspace String (Layout Window) Window
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
 -> Workspace String (Layout Window) Window)
-> (WindowSet
    -> Screen String (Layout Window) Window ScreenId ScreenDetail)
-> WindowSet
-> Workspace String (Layout Window) Window
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
s)
                     [Window]
filterAll <- (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)) (WindowSet -> [Window]
forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
s)
                     case [Window]
filterCurrent of
                       [] -> do
                         case [Window]
filterAll of
                           [] -> NamedScratchpad -> X ()
runApplication NamedScratchpad
conf
                           _  -> (Window -> X ()) -> [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
s)) [Window]
filterAll
                       _ -> do
                         if [Workspace String (Layout Window) Window] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ((Workspace String (Layout Window) Window -> Bool)
-> [Workspace String (Layout Window) Window]
-> [Workspace String (Layout Window) Window]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
scratchpadWorkspaceTag) (String -> Bool)
-> (Workspace String (Layout Window) Window -> String)
-> Workspace String (Layout Window) Window
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Workspace String (Layout Window) Window -> String
forall i l a. Workspace i l a -> i
W.tag) (WindowSet -> [Workspace String (Layout Window) Window]
forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces WindowSet
s))
                             then String -> X ()
addHiddenWorkspace String
scratchpadWorkspaceTag
                             else () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                         (Window -> X ()) -> [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 String
scratchpadWorkspaceTag) [Window]
filterAll
    | Bool
otherwise = () -> X ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- tag of the scratchpad workspace
scratchpadWorkspaceTag :: String
scratchpadWorkspaceTag :: String
scratchpadWorkspaceTag = "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 (\c :: 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)

-- | Transforms a workspace list containing the NSP workspace into one that
-- doesn't contain it. Intended for use with logHooks.
namedScratchpadFilterOutWorkspace :: [WindowSpace] -> [WindowSpace]
namedScratchpadFilterOutWorkspace :: [Workspace String (Layout Window) Window]
-> [Workspace String (Layout Window) Window]
namedScratchpadFilterOutWorkspace = (Workspace String (Layout Window) Window -> Bool)
-> [Workspace String (Layout Window) Window]
-> [Workspace String (Layout Window) Window]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(W.Workspace tag :: String
tag _ _) -> String
tag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
scratchpadWorkspaceTag)

-- | 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
pp {
  ppSort :: X ([Workspace String (Layout Window) Window]
   -> [Workspace String (Layout Window) Window])
ppSort = (([Workspace String (Layout Window) Window]
  -> [Workspace String (Layout Window) Window])
 -> [Workspace String (Layout Window) Window]
 -> [Workspace String (Layout Window) Window])
-> X ([Workspace String (Layout Window) Window]
      -> [Workspace String (Layout Window) Window])
-> X ([Workspace String (Layout Window) Window]
      -> [Workspace String (Layout Window) Window])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Workspace String (Layout Window) Window]
 -> [Workspace String (Layout Window) Window])
-> ([Workspace String (Layout Window) Window]
    -> [Workspace String (Layout Window) Window])
-> [Workspace String (Layout Window) Window]
-> [Workspace String (Layout Window) Window]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Workspace String (Layout Window) Window]
-> [Workspace String (Layout Window) Window]
namedScratchpadFilterOutWorkspace) (PP
-> X ([Workspace String (Layout Window) Window]
      -> [Workspace String (Layout Window) Window])
ppSort PP
pp)
  }

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