{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeApplications #-}
module XMonad.Util.NamedScratchpad (
NamedScratchpad(..),
scratchpadWorkspaceTag,
nonFloating,
defaultFloating,
customFloating,
NamedScratchpads,
namedScratchpadAction,
spawnHereNamedScratchpadAction,
customRunNamedScratchpadAction,
allNamedScratchpadAction,
namedScratchpadManageHook,
nsHideOnFocusLoss,
dynamicNSPAction,
toggleDynamicNSP,
namedScratchpadFilterOutWorkspace,
namedScratchpadFilterOutWorkspacePP,
) where
import Data.Coerce (coerce)
import Data.Map.Strict (Map, (!?))
import XMonad
import XMonad.Actions.DynamicWorkspaces (addHiddenWorkspace)
import XMonad.Actions.SpawnOn (spawnHere)
import XMonad.Hooks.ManageHelpers (doRectFloat)
import XMonad.Hooks.RefocusLast (withRecentsIn)
import XMonad.Hooks.StatusBar.PP (PP, ppSort)
import XMonad.Prelude (filterM, unless, when)
import qualified Data.Map.Strict as Map
import qualified Data.List.NonEmpty as NE
import qualified XMonad.StackSet as W
import qualified XMonad.Util.ExtensibleState as XS
data NamedScratchpad = NS { NamedScratchpad -> String
name :: String
, NamedScratchpad -> String
cmd :: String
, NamedScratchpad -> Query Bool
query :: Query Bool
, NamedScratchpad -> ManageHook
hook :: ManageHook
}
newtype NSPState = NSPState (Map String NamedScratchpad)
instance ExtensionClass NSPState where
initialValue :: NSPState
initialValue :: NSPState
initialValue = Map String NamedScratchpad -> NSPState
NSPState forall a. Monoid a => a
mempty
fillNSPState :: NamedScratchpads -> X NSPState
fillNSPState :: NamedScratchpads -> X NSPState
fillNSPState NamedScratchpads
nsps = do
nsp :: NSPState
nsp@(NSPState Map String NamedScratchpad
xs) <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
let nspState :: NSPState
nspState = Map String NamedScratchpad -> NSPState
NSPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)]
zip (forall a b. (a -> b) -> [a] -> [b]
map NamedScratchpad -> String
name NamedScratchpads
nsps) NamedScratchpads
nsps
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map String NamedScratchpad
xs
then NSPState
nspState forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall a (m :: * -> *). (ExtensionClass a, XLike m) => a -> m ()
XS.put NSPState
nspState
else forall (f :: * -> *) a. Applicative f => a -> f a
pure NSPState
nsp
nonFloating :: ManageHook
nonFloating :: ManageHook
nonFloating = forall a. Monoid a => a
idHook
defaultFloating :: ManageHook
defaultFloating :: ManageHook
defaultFloating = ManageHook
doFloat
customFloating :: W.RationalRect -> ManageHook
customFloating :: RationalRect -> ManageHook
customFloating = RationalRect -> ManageHook
doRectFloat
type NamedScratchpads = [NamedScratchpad]
runApplication :: NamedScratchpad -> X ()
runApplication :: NamedScratchpad -> X ()
runApplication = forall (m :: * -> *). MonadIO m => String -> m ()
spawn forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedScratchpad -> String
cmd
runApplicationHere :: NamedScratchpad -> X ()
runApplicationHere :: NamedScratchpad -> X ()
runApplicationHere = String -> X ()
spawnHere forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedScratchpad -> String
cmd
namedScratchpadAction :: NamedScratchpads
-> String
-> X ()
namedScratchpadAction :: NamedScratchpads -> String -> X ()
namedScratchpadAction = (NamedScratchpad -> X ()) -> NamedScratchpads -> String -> X ()
customRunNamedScratchpadAction NamedScratchpad -> X ()
runApplication
spawnHereNamedScratchpadAction :: NamedScratchpads
-> String
-> X ()
spawnHereNamedScratchpadAction :: NamedScratchpads -> String -> X ()
spawnHereNamedScratchpadAction = (NamedScratchpad -> X ()) -> NamedScratchpads -> String -> X ()
customRunNamedScratchpadAction NamedScratchpad -> X ()
runApplicationHere
customRunNamedScratchpadAction :: (NamedScratchpad -> X ())
-> NamedScratchpads
-> String
-> 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 forall a b. (a -> b) -> a -> b
$ 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 forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ NamedScratchpad -> X ()
runApplication
nsHideOnFocusLoss :: NamedScratchpads -> X ()
nsHideOnFocusLoss :: NamedScratchpads -> X ()
nsHideOnFocusLoss NamedScratchpads
scratches = forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$ \WindowSet
winSet -> do
let cur :: String
cur = forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
winSet
forall a. String -> a -> (Window -> Window -> X a) -> X a
withRecentsIn String
cur () forall a b. (a -> b) -> a -> b
$ \Window
lastFocus Window
_ ->
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Window
lastFocus forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall i l a s sd. StackSet i l a s sd -> [a]
W.index WindowSet
winSet Bool -> Bool -> Bool
&& String
cur forall a. Eq a => a -> a -> Bool
/= String
scratchpadWorkspaceTag) forall a b. (a -> b) -> a -> b
$
X Bool -> X () -> X ()
whenX (Window -> X Bool
isNS Window
lastFocus) forall a b. (a -> b) -> a -> b
$
[WindowSpace] -> ((Window -> X ()) -> X ()) -> X ()
shiftToNSP (forall i l a s sd. StackSet i l a s sd -> [Workspace i l a]
W.workspaces WindowSet
winSet) (forall a b. (a -> b) -> a -> b
$ Window
lastFocus)
where
isNS :: Window -> X Bool
isNS :: Window -> X Bool
isNS Window
w = forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((forall a. Query a -> Window -> X a
`runQuery` Window
w) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedScratchpad -> Query Bool
query) NamedScratchpads
scratches
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
_ns String
scratchpadName = do
NSPState Map String NamedScratchpad
scratchpadConfig <- NamedScratchpads -> X NSPState
fillNSPState NamedScratchpads
_ns
case Map String NamedScratchpad
scratchpadConfig forall k a. Ord k => Map k a -> k -> Maybe a
!? String
scratchpadName of
Just NamedScratchpad
conf -> forall a. (WindowSet -> X a) -> X a
withWindowSet forall a b. (a -> b) -> a -> b
$ \WindowSet
winSet -> do
let focusedWspWindows :: [Window]
focusedWspWindows = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. Stack a -> [a]
W.integrate (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 a b. (a -> b) -> a -> b
$ WindowSet
winSet)
allWindows :: [Window]
allWindows = forall a i l s sd. Eq a => StackSet i l a s sd -> [a]
W.allWindows WindowSet
winSet
[Window]
matchingOnCurrent <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall a. Query a -> Window -> X a
runQuery (NamedScratchpad -> Query Bool
query NamedScratchpad
conf)) [Window]
focusedWspWindows
[Window]
matchingOnAll <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (forall a. Query a -> Window -> X a
runQuery (NamedScratchpad -> Query Bool
query NamedScratchpad
conf)) [Window]
allWindows
case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Window]
matchingOnCurrent of
Maybe (NonEmpty Window)
Nothing -> case 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall i l a s sd. StackSet i l a s sd -> i
W.currentTag WindowSet
winSet)) NonEmpty Window
wins
Just NonEmpty Window
wins -> [WindowSpace] -> ((Window -> X ()) -> X ()) -> X ()
shiftToNSP (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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
scratchpadWorkspaceTag :: String
scratchpadWorkspaceTag :: String
scratchpadWorkspaceTag = String
"NSP"
namedScratchpadManageHook :: NamedScratchpads
-> ManageHook
namedScratchpadManageHook :: NamedScratchpads -> ManageHook
namedScratchpadManageHook NamedScratchpads
nsps = do
NamedScratchpads
ns <- forall k a. Map k a -> [a]
Map.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. X a -> Query a
liftX (NamedScratchpads -> X NSPState
fillNSPState NamedScratchpads
nsps)
forall m. Monoid m => [m] -> m
composeAll forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NamedScratchpad
c -> NamedScratchpad -> Query Bool
query NamedScratchpad
c forall (m :: * -> *) a. (Monad m, Monoid a) => m Bool -> m a -> m a
--> NamedScratchpad -> ManageHook
hook NamedScratchpad
c) NamedScratchpads
ns
shiftToNSP :: [WindowSpace] -> ((Window -> X ()) -> X ()) -> X ()
shiftToNSP :: [WindowSpace] -> ((Window -> X ()) -> X ()) -> X ()
shiftToNSP [WindowSpace]
ws (Window -> X ()) -> X ()
f = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((String
scratchpadWorkspaceTag forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i l a. Workspace i l a -> i
W.tag) [WindowSpace]
ws) forall a b. (a -> b) -> a -> b
$
String -> X ()
addHiddenWorkspace String
scratchpadWorkspaceTag
(Window -> X ()) -> X ()
f ((WindowSet -> WindowSet) -> X ()
windows forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
mkDynamicNSP :: String -> Window -> NamedScratchpad
mkDynamicNSP :: String -> Window -> NamedScratchpad
mkDynamicNSP String
s Window
w =
NS { name :: String
name = String
s
, cmd :: String
cmd = String
""
, query :: Query Bool
query = (Window
w forall a. Eq a => a -> a -> Bool
==) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask
, hook :: ManageHook
hook = forall a. Monoid a => a
mempty
}
addDynamicNSP :: String -> Window -> X ()
addDynamicNSP :: String -> Window -> X ()
addDynamicNSP String
s Window
w = forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify @NSPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
s (String -> Window -> NamedScratchpad
mkDynamicNSP String
s Window
w)
removeDynamicNSP :: String -> X ()
removeDynamicNSP :: String -> X ()
removeDynamicNSP String
s = forall a (m :: * -> *).
(ExtensionClass a, XLike m) =>
(a -> a) -> m ()
XS.modify @NSPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Map k a
Map.delete @_ @NamedScratchpad String
s
dynamicNSPAction :: String -> X ()
dynamicNSPAction :: String -> X ()
dynamicNSPAction = (NamedScratchpad -> X ()) -> NamedScratchpads -> String -> X ()
customRunNamedScratchpadAction (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) []
toggleDynamicNSP :: String -> Window -> X ()
toggleDynamicNSP :: String -> Window -> X ()
toggleDynamicNSP String
s Window
w = do
NSPState Map String NamedScratchpad
nsps <- forall a (m :: * -> *). (ExtensionClass a, XLike m) => m a
XS.get
case Map String NamedScratchpad
nsps forall k a. Ord k => Map k a -> k -> Maybe a
!? String
s of
Maybe NamedScratchpad
Nothing -> String -> Window -> X ()
addDynamicNSP String
s Window
w
Just NamedScratchpad
nsp -> forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall a. Query a -> Window -> X a
runQuery (NamedScratchpad -> Query Bool
query NamedScratchpad
nsp) Window
w)
(String -> X ()
removeDynamicNSP String
s)
(String -> Window -> X ()
addDynamicNSP String
s Window
w)
namedScratchpadFilterOutWorkspace :: [WindowSpace] -> [WindowSpace]
namedScratchpadFilterOutWorkspace :: [WindowSpace] -> [WindowSpace]
namedScratchpadFilterOutWorkspace = forall a. (a -> Bool) -> [a] -> [a]
filter (\(W.Workspace String
tag Layout Window
_ Maybe (Stack Window)
_) -> String
tag forall a. Eq a => a -> a -> Bool
/= String
scratchpadWorkspaceTag)
{-# DEPRECATED namedScratchpadFilterOutWorkspace "Use XMonad.Util.WorkspaceCompare.filterOutWs [scratchpadWorkspaceTag] instead" #-}
namedScratchpadFilterOutWorkspacePP :: PP -> PP
namedScratchpadFilterOutWorkspacePP :: PP -> PP
namedScratchpadFilterOutWorkspacePP PP
pp = PP
pp {
ppSort :: X ([WindowSpace] -> [WindowSpace])
ppSort = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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" #-}